{-# 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

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), Applicative(..))
#endif
import Control.Applicative ((<|>))
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.Aeson hiding (AesonException)
#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
import Data.Aeson.Internal (formatError)
import Data.Aeson.Types hiding (parse, Parser)
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.Prelude (SerialT)
import Streamly.Internal.Data.Parser (Parser)
import qualified Streamly.Internal.Data.Parser as Parser
import qualified Streamly.Internal.Data.Stream.IsStream.Eliminate as Stream
import Streamly.Internal.Data.Parser.ParserK.Type (toParserK)
import qualified Streamly.Internal.Data.Parser.ParserD.Type as ParserD
#if MIN_VERSION_streamly(0,8,1)
import Streamly.Internal.Data.Stream.IsStream.Lift (hoist)
#else
import Streamly.Internal.Data.Parser.ParserK.Type (fromParserK, fromEffect)
import Streamly.Internal.Data.Stream.StreamK (hoist)
#endif




#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 -> AnchorName
_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 -> AnchorName
forall a.
(Int -> a -> ShowS)
-> (a -> AnchorName) -> ([a] -> ShowS) -> Show a
showList :: [ParseException] -> ShowS
$cshowList :: [ParseException] -> ShowS
show :: ParseException -> AnchorName
$cshow :: ParseException -> AnchorName
showsPrec :: Int -> ParseException -> ShowS
$cshowsPrec :: Int -> ParseException -> ShowS
Show, Typeable, 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
$cto :: forall x. Rep ParseException x -> ParseException
$cfrom :: forall x. ParseException -> Rep ParseException x
Generic, ParseException -> ()
forall a. (a -> ()) -> NFData a
rnf :: ParseException -> ()
$crnf :: ParseException -> ()
NFData)

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

instance Exception ParseException where
#if MIN_VERSION_base(4, 8, 0)
  displayException :: ParseException -> AnchorName
displayException = ParseException -> AnchorName
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 -> AnchorName
prettyPrintParseException ParseException
pe = case ParseException
pe of
  ParseException
NonScalarKey -> AnchorName
"Non scalar key"
  UnknownAlias AnchorName
anchor -> AnchorName
"Unknown alias `" forall a. [a] -> [a] -> [a]
++ AnchorName
anchor forall a. [a] -> [a] -> [a]
++ AnchorName
"`"
  UnexpectedEvent { _expected :: ParseException -> Maybe Event
_expected = Maybe Event
mbExpected, _received :: ParseException -> Maybe Event
_received = Maybe Event
mbUnexpected } -> [AnchorName] -> AnchorName
unlines
    [ AnchorName
"Unexpected event: expected"
    , AnchorName
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> AnchorName
show Maybe Event
mbExpected
    , AnchorName
"but received"
    , AnchorName
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> AnchorName
show Maybe Event
mbUnexpected
    ]
  InvalidYaml Maybe YamlException
mbYamlError -> case Maybe YamlException
mbYamlError of
    Maybe YamlException
Nothing -> AnchorName
"Unspecified YAML error"
    Just YamlException
yamlError -> case YamlException
yamlError of
      YamlException AnchorName
s -> AnchorName
"YAML exception:\n" forall a. [a] -> [a] -> [a]
++ AnchorName
s
      YamlParseException AnchorName
problem AnchorName
context YamlMark
mark -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ AnchorName
"YAML parse exception at line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> AnchorName
show (YamlMark -> Int
yamlLine YamlMark
mark) forall a. [a] -> [a] -> [a]
++
          AnchorName
", column " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> AnchorName
show (YamlMark -> Int
yamlColumn YamlMark
mark)
        , case AnchorName
context of
            AnchorName
"" -> AnchorName
":\n"
            -- The context seems to include a leading "while" or similar.
            AnchorName
_  -> AnchorName
",\n" forall a. [a] -> [a] -> [a]
++ AnchorName
context forall a. [a] -> [a] -> [a]
++ AnchorName
":\n"
        , AnchorName
problem
        ]
  ParseException
MultipleDocuments -> AnchorName
"Multiple YAML documents encountered"
  AesonException AnchorName
s -> AnchorName
"Aeson exception:\n" forall a. [a] -> [a] -> [a]
++ AnchorName
s
  OtherParseException SomeException
exc -> AnchorName
"Generic parse exception:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> AnchorName
show SomeException
exc
  NonStringKey JSONPath
path -> JSONPath -> ShowS
formatError JSONPath
path AnchorName
"Non-string keys are not supported"
  NonStringKeyAlias AnchorName
