{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Data.Yaml.Internal
    (
      ParseException(..)
    , prettyPrintParseException
    , Warning(..)
    , parse
    , decodeHelper
    , decodeHelper_
    , decodeAllHelper
    , decodeAllHelper_
    , textToScientific
    , stringScalar
    , defaultStringStyle
    , isSpecialString
    , specialStrings
    , isNumeric
    , objToStream
    , objToEvents
    , anyEvent
    , missed
    ) where

import Control.Monad (when, unless, void)
import Control.Monad.IO.Class (MonadIO(..))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), Applicative(..))
#endif
import Control.Applicative ((<|>))
import Control.Monad.State.Strict (MonadState(..), StateT(..), modify, gets)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as M
import Data.Aeson.KeyMap (KeyMap)
#else
import qualified Data.HashMap.Strict as M
#endif
#if MIN_VERSION_aeson(2,2,0)
import Data.Aeson.Types hiding (parse, Parser, AesonException)
#else
import Data.Aeson.Internal (formatError)
import Data.Aeson hiding (AesonException)
import Data.Aeson.Types hiding (parse, Parser)
#endif
import qualified Data.Attoparsec.Text as Atto
import Data.Bits (shiftL, (.|.))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Builder.Scientific (scientificBuilder)
import Data.Char (toUpper, ord)
import Data.List (foldl', (\\))
import qualified Data.HashSet as HashSet
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import Data.Scientific (Scientific, base10Exponent, coefficient)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable
import qualified Data.Vector as V
import GHC.Generics (Generic)
import Control.DeepSeq

import qualified Text.Libyaml as Y
import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)

import Control.Exception.Safe

import Streamly.Data.Stream (Stream)
import Streamly.Data.ParserK (ParserK)
import qualified Streamly.Data.Fold as Fold
import qualified Streamly.Data.Parser as Parser
import qualified Streamly.Data.ParserK as ParserK
import qualified Streamly.Data.StreamK as StreamK
import qualified Streamly.Internal.Data.StreamK as StreamK (hoist)

#if MIN_VERSION_aeson(2,0,0)
fromText :: T.Text -> K.Key
fromText :: Text -> Key
fromText = Text -> Key
K.fromText

toText :: K.Key -> T.Text
toText :: Key -> Text
toText = Key -> Text
K.toText
#else
fromText :: T.Text -> T.Text
fromText = id

toText :: Key -> T.Text
toText = id

type KeyMap a = M.HashMap Text a
type Key = Text
#endif

data ParseException = NonScalarKey
                    | UnknownAlias { ParseException -> String
_anchorName :: Y.AnchorName }
                    | UnexpectedEvent { ParseException -> Maybe Event
_received :: Maybe Event
                                      , ParseException -> Maybe Event
_expected :: Maybe Event
                                      }
                    | InvalidYaml (Maybe YamlException)
                    | MultipleDocuments
                    | AesonException String
                    | OtherParseException SomeException
                    | NonStringKey JSONPath
                    | NonStringKeyAlias Y.AnchorName Value
                    | CyclicIncludes
                    | LoadSettingsException FilePath ParseException
    deriving (Int -> ParseException -> ShowS
[ParseException] -> ShowS
ParseException -> String
(Int -> ParseException -> ShowS)
-> (ParseException -> String)
-> ([ParseException] -> ShowS)
-> Show ParseException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseException -> ShowS
showsPrec :: Int -> ParseException -> ShowS
$cshow :: ParseException -> String
show :: ParseException -> String
$cshowList :: [ParseException] -> ShowS
showList :: [ParseException] -> ShowS
Show, Typeable, (forall x. ParseException -> Rep ParseException x)
-> (forall x. Rep ParseException x -> ParseException)
-> Generic ParseException
forall x. Rep ParseException x -> ParseException
forall x. ParseException -> Rep ParseException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParseException -> Rep ParseException x
from :: forall x. ParseException -> Rep ParseException x
$cto :: forall x. Rep ParseException x -> ParseException
to :: forall x. Rep ParseException x -> ParseException
Generic, ParseException -> ()
(ParseException -> ()) -> NFData ParseException
forall a. (a -> ()) -> NFData a
$crnf :: ParseException -> ()
rnf :: ParseException -> ()
NFData)

instance NFData SomeException where rnf :: SomeException -> ()
rnf !SomeException
_ = ()

instance Exception ParseException where
#if MIN_VERSION_base(4, 8, 0)
  displayException :: ParseException -> String
displayException = ParseException -> String
prettyPrintParseException
#endif

-- | Alternative to 'show' to display a 'ParseException' on the screen.
--   Instead of displaying the data constructors applied to their arguments,
--   a more textual output is returned. For example, instead of printing:
--
-- > InvalidYaml (Just (YamlParseException {yamlProblem = "did not find expected ',' or '}'", yamlContext = "while parsing a flow mapping", yamlProblemMark = YamlMark {yamlIndex = 42, yamlLine = 2, yamlColumn = 12}})))
--
--   It looks more pleasant to print:
--
-- > YAML parse exception at line 2, column 12,
-- > while parsing a flow mapping:
-- > did not find expected ',' or '}'
--
-- Since 0.8.11
prettyPrintParseException :: ParseException -> String
prettyPrintParseException :: ParseException -> String
prettyPrintParseException ParseException
pe = case ParseException
pe of
  ParseException
NonScalarKey -> String
"Non scalar key"
  UnknownAlias String
anchor -> String
"Unknown alias `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
anchor String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
  UnexpectedEvent { _expected :: ParseException -> Maybe Event
_expected = Maybe Event
mbExpected, _received :: ParseException -> Maybe Event
_received = Maybe Event
mbUnexpected } -> [String] -> String
unlines
    [ String
"Unexpected event: expected"
    , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Event -> String
forall a. Show a => a -> String
show Maybe Event
mbExpected
    , String
"but received"
    , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Event -> String
forall a. Show a => a -> String
show Maybe Event
mbUnexpected
    ]
  InvalidYaml Maybe YamlException
mbYamlError -> case Maybe YamlException
mbYamlError of
    Maybe YamlException
Nothing -> String
"Unspecified YAML error"
    Just YamlException
yamlError -> case YamlException
yamlError of
      YamlException String
s -> String
"YAML exception:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
      YamlParseException String