anchor Value
value -> [AnchorName] -> AnchorName
unlines
    [ AnchorName
"Non-string key alias:"
    , AnchorName
"  Anchor name: " forall a. [a] -> [a] -> [a]
++ AnchorName
anchor
    , AnchorName
"  Value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> AnchorName
show Value
value
    ]
  ParseException
CyclicIncludes -> AnchorName
"Cyclic includes"
  LoadSettingsException AnchorName
fp ParseException
exc -> AnchorName
"Could not parse file as YAML: " forall a. [a] -> [a] -> [a]
++ AnchorName
fp forall a. [a] -> [a] -> [a]
++ AnchorName
"\n" forall a. [a] -> [a] -> [a]
++ ParseException -> AnchorName
prettyPrintParseException ParseException
exc


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

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

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

addWarning :: Warning -> Parser (ReaderT JSONPath Parse) Event ()
addWarning :: Warning -> Parser (ReaderT JSONPath Parse) Event ()
addWarning Warning
w = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([Warning] -> [Warning]) -> ParseState -> ParseState
modifyWarnings (Warning
w 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 :: [Warning]
parseStateWarnings = [Warning] -> [Warning]
f (ParseState -> [Warning]
parseStateWarnings ParseState
st)}

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

type Parse = StateT ParseState IO

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

{-# INLINE anyEvent #-}
anyEvent :: MonadCatch m => ParserD.Parser m a (Maybe a)
anyEvent :: forall (m :: * -> *) a. MonadCatch m => Parser m a (Maybe a)
anyEvent = forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Initial s b) -> (s -> m b) -> Parser m a b
ParserD.Parser forall {f :: * -> *} {p} {a} {s}.
Applicative f =>
p -> a -> f (Step s (Maybe a))
step forall {b}. m (Initial () b)
initial forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Maybe a)
extract
  where
  initial :: m (Initial () b)
initial = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s b. s -> Initial s b
ParserD.IPartial ()
  step :: p -> a -> f (Step s (Maybe a))
step p
_ a
a = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s b. Int -> b -> Step s b
ParserD.Done Int
0 (forall a. a -> Maybe a
Just a
a)
  extract :: p -> f (Maybe a)
extract p
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing


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


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

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

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


parseScalar :: ByteString -> Anchor -> Style -> Tag
            -> Parser (ReaderT JSONPath Parse) Event Text
parseScalar :: ByteString
-> Anchor
-> Style
-> Tag
-> Parser (ReaderT JSONPath Parse) Event Text
parseScalar ByteString
v Anchor
a Style
style Tag
tag = do
    let res :: Text
res = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
v
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> AnchorName -> Parser (ReaderT JSONPath Parse) Event ()
defineAnchor (Style -> Tag -> Text -> Value
textToValue Style
style Tag
tag Text
res)) Anchor
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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"null", Text
"Null", Text
"NULL", Text
"~", Text
""] = Value
Null
    | 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
    | 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 AnchorName 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 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 (Text -> Char
T.head Text
ref) Char -> Text -> Text
`T.cons` Text -> Text
T.tail Text
ref

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

    octal :: Parser Text Integer
octal = forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' forall {a}. (Bits a, Num a) => a -> Char -> a
step Integer
0 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 forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'7')
        step :: a -> Char -> a
step a
a Char
c = (a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
3) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Int
48)


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

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

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

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


parseSrc :: Parser (ReaderT JSONPath Parse) Event val
         -> SerialT IO Event
         -> IO (val, ParseState)
parseSrc :: forall val.
Parser (ReaderT JSONPath Parse) Event val
-> SerialT IO Event -> IO (val, ParseState)
parseSrc Parser (ReaderT JSONPath Parse) Event val
eventParser SerialT IO Event
src =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Map AnchorName Value -> [Warning] -> ParseState
ParseState forall k a. Map k a
Map.empty []) forall a b. (a -> b) -> a -> b
$
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT [] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a b.
MonadThrow m =>
Parser m a b -> SerialT m a -> m b
Stream.parse Parser (ReaderT JSONPath Parse) Event val
eventParser (forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
(forall x. m x -> n x) -> SerialT m a -> SerialT n a
hoist forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO SerialT IO Event
src)

mkHelper :: Parser (ReaderT JSONPath Parse) Event 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
         -> SerialT IO Event                                 -- ^ the libyaml event (string/file) source
         -> IO (Either ParseException a)