problem String
context YamlMark
mark -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"YAML parse exception at line " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (YamlMark -> Int
yamlLine YamlMark
mark) String -> ShowS
forall a. [a] -> [a] -> [a]
++
          String
", column " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (YamlMark -> Int
yamlColumn YamlMark
mark)
        , case String
context of
            String
"" -> String
":\n"
            -- The context seems to include a leading "while" or similar.
            String
_  -> String
",\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
context String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n"
        , String
problem
        ]
  ParseException
MultipleDocuments -> String
"Multiple YAML documents encountered"
  AesonException String
s -> String
"Aeson exception:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
  OtherParseException SomeException
exc -> String
"Generic parse exception:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exc
  NonStringKey JSONPath
path -> JSONPath -> ShowS
formatError JSONPath
path String
"Non-string keys are not supported"
  NonStringKeyAlias String
anchor Value
value -> [String] -> String
unlines
    [ String
"Non-string key alias:"
    , String
"  Anchor name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
anchor
    , String
"  Value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
value
    ]
  ParseException
CyclicIncludes -> String
"Cyclic includes"
  LoadSettingsException String
fp ParseException
exc -> String
"Could not parse file as YAML: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseException -> String
prettyPrintParseException ParseException
exc


defineAnchor :: Value -> String -> ParserK Event Parse ()
defineAnchor :: Value -> String -> ParserK Event Parse ()
defineAnchor Value
value String
name = (ParseState -> ParseState) -> ParserK Event Parse ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map String Value -> Map String Value) -> ParseState -> ParseState
modifyAnchors ((Map String Value -> Map String Value)
 -> ParseState -> ParseState)
-> (Map String Value -> Map String Value)
-> ParseState
-> ParseState
forall a b. (a -> b) -> a -> b
$ String -> Value -> Map String Value -> Map String Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name Value
value)
  where
    modifyAnchors :: (Map String Value -> Map String Value) -> ParseState -> ParseState
    modifyAnchors :: (Map String Value -> Map String Value) -> ParseState -> ParseState
modifyAnchors Map String Value -> Map String Value
f ParseState
st =  ParseState
st {parseStateAnchors = f (parseStateAnchors st)}

lookupAnchor :: String -> ParserK Event Parse (Maybe Value)
lookupAnchor :: String -> ParserK Event Parse (Maybe Value)
lookupAnchor String
name = (ParseState -> Maybe Value) -> ParserK Event Parse (Maybe Value)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (String -> Map String Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name (Map String Value -> Maybe Value)
-> (ParseState -> Map String Value) -> ParseState -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> Map String Value
parseStateAnchors)

data Warning = DuplicateKey !JSONPath
    deriving (Warning -> Warning -> Bool
(Warning -> Warning -> Bool)
-> (Warning -> Warning -> Bool) -> Eq Warning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Warning -> Warning -> Bool
== :: Warning -> Warning -> Bool
$c/= :: Warning -> Warning -> Bool
/= :: Warning -> Warning -> Bool
Eq, Int -> Warning -> ShowS
[Warning] -> ShowS
Warning -> String
(Int -> Warning -> ShowS)
-> (Warning -> String) -> ([Warning] -> ShowS) -> Show Warning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Warning -> ShowS
showsPrec :: Int -> Warning -> ShowS
$cshow :: Warning -> String
show :: Warning -> String
$cshowList :: [Warning] -> ShowS
showList :: [Warning] -> ShowS
Show)

addWarning :: Warning -> ParserK Event Parse ()
addWarning :: Warning -> ParserK Event Parse ()
addWarning Warning
w = (ParseState -> ParseState) -> ParserK Event Parse ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([Warning] -> [Warning]) -> ParseState -> ParseState
modifyWarnings (Warning
w Warning -> [Warning] -> [Warning]
forall a. a -> [a] -> [a]
:))
  where
    modifyWarnings :: ([Warning] -> [Warning]) -> ParseState -> ParseState
    modifyWarnings :: ([Warning] -> [Warning]) -> ParseState -> ParseState
modifyWarnings [Warning] -> [Warning]
f ParseState
st =  ParseState
st {parseStateWarnings = f (parseStateWarnings st)}

data ParseState = ParseState {
  ParseState -> Map String Value
parseStateAnchors  :: Map String Value
, ParseState -> [Warning]
parseStateWarnings :: [Warning]
}

type Parse = StateT ParseState IO

requireEvent :: Event -> ParserK Event Parse ()
requireEvent :: Event -> ParserK Event Parse ()
requireEvent Event
e = do
    Maybe Event
f <- ParserK Event Parse (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
    Bool -> ParserK Event Parse () -> ParserK Event Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Event
f Maybe Event -> Maybe Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e) (ParserK Event Parse () -> ParserK Event Parse ())
-> ParserK Event Parse () -> ParserK Event Parse ()
forall a b. (a -> b) -> a -> b
$ Maybe Event -> ParserK Event Parse ()
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> ParserK a m b
missed (Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e)

{-# INLINE anyEvent #-}
anyEvent :: MonadCatch m => ParserK a m (Maybe a)
anyEvent :: forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent = Parser a m (Maybe a) -> ParserK a m (Maybe a)
forall (m :: * -> *) a b. Monad m => Parser a m b -> ParserK a m b
ParserK.adapt (Parser a m (Maybe a) -> ParserK a m (Maybe a))
-> Parser a m (Maybe a) -> ParserK a m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Fold m a (Maybe a) -> Parser a m (Maybe a)
forall (m :: * -> *) a b. Monad m => Fold m a b -> Parser a m b
Parser.fromFold Fold m a (Maybe a)
forall (m :: * -> *) a. Monad m => Fold m a (Maybe a)
Fold.one

{-# INLINE peekEvent #-}
peekEvent :: MonadCatch m => ParserK a m (Maybe a)
peekEvent :: forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
peekEvent = Parser a m (Maybe a) -> ParserK a m (Maybe a)
forall (m :: * -> *) a b. Monad m => Parser a m b -> ParserK a m b
ParserK.adapt (Parser a m (Maybe a) -> ParserK a m (Maybe a))
-> Parser a m (Maybe a) -> ParserK a m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Parser a m (Maybe a) -> Parser a m (Maybe a)
forall (m :: * -> *) a b. Monad m => Parser a m b -> Parser a m b
Parser.lookAhead (Parser a m (Maybe a) -> Parser a m (Maybe a))
-> Parser a m (Maybe a) -> Parser a m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Fold m a (Maybe a) -> Parser a m (Maybe a)
forall (m :: * -> *) a b. Monad m => Fold m a b -> Parser a m b
Parser.fromFold Fold m a (Maybe a)
forall (m :: * -> *) a. Monad m => Fold m a (Maybe a)
Fold.one

parse :: JSONPath -> ParserK Event Parse Value
parse :: JSONPath -> ParserK Event Parse Value
parse JSONPath
env = do
    [Value]
docs <- JSONPath -> ParserK Event Parse [Value]
parseAll JSONPath
env
    case [Value]
docs of
        [] -> Value -> ParserK Event Parse Value
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
        [Value
doc] -> Value -> ParserK Event Parse Value
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
doc
        [Value]
_ -> IO Value -> ParserK Event Parse Value
forall a. IO a -> ParserK Event Parse a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> ParserK Event Parse Value)
-> IO Value -> ParserK Event Parse Value
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Value
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO ParseException
MultipleDocuments


parseAll :: JSONPath -> ParserK Event Parse [Value]
parseAll :: JSONPath -> ParserK Event Parse [Value]
parseAll JSONPath
env = do
    Maybe Event
e <- ParserK Event Parse (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
    case Maybe Event
e of
      Maybe Event
Nothing -> [Value] -> ParserK Event Parse [Value]
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just Event
EventStreamStart ->
        JSONPath -> ParserK Event Parse [Value]
parseDocs JSONPath
env
      Maybe Event
_ -> Maybe Event -> ParserK Event Parse [Value]
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> ParserK a m b
missed Maybe Event
e

parseDocs :: JSONPath -> ParserK Event Parse [Value]
parseDocs :: JSONPath -> ParserK Event Parse [Value]
parseDocs JSONPath
env = do
  Maybe Event
e <- ParserK Event Parse (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
  case Maybe Event
e of
      Just Event
EventStreamEnd -> [Value] -> ParserK Event Parse [Value]
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just Event
EventDocumentStart -> do
          Value
res <- JSONPath -> ParserK Event Parse Value
parseO JSONPath
env
          Event -> ParserK Event Parse ()
requireEvent Event
EventDocumentEnd
          (Value
res Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:) ([Value] -> [Value])
-> ParserK Event Parse [Value] -> ParserK Event Parse [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSONPath -> ParserK Event Parse [Value]
parseDocs JSONPath
env
      Maybe Event
_ -> Maybe Event -> ParserK Event Parse [Value]
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> ParserK a m b
missed Maybe Event
e

missed :: (MonadIO m, MonadThrow m) => Maybe Event -> ParserK a m b
missed :: forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> ParserK a m b
missed Maybe Event
event = IO b -> ParserK a m b
forall a. IO a -> ParserK a m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ParserK a m b) -> IO b -> ParserK a m b
forall a b. (a -> b) -> a -> b
$ ParseException -> IO b
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (ParseException -> IO b) -> ParseException -> IO b
forall a b. (a -> b) -> a -> b
$ Maybe Event -> Maybe Event -> ParseException
UnexpectedEvent Maybe Event
event Maybe Event
forall a. Maybe a
Nothing


parseScalar :: ByteString -> Anchor -> Style -> Tag
            -> ParserK Event Parse Text
parseScalar :: ByteString -> Anchor -> Style -> Tag -> ParserK Event Parse Text
parseScalar ByteString
v Anchor
a Style
style Tag
tag = do
    let res :: Text
res = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
v
    (String -> ParserK Event Parse ())
-> Anchor -> ParserK Event Parse ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> String -> ParserK Event Parse ()
defineAnchor (Style -> Tag -> Text -> Value
textToValue Style
style Tag
tag Text
res)) Anchor
a
    Text -> ParserK Event Parse Text
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
res


textToValue :: Style -> Tag -> Text -> Value
textToValue :: Style -> Tag -> Text -> Value
textToValue Style
SingleQuoted Tag
_ Text
t = Text -> Value
String Text
t
textToValue Style
DoubleQuoted Tag
_ Text
t = Text -> Value
String Text
t
textToValue Style
_ Tag
StrTag Text
t = Text -> Value
String Text
t
textToValue Style
Folded Tag
_ Text
t = Text -> Value
String Text
t
textToValue Style
_ Tag
_ Text
t
    | Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"null", Text
"Null", Text
"NULL", Text
"~", Text
""] = Value
Null
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text
t Text -> Text -> Bool
`isLike`) [Text
"y", Text
"yes", Text
"on", Text
"true"] = Bool -> Value
Bool Bool
True
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text
t Text -> Text -> Bool
`isLike`) [Text
"n", Text
"no", Text
"off", Text
"false"] = Bool -> Value
Bool Bool
False
    | Right Scientific
x <- Text -> Either String Scientific
textToScientific Text
t = Scientific -> Value
Number Scientific
x
    | Bool
otherwise = Text -> Value
String Text
t
  where Text
x isLike :: Text -> Text -> Bool
`isLike` Text
ref = Text
x Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
ref, Text -> Text
T.toUpper Text
ref, Text
titleCased]
          where titleCased :: Text
titleCased = Char -> Char
toUpper (HasCallStack => Text -> Char
Text -> Char
T.head Text
ref) Char -> Text -> Text
`T.cons` HasCallStack => Text -> Text
Text -> Text
T.tail Text
ref

textToScientific :: Text -> Either String Scientific
textToScientific :: Text -> Either String Scientific
textToScientific = Parser Scientific -> Text -> Either String Scientific
forall a. Parser a -> Text -> Either String a
Atto.parseOnly (Parser Scientific
num Parser Scientific -> Parser Text () -> Parser Scientific
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput)
  where
    num :: Parser Scientific
num = (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> Parser Text Integer -> Parser Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Text
"0x" Parser Text Text -> Parser Text Integer -> Parser Text Integer
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Integer
forall a. (Integral a, Bits a) => Parser a
Atto.hexadecimal))
      Parser Scientific -> Parser Scientific -> Parser Scientific
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> Parser Text Integer -> Parser Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Text
"0o" Parser Text Text -> Parser Text Integer -> Parser Text Integer
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Integer
octal))
      Parser Scientific -> Parser Scientific -> Parser Scientific
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Scientific
Atto.scientific

    octal :: Parser Text Integer