mkHelper :: forall val a.
Parser (ReaderT JSONPath Parse) Event val
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> SerialT IO Event
-> IO (Either ParseException a)
mkHelper Parser (ReaderT JSONPath Parse) Event val
eventParser SomeException -> IO (Either ParseException a)
onOtherExc (val, ParseState) -> Either ParseException a
extractResults SerialT IO Event
src = forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
catches
    ((val, ParseState) -> Either ParseException a
extractResults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall val.
Parser (ReaderT JSONPath Parse) Event val
-> SerialT IO Event -> IO (val, ParseState)
parseSrc Parser (ReaderT JSONPath Parse) Event val
eventParser SerialT IO Event
src)
    [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \ParseException
pe -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ParseException
pe :: ParseException)
    , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \YamlException
ye -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe YamlException -> ParseException
InvalidYaml forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (YamlException
ye :: YamlException)
    , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \SomeAsyncException
sae -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (SomeAsyncException
sae :: SomeAsyncException)
    , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler SomeException -> IO (Either ParseException a)
onOtherExc
    ]

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

decodeAllHelper :: FromJSON a
                => SerialT IO Event
                -> IO (Either ParseException ([Warning], Either String [a]))
decodeAllHelper :: forall a.
FromJSON a =>
SerialT IO Event
-> IO (Either ParseException ([Warning], Either AnchorName [a]))
decodeAllHelper = forall val a.
Parser (ReaderT JSONPath Parse) Event val
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> SerialT IO Event
-> IO (Either ParseException a)
mkHelper Parser (ReaderT JSONPath Parse) Event [Value]
parseAll forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ \([Value]
vs, ParseState
st) ->
    forall a b. b -> Either a b
Right (ParseState -> [Warning]
parseStateWarnings ParseState
st, forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> Parser b) -> a -> Either AnchorName b
parseEither 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ParseException
OtherParseException

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

decodeAllHelper_ :: FromJSON a
                 => SerialT IO Event
                 -> IO (Either ParseException ([Warning], [a]))
decodeAllHelper_ :: forall a.
FromJSON a =>
SerialT IO Event -> IO (Either ParseException ([Warning], [a]))
decodeAllHelper_ = forall val a.
Parser (ReaderT JSONPath Parse) Event val
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> SerialT IO Event
-> IO (Either ParseException a)
mkHelper Parser (ReaderT JSONPath Parse) Event [Value]
parseAll forall a. SomeException -> IO (Either ParseException a)
catchLeft forall a b. (a -> b) -> a -> b
$ \([Value]
vs, ParseState
st) ->
    case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> Parser b) -> a -> Either AnchorName b
parseEither forall a. FromJSON a => Value -> Parser a
parseJSON) [Value]
vs of
        Left AnchorName
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ AnchorName -> ParseException
AesonException AnchorName
e
        Right [a]
xs -> 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 -> AnchorName
T.unpack 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 -> AnchorName
T.unpack 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 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 = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) (forall a b. a -> b -> a
const Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either AnchorName 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
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Event
EventDocumentStart
    forall a b. (a -> b) -> a -> b
$ 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' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Maybe a
Nothing
      forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Value -> [Event] -> [Event]
objToEvents' (Event
EventSequenceEnd forall a. a -> [a] -> [a]
: [Event]
rest) (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 forall a. Maybe a
Nothing
      forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pair -> [Event] -> [Event]
pairToEvents (Event
EventMappingEnd forall a. a -> [a] -> [a]
: [Event]
rest) (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 forall a b. (a -> b) -> a -> b
$ Key -> Text
toText Key
k) 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 forall a. Maybe a
Nothing Text
s forall a. a -> [a] -> [a]
: [Event]
rest

    objToEvents' Value
Null [Event]
rest = ByteString -> Tag -> Style -> Anchor -> Event
EventScalar ByteString
"null" Tag
NullTag Style
PlainNoTag forall a. Maybe a
Nothing 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 forall a. Maybe a
Nothing 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 forall a. Maybe a
Nothing 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 forall a. Eq a => a -> a -> Bool
== Int
0 = Integer -> Builder
BB.integerDec 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 forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: [Event]
rest


#if !MIN_VERSION_streamly(0,8,1)
instance (MonadThrow m, MonadReader r m, MonadCatch m) => MonadReader r (Parser m a) where
    {-# INLINE ask #-}
    ask = fromEffect ask
    {-# INLINE local #-}
    local f (fromParserK -> ParserD.Parser step init' extract) =
      toParserK $ ParserD.Parser ((local f .) . step)
             (local f init')
             (local f . extract)


instance (MonadThrow m, MonadState s m) => MonadState s (Parser m a) where
    {-# INLINE get #-}
    get = fromEffect get
    {-# INLINE put #-}
    put = fromEffect . put


instance (MonadThrow m, MonadIO m) => MonadIO (Parser m a) where
    {-# INLINE liftIO #-}
    liftIO = fromEffect . liftIO
#endif