octal = (Integer -> Char -> Integer) -> Integer -> Text -> Integer
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Integer -> Char -> Integer
forall {a}. (Bits a, Num a) => a -> Char -> a
step Integer
0 (Text -> Integer) -> Parser Text Text -> Parser Text Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
Atto.takeWhile1 Char -> Bool
isOctalDigit
      where
        isOctalDigit :: Char -> Bool
isOctalDigit Char
c = (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'7')
        step :: a -> Char -> a
step a
a Char
c = (a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
3) a -> a -> a
forall a. Bits a => a -> a -> a
.|. Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48)


parseO :: JSONPath -> ParserK Event Parse Value
parseO :: JSONPath -> ParserK Event Parse Value
parseO JSONPath
env = do
    Maybe Event
me <- ParserK Event Parse (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
    case Maybe Event
me of
        Just (EventScalar ByteString
v Tag
tag Style
style Anchor
a) -> Style -> Tag -> Text -> Value
textToValue Style
style Tag
tag (Text -> Value)
-> ParserK Event Parse Text -> ParserK Event Parse Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Anchor -> Style -> Tag -> ParserK Event Parse Text
parseScalar ByteString
v Anchor
a Style
style Tag
tag
        Just (EventSequenceStart Tag
_ SequenceStyle
_ Anchor
a) -> JSONPath
-> Int
-> Anchor
-> ([Value] -> [Value])
-> ParserK Event Parse Value
parseS JSONPath
env Int
0 Anchor
a [Value] -> [Value]
forall a. a -> a
id
        Just (EventMappingStart Tag
_ MappingStyle
_ Anchor
a) -> JSONPath
-> Set Key -> Anchor -> KeyMap Value -> ParserK Event Parse Value
parseM JSONPath
env Set Key
forall a. Monoid a => a
mempty Anchor
a KeyMap Value
forall v. KeyMap v
M.empty
        Just (EventAlias String
an) -> do
            Maybe Value
m <- String -> ParserK Event Parse (Maybe Value)
lookupAnchor String
an
            case Maybe Value
m of
                Maybe Value
Nothing -> IO Value -> ParserK Event Parse Value
forall a. IO a -> ParserK Event Parse a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> ParserK Event Parse Value)
-> IO Value -> ParserK Event Parse Value
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Value
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (ParseException -> IO Value) -> ParseException -> IO Value
forall a b. (a -> b) -> a -> b
$ String -> ParseException
UnknownAlias String
an
                Just Value
v -> Value -> ParserK Event Parse Value
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
        Maybe Event
_ -> Maybe Event -> ParserK Event Parse Value
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> ParserK a m b
missed Maybe Event
me

parseS :: JSONPath
       -> Int
       -> Y.Anchor
       -> ([Value] -> [Value])
       -> ParserK Event Parse Value
parseS :: JSONPath
-> Int
-> Anchor
-> ([Value] -> [Value])
-> ParserK Event Parse Value
parseS JSONPath
env !Int
n Anchor
a [Value] -> [Value]
front = do
    Maybe Event
me <- ParserK Event Parse (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
peekEvent
    case Maybe Event
me of
        Just Event
EventSequenceEnd -> do
            ParserK Event Parse (Maybe Event) -> ParserK Event Parse ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParserK Event Parse (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
            let res :: Value
res = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array) -> [Value] -> Array
forall a b. (a -> b) -> a -> b
$ [Value] -> [Value]
front []
            (String -> ParserK Event Parse ())
-> Anchor -> ParserK Event Parse ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> String -> ParserK Event Parse ()
defineAnchor Value
res) Anchor
a
            Value -> ParserK Event Parse Value
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res
        Maybe Event
_ -> do
            Value
o <- JSONPath -> ParserK Event Parse Value
parseO (Int -> JSONPathElement
Index Int
n JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
: JSONPath
env)
            JSONPath
-> Int
-> Anchor
-> ([Value] -> [Value])
-> ParserK Event Parse Value
parseS JSONPath
env (Int -> Int
forall a. Enum a => a -> a
succ Int
n) Anchor
a (([Value] -> [Value]) -> ParserK Event Parse Value)
-> ([Value] -> [Value]) -> ParserK Event Parse Value
forall a b. (a -> b) -> a -> b
$ [Value] -> [Value]
front ([Value] -> [Value]) -> ([Value] -> [Value]) -> [Value] -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Value
o

parseM :: JSONPath
       -> Set Key
       -> Y.Anchor
       -> KeyMap Value
       -> ParserK Event Parse Value
parseM :: JSONPath
-> Set Key -> Anchor -> KeyMap Value -> ParserK Event Parse Value
parseM JSONPath
env Set Key
mergedKeys Anchor
a KeyMap Value
front = do
    Maybe Event
me <- ParserK Event Parse (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
    case Maybe Event
me of
        Just Event
EventMappingEnd -> do
            let res :: Value
res = KeyMap Value -> Value
Object KeyMap Value
front
            (String -> ParserK Event Parse ())
-> Anchor -> ParserK Event Parse ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> String -> ParserK Event Parse ()
defineAnchor Value
res) Anchor
a
            Value -> ParserK Event Parse Value
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res
        Maybe Event
_ -> do
            Key
s <- case Maybe Event
me of
                    Just (EventScalar ByteString
v Tag
tag Style
style Anchor
a') -> Text -> Key
fromText (Text -> Key)
-> ParserK Event Parse Text -> ParserK Event Parse Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Anchor -> Style -> Tag -> ParserK Event Parse Text
parseScalar ByteString
v Anchor
a' Style
style Tag
tag
                    Just (EventAlias String
an) -> do
                        Maybe Value
m <- String -> ParserK Event Parse (Maybe Value)
lookupAnchor String
an
                        case Maybe Value
m of
                            Maybe Value
Nothing -> IO Key -> ParserK Event Parse Key
forall a. IO a -> ParserK Event Parse a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Key -> ParserK Event Parse Key)
-> IO Key -> ParserK Event Parse Key
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Key
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (ParseException -> IO Key) -> ParseException -> IO Key
forall a b. (a -> b) -> a -> b
$ String -> ParseException
UnknownAlias String
an
                            Just (String Text
t) -> Key -> ParserK Event Parse Key
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> ParserK Event Parse Key) -> Key -> ParserK Event Parse Key
forall a b. (a -> b) -> a -> b
$ Text -> Key
fromText Text
t
                            Just Value
v -> IO Key -> ParserK Event Parse Key
forall a. IO a -> ParserK Event Parse a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Key -> ParserK Event Parse Key)
-> IO Key -> ParserK Event Parse Key
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Key
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (ParseException -> IO Key) -> ParseException -> IO Key
forall a b. (a -> b) -> a -> b
$ String -> Value -> ParseException
NonStringKeyAlias String
an Value
v
                    Maybe Event
_ -> do
                        IO Key -> ParserK Event Parse Key
forall a. IO a -> ParserK Event Parse a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Key -> ParserK Event Parse Key)
-> IO Key -> ParserK Event Parse Key
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Key
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (ParseException -> IO Key) -> ParseException -> IO Key
forall a b. (a -> b) -> a -> b
$ JSONPath -> ParseException
NonStringKey JSONPath
env

            (Set Key
mergedKeys', KeyMap Value
al') <- do
              let newEnv :: JSONPath
newEnv = Key -> JSONPathElement
Key Key
s JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
: JSONPath
env
              Value
o <- JSONPath -> ParserK Event Parse Value
parseO JSONPath
newEnv
              let al :: ParserK Event Parse (Set Key, KeyMap Value)
al = do
                      Bool -> ParserK Event Parse () -> ParserK Event Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Key -> KeyMap Value -> Bool
forall a. Key -> KeyMap a -> Bool
M.member Key
s KeyMap Value
front Bool -> Bool -> Bool
&& Key -> Set Key -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Key
s Set Key
mergedKeys) (ParserK Event Parse () -> ParserK Event Parse ())
-> ParserK Event Parse () -> ParserK Event Parse ()
forall a b. (a -> b) -> a -> b
$ do
                          let path :: JSONPath
path = JSONPath -> JSONPath
forall a. [a] -> [a]
reverse JSONPath
newEnv
                          Warning -> ParserK Event Parse ()
addWarning (JSONPath -> Warning
DuplicateKey JSONPath
path)
                      (Set Key, KeyMap Value)
-> ParserK Event Parse (Set Key, KeyMap Value)
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Set Key -> Set Key
forall a. Ord a => a -> Set a -> Set a
Set.delete Key
s Set Key
mergedKeys, Key -> Value -> KeyMap Value -> KeyMap Value
forall v. Key -> v -> KeyMap v -> KeyMap v
M.insert Key
s Value
o KeyMap Value
front)
              if Key
s Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
"<<"
                         then case Value
o of
                                  Object KeyMap Value
l  -> (Set Key, KeyMap Value)
-> ParserK Event Parse (Set Key, KeyMap Value)
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMap Value -> (Set Key, KeyMap Value)
merge KeyMap Value
l)
                                  Array Array
l -> (Set Key, KeyMap Value)
-> ParserK Event Parse (Set Key, KeyMap Value)
forall a. a -> ParserK Event Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Set Key, KeyMap Value)
 -> ParserK Event Parse (Set Key, KeyMap Value))
-> (Set Key, KeyMap Value)
-> ParserK Event Parse (Set Key, KeyMap Value)
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> (Set Key, KeyMap Value)
merge (KeyMap Value -> (Set Key, KeyMap Value))
-> KeyMap Value -> (Set Key, KeyMap Value)
forall a b. (a -> b) -> a -> b
$ (KeyMap Value -> Value -> KeyMap Value)
-> KeyMap Value -> [Value] -> KeyMap Value
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' KeyMap Value -> Value -> KeyMap Value
mergeObjects KeyMap Value
forall v. KeyMap v
M.empty ([Value] -> KeyMap Value) -> [Value] -> KeyMap Value
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
l
                                  Value
_          -> ParserK Event Parse (Set Key, KeyMap Value)
al
                         else ParserK Event Parse (Set Key, KeyMap Value)
al
            JSONPath
-> Set Key -> Anchor -> KeyMap Value -> ParserK Event Parse Value
parseM JSONPath
env Set Key
mergedKeys' Anchor
a KeyMap Value
al'
    where mergeObjects :: KeyMap Value -> Value -> KeyMap Value
mergeObjects KeyMap Value
al (Object KeyMap Value
om) = KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
M.union KeyMap Value
al KeyMap Value
om
          mergeObjects KeyMap Value
al Value
_           = KeyMap Value
al

          merge :: KeyMap Value -> (Set Key, KeyMap Value)
merge KeyMap Value
xs = ([Key] -> Set Key
forall a. Ord a => [a] -> Set a
Set.fromList (KeyMap Value -> [Key]
forall v. KeyMap v -> [Key]
M.keys KeyMap Value
xs [Key] -> [Key] -> [Key]
forall a. Eq a => [a] -> [a] -> [a]
\\ KeyMap Value -> [Key]
forall v. KeyMap v -> [Key]
M.keys KeyMap Value
front), KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
M.union KeyMap Value
front KeyMap Value
xs)


parseSrc :: (JSONPath -> ParserK Event Parse val)
         -> Stream IO Event
         -> IO (val, ParseState)
parseSrc :: forall val.
(JSONPath -> ParserK Event Parse val)
-> Stream IO Event -> IO (val, ParseState)
parseSrc JSONPath -> ParserK Event Parse val
eventParser Stream IO Event
src =
  (StateT ParseState IO val -> ParseState -> IO (val, ParseState))
-> ParseState -> StateT ParseState IO val -> IO (val, ParseState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ParseState IO val -> ParseState -> IO (val, ParseState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Map String Value -> [Warning] -> ParseState
ParseState Map String Value
forall k a. Map k a
Map.empty []) (StateT ParseState IO val -> IO (val, ParseState))
-> StateT ParseState IO val -> IO (val, ParseState)
forall a b. (a -> b) -> a -> b
$ do
      Either ParseError val
res <-
          ParserK Event Parse val
-> StreamK Parse Event
-> StateT ParseState IO (Either ParseError val)
forall (m :: * -> *) a b.
Monad m =>
ParserK a m b -> StreamK m a -> m (Either ParseError b)
StreamK.parse
              (JSONPath -> ParserK Event Parse val
eventParser [])
              ((forall x. IO x -> StateT ParseState IO x)
-> StreamK IO Event -> StreamK Parse Event
forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
(forall x. m x -> n x) -> StreamK m a -> StreamK n a
StreamK.hoist IO x -> StateT ParseState IO x
forall x. IO x -> StateT ParseState IO x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Stream IO Event -> StreamK IO Event
forall (m :: * -> *) a. Monad m => Stream m a -> StreamK m a
StreamK.fromStream Stream IO Event
src))
      case Either ParseError val
res of
        Left ParseError
err -> ParseError -> StateT ParseState IO val
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO ParseError
err
        Right val
val -> val -> StateT ParseState IO val
forall a. a -> StateT ParseState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure val
val

mkHelper :: (JSONPath -> ParserK Event Parse val)            -- ^ parse libyaml events as Value or [Value]
         -> (SomeException -> IO (Either ParseException a))  -- ^ what to do with unhandled exceptions
         -> ((val, ParseState) -> Either ParseException a)   -- ^ further transform and parse results
         -> Stream IO Event                                  -- ^ the libyaml event (string/file) source
         -> IO (Either ParseException a)
mkHelper :: forall val a.
(JSONPath -> ParserK Event Parse val)
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> Stream IO Event
-> IO (Either ParseException a)
mkHelper JSONPath -> ParserK Event Parse val
eventParser SomeException -> IO (Either ParseException a)
onOtherExc (val, ParseState) -> Either ParseException a
extractResults Stream IO Event
src = IO (Either ParseException a)
-> [Handler IO (Either ParseException a)]
-> IO (Either ParseException a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
catches
    ((val, ParseState) -> Either ParseException a
extractResults ((val, ParseState) -> Either ParseException a)
-> IO (val, ParseState) -> IO (Either ParseException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JSONPath -> ParserK Event Parse val)
-> Stream IO Event -> IO (val, ParseState)
forall val.
(JSONPath -> ParserK Event Parse val)
-> Stream IO Event -> IO (val, ParseState)
parseSrc JSONPath -> ParserK Event Parse val
eventParser Stream IO Event
src)
    [ (ParseException -> IO (Either ParseException a))
-> Handler IO (Either ParseException a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((ParseException -> IO (Either ParseException a))
 -> Handler IO (Either ParseException a))
-> (ParseException -> IO (Either ParseException a))
-> Handler IO (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ \ParseException
pe -> Either ParseException a -> IO (Either ParseException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseException a -> IO (Either ParseException a))
-> Either ParseException a -> IO (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ ParseException -> Either ParseException a
forall a b. a -> Either a b
Left (ParseException
pe :: ParseException)
    , (YamlException -> IO (Either ParseException a))
-> Handler IO (Either ParseException a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((YamlException -> IO (Either ParseException a))
 -> Handler IO (Either ParseException a))
-> (YamlException -> IO (Either ParseException a))
-> Handler IO (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ \YamlException
ye -> Either ParseException a -> IO (Either ParseException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseException a -> IO (Either ParseException a))
-> Either ParseException a -> IO (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ ParseException -> Either ParseException a
forall a b. a -> Either a b
Left (ParseException -> Either ParseException a)
-> ParseException -> Either ParseException a
forall a b. (a -> b) -> a -> b
$ Maybe YamlException -> ParseException
InvalidYaml (Maybe YamlException -> ParseException)
-> Maybe YamlException -> ParseException
forall a b. (a -> b) -> a -> b
$ YamlException -> Maybe YamlException
forall a. a -> Maybe a
Just (YamlException
ye :: YamlException)
    , (SomeAsyncException -> IO (Either ParseException a))
-> Handler IO (Either ParseException a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeAsyncException -> IO (Either ParseException a))
 -> Handler IO (Either ParseException a))
-> (SomeAsyncException -> IO (Either ParseException a))
-> Handler IO (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ \SomeAsyncException
sae -> SomeAsyncException -> IO (Either ParseException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (SomeAsyncException
sae :: SomeAsyncException)
    , (SomeException -> IO (Either ParseException a))
-> Handler IO (Either ParseException a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler SomeException -> IO (Either ParseException a)
onOtherExc
    ]

decodeHelper :: FromJSON a
             => Stream IO Y.Event
             -> IO (Either ParseException ([Warning], Either String a))
decodeHelper :: forall a.
FromJSON a =>
Stream IO Event
-> IO (Either ParseException ([Warning], Either String a))
decodeHelper = (JSONPath -> ParserK Event Parse Value)
-> (SomeException
    -> IO (Either ParseException ([Warning], Either String a)))
-> ((Value, ParseState)
    -> Either ParseException ([Warning], Either String a))
-> Stream IO Event
-> IO (Either ParseException ([Warning], Either String a))
forall val a.
(JSONPath -> ParserK Event Parse val)
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> Stream IO Event
-> IO (Either ParseException a)
mkHelper JSONPath -> ParserK Event Parse Value
parse SomeException
-> IO (Either ParseException ([Warning], Either String a))
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (((Value, ParseState)
  -> Either ParseException ([Warning], Either String a))
 -> Stream IO Event
 -> IO (Either ParseException ([Warning], Either String a)))
-> ((Value, ParseState)
    -> Either ParseException ([Warning], Either String a))
-> Stream IO Event
-> IO (Either ParseException ([Warning], Either String a))
forall a b. (a -> b) -> a -> b
$ \(Value
v, ParseState
st) ->
    ([Warning], Either String a)
-> Either ParseException ([Warning], Either String a)
forall a b. b -> Either a b
Right (ParseState -> [Warning]
parseStateWarnings ParseState
st, (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

decodeAllHelper :: FromJSON a
                => Stream IO Event
                -> IO (Either ParseException ([Warning], Either String [a]))
decodeAllHelper :: forall a.
FromJSON a =>
Stream IO Event
-> IO (Either ParseException ([Warning], Either String [a]))
decodeAllHelper = (JSONPath -> ParserK Event Parse [Value])
-> (SomeException
    -> IO (Either ParseException ([Warning], Either String [a])))
-> (([Value], ParseState)
    -> Either ParseException ([Warning], Either String [a]))
-> Stream IO Event
-> IO (Either ParseException ([Warning], Either String [a]))
forall val a.
(JSONPath -> ParserK Event Parse val)
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> Stream IO Event
-> IO (Either ParseException a)
mkHelper JSONPath -> ParserK Event Parse [Value]
parseAll SomeException
-> IO (Either ParseException ([Warning], Either String [a]))
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO ((([Value], ParseState)
  -> Either ParseException ([Warning], Either String [a]))
 -> Stream IO Event
 -> IO (Either ParseException ([Warning], Either String [a])))
-> (([Value], ParseState)
    -> Either ParseException ([Warning], Either String [a]))
-> Stream IO Event
-> IO (Either ParseException ([Warning], Either String [a]))
forall a b. (a -> b) -> a -> b
$ \([Value]
vs, ParseState
st) ->
    ([Warning], Either String [a])
-> Either ParseException ([Warning], Either String [a])
forall a b. b -> Either a b
Right (ParseState -> [Warning]
parseStateWarnings ParseState
st, (Value -> Either String a) -> [Value] -> Either String [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON) [Value]
vs)

catchLeft :: SomeException -> IO (Either ParseException a)
catchLeft :: forall a. SomeException -> IO (Either ParseException a)
catchLeft = Either ParseException a -> IO (Either ParseException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseException a -> IO (Either ParseException a))
-> (SomeException -> Either ParseException a)
-> SomeException
-> IO (Either ParseException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> Either ParseException a
forall a b. a -> Either a b
Left (ParseException -> Either ParseException a)
-> (SomeException -> ParseException)
-> SomeException
-> Either ParseException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ParseException
OtherParseException

decodeHelper_ :: FromJSON a
              => Stream IO Event
              -> IO (Either ParseException ([Warning], a))
decodeHelper_ :: forall a.
FromJSON a =>
Stream IO Event -> IO (Either ParseException ([Warning], a))
decodeHelper_ = (JSONPath -> ParserK Event Parse Value)
-> (SomeException -> IO (Either ParseException ([Warning], a)))
-> ((Value, ParseState) -> Either ParseException ([Warning], a))
-> Stream IO Event
-> IO (Either ParseException ([Warning], a))
forall val a.
(JSONPath -> ParserK Event Parse val)
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> Stream IO Event
-> IO (Either ParseException a)
mkHelper JSONPath -> ParserK Event Parse Value
parse SomeException -> IO (Either ParseException ([Warning], a))
forall a. SomeException -> IO (Either ParseException a)
catchLeft (((Value, ParseState) -> Either ParseException ([Warning], a))
 -> Stream IO Event -> IO (Either ParseException ([Warning], a)))
-> ((Value, ParseState) -> Either ParseException ([Warning], a))
-> Stream IO Event
-> IO (Either ParseException ([Warning], a))
forall a b. (a -> b) -> a -> b
$ \(Value
v, ParseState
st) ->
    case (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v of
        Left String
e -> ParseException -> Either ParseException ([Warning], a)
forall a b. a -> Either a b
Left (ParseException -> Either ParseException ([Warning], a))
-> ParseException -> Either ParseException ([Warning], a)
forall a b. (a -> b) -> a -> b
$ String -> ParseException
AesonException String
e
        Right a
x -> ([Warning], a) -> Either ParseException ([Warning], a)
forall a b. b -> Either a b
Right (ParseState -> [Warning]
parseStateWarnings ParseState
st, a
x)

decodeAllHelper_ :: FromJSON a
                 => Stream IO Event
                 -> IO (Either ParseException ([Warning], [a]))
decodeAllHelper_ :: forall a.
FromJSON a =>
Stream IO Event -> IO (Either ParseException ([Warning], [a]))
decodeAllHelper_ = (JSONPath -> ParserK Event Parse [Value])
-> (SomeException -> IO (Either ParseException ([Warning], [a])))
-> (([Value], ParseState)
    -> Either ParseException ([Warning], [a]))
-> Stream IO Event
-> IO (Either ParseException ([Warning], [a]))
forall val a.
(JSONPath -> ParserK Event Parse val)
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> Stream IO Event
-> IO (Either ParseException a)
mkHelper JSONPath -> ParserK Event Parse [Value]
parseAll SomeException -> IO (Either ParseException ([Warning], [a]))
forall a. SomeException -> IO (Either ParseException a)
catchLeft ((([Value], ParseState) -> Either ParseException ([Warning], [a]))
 -> Stream IO Event -> IO (Either ParseException ([Warning], [a])))
-> (([Value], ParseState)
    -> Either ParseException ([Warning], [a]))
-> Stream IO Event
-> IO (Either ParseException ([Warning], [a]))
forall a b. (a -> b) -> a -> b
$ \([Value]
vs, ParseState
st) ->
    case (Value -> Either String a) -> [Value] -> Either String [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON) [Value]
vs of
        Left String
e -> ParseException -> Either ParseException ([Warning], [a])
forall a b. a -> Either a b
Left (ParseException -> Either ParseException ([Warning], [a]))
-> ParseException -> Either ParseException ([Warning], [a])
forall a b. (a -> b) -> a -> b
$ String -> ParseException
AesonException String
e
        Right [a]
xs -> ([Warning], [a]) -> Either ParseException ([Warning], [a])
forall a b. b -> Either a b
Right (ParseState -> [Warning]
parseStateWarnings ParseState
st, [a]
xs)

type StringStyle = Text -> ( Tag, Style )

-- | Encodes a string with the supplied style. This function handles the empty
-- string case properly to avoid https://github.com/snoyberg/yaml/issues/24
--
-- @since 0.11.2.0
stringScalar :: StringStyle -> Maybe Text -> Text -> Event
stringScalar :: StringStyle -> Maybe Text -> Text -> Event
stringScalar StringStyle
_ Maybe Text
anchor Text
"" = ByteString -> Tag -> Style -> Anchor -> Event
EventScalar ByteString
"" Tag
NoTag Style
SingleQuoted (Text -> String
T.unpack (Text -> String) -> Maybe Text -> Anchor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
anchor)
stringScalar StringStyle
stringStyle Maybe Text
anchor Text
s = ByteString -> Tag -> Style -> Anchor -> Event
EventScalar (Text -> ByteString
encodeUtf8 Text
s) Tag
tag Style
style (Text -> String
T.unpack (Text -> String) -> Maybe Text -> Anchor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
anchor)
  where
    ( Tag
tag, Style
style ) = StringStyle
stringStyle Text
s

-- |
-- @since 0.11.2.0
defaultStringStyle :: StringStyle
defaultStringStyle :: StringStyle
defaultStringStyle = \Text
s ->
    case () of
      ()
        | Text
"\n" Text -> Text -> Bool
`T.isInfixOf` Text
s -> ( Tag
NoTag, Style
Literal )
        | Text -> Bool
isSpecialString Text
s -> ( Tag
NoTag, Style
SingleQuoted )
        | Bool
otherwise -> ( Tag
NoTag, Style
PlainNoTag )

-- | Determine whether a string must be quoted in YAML and can't appear as plain text.
-- Useful if you want to use 'setStringStyle'.
--
-- @since 0.10.2.0
isSpecialString :: Text -> Bool
isSpecialString :: Text -> Bool
isSpecialString Text
s = Text
s Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet Text
specialStrings Bool -> Bool -> Bool
|| Text -> Bool
isNumeric Text
s

-- | Strings which must be escaped so as not to be treated as non-string scalars.
--
-- @since 0.8.32
specialStrings :: HashSet.HashSet Text
specialStrings :: HashSet Text
specialStrings = [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([Text] -> HashSet Text) -> [Text] -> HashSet Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words
    Text
"y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF null Null NULL ~ *"

-- |
-- @since 0.8.32
isNumeric :: Text -> Bool
isNumeric :: Text -> Bool
isNumeric = (String -> Bool)
-> (Scientific -> Bool) -> Either String Scientific -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> Scientific -> Bool
forall a b. a -> b -> a
const Bool
True) (Either String Scientific -> Bool)
-> (Text -> Either String Scientific) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Scientific
textToScientific

-- | Encode a value as a YAML document stream.
--
-- @since 0.11.2.0
objToStream :: ToJSON a => StringStyle -> a -> [Y.Event]
objToStream :: forall a. ToJSON a => StringStyle -> a -> [Event]
objToStream StringStyle
stringStyle a
o =
      (:) Event
EventStreamStart
    ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Event
EventDocumentStart
    ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ StringStyle -> a -> [Event] -> [Event]
forall a. ToJSON a => StringStyle -> a -> [Event] -> [Event]
objToEvents StringStyle
stringStyle a
o
        [ Event
EventDocumentEnd
        , Event
EventStreamEnd
        ]

-- | Encode a value as a list of 'Event's.
--
-- @since 0.11.2.0
objToEvents :: ToJSON a => StringStyle -> a -> [Y.Event] -> [Y.Event]
objToEvents :: forall a. ToJSON a => StringStyle -> a -> [Event] -> [Event]
objToEvents StringStyle
stringStyle = Value -> [Event] -> [Event]
objToEvents' (Value -> [Event] -> [Event])
-> (a -> Value) -> a -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON
  where
    objToEvents' :: Value -> [Event] -> [Event]
objToEvents' (Array Array
list) [Event]
rest =
        Tag -> SequenceStyle -> Anchor -> Event
EventSequenceStart Tag
NoTag SequenceStyle
AnySequence Anchor
forall a. Maybe a
Nothing
      Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: (Value -> [Event] -> [Event]) -> [Event] -> [Value] -> [Event]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Value -> [Event] -> [Event]
objToEvents' (Event
EventSequenceEnd Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
rest) (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
list)

    objToEvents' (Object KeyMap Value
o) [Event]
rest =
        Tag -> MappingStyle -> Anchor -> Event
EventMappingStart Tag
NoTag MappingStyle
AnyMapping Anchor
forall a. Maybe a
Nothing
      Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: (Pair -> [Event] -> [Event]) -> [Event] -> [Pair] -> [Event]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pair -> [Event] -> [Event]
pairToEvents (Event
EventMappingEnd Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
rest) (KeyMap Value -> [Pair]
forall v. KeyMap v -> [(Key, v)]
M.toList KeyMap Value
o)
      where
        pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
        pairToEvents :: Pair -> [Event] -> [Event]
pairToEvents (Key
k, Value
v) = Value -> [Event] -> [Event]
objToEvents' (Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Text
toText Key
k) ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Event] -> [Event]
objToEvents' Value
v

    objToEvents' (String Text
s) [Event]
rest = StringStyle -> Maybe Text -> Text -> Event
stringScalar StringStyle
stringStyle Maybe Text
forall a. Maybe a
Nothing Text
s Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
rest

    objToEvents' Value
Null [Event]
rest = ByteString -> Tag -> Style -> Anchor -> Event
EventScalar ByteString
"null" Tag
NullTag Style
PlainNoTag Anchor
forall a. Maybe a
Nothing Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
rest

    objToEvents' (Bool Bool
True) [Event]
rest = ByteString -> Tag -> Style -> Anchor -> Event
EventScalar ByteString
"true" Tag
BoolTag Style
PlainNoTag Anchor
forall a. Maybe a
Nothing Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
rest
    objToEvents' (Bool Bool
False) [Event]
rest = ByteString -> Tag -> Style -> Anchor -> Event
EventScalar ByteString
"false" Tag
BoolTag Style
PlainNoTag Anchor
forall a. Maybe a
Nothing Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
rest

    objToEvents' (Number Scientific
s) [Event]
rest =
      let builder :: Builder
builder
            -- Special case the 0 exponent to remove the trailing .0
            | Scientific -> Int
base10Exponent Scientific
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Integer -> Builder
BB.integerDec (Integer -> Builder) -> Integer -> Builder
forall a b. (a -> b) -> a -> b
$ Scientific -> Integer
coefficient Scientific
s
            | Bool
otherwise = Scientific -> Builder
scientificBuilder Scientific
s
          lbs :: ByteString
lbs = Builder -> ByteString
BB.toLazyByteString Builder
builder
          bs :: ByteString
bs = ByteString -> ByteString
BL.toStrict ByteString
lbs
       in ByteString -> Tag -> Style -> Anchor -> Event
EventScalar ByteString
bs Tag
IntTag Style
PlainNoTag Anchor
forall a. Maybe a
Nothing Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
rest

instance (MonadThrow m, MonadState s m) => MonadState s (ParserK a m) where
    {-# INLINE get #-}
    get :: ParserK a m s
get = m s -> ParserK a m s
forall (m :: * -> *) b a. Monad m => m b -> ParserK a m b
ParserK.fromEffect m s
forall s (m :: * -> *). MonadState s m => m s
get
    {-# INLINE put #-}
    put :: s -> ParserK a m ()
put = m () -> ParserK a m ()
forall (m :: * -> *) b a. Monad m => m b -> ParserK a m b
ParserK.fromEffect (m () -> ParserK a m ()) -> (s -> m ()) -> s -> ParserK a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put