{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Data.Yaml.Internal
    (
      ParseException(..)
    , prettyPrintParseException
    , Warning(..)
    , parse
    , decodeHelper
    , decodeHelper_
    , decodeAllHelper
    , decodeAllHelper_
    , textToScientific
    , stringScalar
    , defaultStringStyle
    , isSpecialString
    , specialStrings
    , isNumeric
    , objToStream
    , objToEvents
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), Applicative(..))
#endif
import Control.Applicative ((<|>))
import Control.Exception
import Control.Monad (when, unless)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Internal (JSONPath, JSONPathElement(..), formatError)
import Data.Aeson.Types hiding (parse)
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
import Data.Conduit ((.|), ConduitM, runConduit)
import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Strict as M
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, pack)
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 Data.Void (Void)

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

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
(Int -> ParseException -> ShowS)
-> (ParseException -> AnchorName)
-> ([ParseException] -> ShowS)
-> Show ParseException
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)

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 `" AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
anchor AnchorName -> ShowS
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
"  " AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Event -> AnchorName
forall a. Show a => a -> AnchorName
show Maybe Event
mbExpected
    , AnchorName
"but received"
    , AnchorName
"  " AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Event -> AnchorName
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" AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
s
      YamlParseException AnchorName
problem AnchorName
context YamlMark
mark -> [AnchorName] -> AnchorName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ AnchorName
"YAML parse exception at line " AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> AnchorName
forall a. Show a => a -> AnchorName
show (YamlMark -> Int
yamlLine YamlMark
mark) AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++
          AnchorName
", column " AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> AnchorName
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" AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
context AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
":\n"
        , AnchorName
problem
        ]
  ParseException
MultipleDocuments -> AnchorName
"Multiple YAML documents encountered"
  AesonException AnchorName
s -> AnchorName
"Aeson exception:\n" AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
s
  OtherParseException SomeException
exc -> AnchorName
"Generic parse exception:\n" AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> AnchorName
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: " AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
anchor
    , AnchorName
"  Value: " AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> AnchorName
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: " AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
fp AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchorName
"\n" AnchorName -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseException -> AnchorName
prettyPrintParseException ParseException
exc

defineAnchor :: Value -> String -> ReaderT JSONPath (ConduitM e o Parse) ()
defineAnchor :: Value -> AnchorName -> ReaderT JSONPath (ConduitM e o Parse) ()
defineAnchor Value
value AnchorName
name = (ParseState -> ParseState)
-> ReaderT JSONPath (ConduitM e o Parse) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map AnchorName Value -> Map AnchorName Value)
-> ParseState -> ParseState
modifyAnchors ((Map AnchorName Value -> Map AnchorName Value)
 -> ParseState -> ParseState)
-> (Map AnchorName Value -> Map AnchorName Value)
-> ParseState
-> ParseState
forall a b. (a -> b) -> a -> b
$ AnchorName -> Value -> Map AnchorName Value -> Map AnchorName Value
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 -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)
lookupAnchor :: AnchorName -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)
lookupAnchor AnchorName
name = (ParseState -> Maybe Value)
-> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (AnchorName -> Map AnchorName Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnchorName
name (Map AnchorName Value -> Maybe Value)
-> (ParseState -> Map AnchorName Value)
-> ParseState
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> Map AnchorName 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
/= :: Warning -> Warning -> Bool
$c/= :: Warning -> Warning -> Bool
== :: Warning -> Warning -> Bool
$c== :: Warning -> Warning -> Bool
Eq, Int -> Warning -> ShowS
[Warning] -> ShowS
Warning -> AnchorName
(Int -> Warning -> ShowS)
-> (Warning -> AnchorName) -> ([Warning] -> ShowS) -> Show Warning
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 -> ReaderT JSONPath (ConduitM e o Parse) ()
addWarning :: Warning -> ReaderT JSONPath (ConduitM e o Parse) ()
addWarning Warning
w = (ParseState -> ParseState)
-> ReaderT JSONPath (ConduitM e o 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 :: [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 (ResourceT IO)

requireEvent :: Event -> ReaderT JSONPath (ConduitM Event o Parse) ()
requireEvent :: Event -> ReaderT JSONPath (ConduitM Event o Parse) ()
requireEvent Event
e = do
    Maybe Event
f <- ConduitT Event o Parse (Maybe Event)
-> ReaderT JSONPath (ConduitM Event o Parse) (Maybe Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT Event o Parse (Maybe Event)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
    Bool
-> ReaderT JSONPath (ConduitM Event o Parse) ()
-> ReaderT JSONPath (ConduitM Event o 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) (ReaderT JSONPath (ConduitM Event o Parse) ()
 -> ReaderT JSONPath (ConduitM Event o Parse) ())
-> ReaderT JSONPath (ConduitM Event o Parse) ()
-> ReaderT JSONPath (ConduitM Event o Parse) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT JSONPath (ConduitM Event o Parse) ())
-> IO () -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall a b. (a -> b) -> a -> b
$ ParseException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO ()) -> ParseException -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Event -> Maybe Event -> ParseException
UnexpectedEvent Maybe Event
f (Maybe Event -> ParseException) -> Maybe Event -> ParseException
forall a b. (a -> b) -> a -> b
$ Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e

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

parseAll :: ReaderT JSONPath (ConduitM Event o Parse) [Value]
parseAll :: ReaderT JSONPath (ConduitM Event o Parse) [Value]
parseAll = do
    Maybe Event
streamStart <- ConduitT Event o Parse (Maybe Event)
-> ReaderT JSONPath (ConduitM Event o Parse) (Maybe Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT Event o Parse (Maybe Event)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
    case Maybe Event
streamStart of
        Maybe Event
Nothing ->
            -- empty string input
            [Value] -> ReaderT JSONPath (ConduitM Event o Parse) [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just Event
EventStreamStart ->
            -- empty file input, comment only string/file input
            ReaderT JSONPath (ConduitM Event o Parse) [Value]
forall o. ReaderT JSONPath (ConduitM Event o Parse) [Value]
parseDocs
        Maybe Event
_ -> Maybe Event -> ReaderT JSONPath (ConduitM Event o Parse) [Value]
forall (m :: * -> *) a. MonadIO m => Maybe Event -> m a
missed Maybe Event
streamStart
  where
    parseDocs :: ReaderT JSONPath (ConduitT Event o Parse) [Value]
parseDocs = do
        Maybe Event
documentStart <- ConduitT Event o Parse (Maybe Event)
-> ReaderT JSONPath (ConduitT Event o Parse) (Maybe Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT Event o Parse (Maybe Event)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
        case Maybe Event
documentStart of
            Just Event
EventStreamEnd -> [Value] -> ReaderT JSONPath (ConduitT Event o Parse) [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just Event
EventDocumentStart -> do
                Value
res <- ReaderT JSONPath (ConduitT Event o Parse) Value
forall o. ReaderT JSONPath (ConduitM Event o Parse) Value
parseO
                Event -> ReaderT JSONPath (ConduitT Event o Parse) ()
forall o. Event -> ReaderT JSONPath (ConduitM Event o Parse) ()
requireEvent Event
EventDocumentEnd
                (Value
res Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:) ([Value] -> [Value])
-> ReaderT JSONPath (ConduitT Event o Parse) [Value]
-> ReaderT JSONPath (ConduitT Event o Parse) [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT JSONPath (ConduitT Event o Parse) [Value]
parseDocs
            Maybe Event
_ -> Maybe Event -> ReaderT JSONPath (ConduitT Event o Parse) [Value]
forall (m :: * -> *) a. MonadIO m => Maybe Event -> m a
missed Maybe Event
documentStart
    missed :: Maybe Event -> m a
missed Maybe Event
event = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ParseException -> IO a
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO a) -> ParseException -> IO a
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
            -> ReaderT JSONPath (ConduitM Event o Parse) Text
parseScalar :: ByteString
-> Anchor
-> Style
-> Tag
-> ReaderT JSONPath (ConduitM Event o Parse) Text
parseScalar ByteString
v Anchor
a Style
style Tag
tag = do
    let res :: Text
res = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
v
    (AnchorName -> ReaderT JSONPath (ConduitM Event o Parse) ())
-> Anchor -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> AnchorName -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall e o.
Value -> AnchorName -> ReaderT JSONPath (ConduitM e o Parse) ()
defineAnchor (Style -> Tag -> Text -> Value
textToValue Style
style Tag
tag Text
res)) Anchor
a
    Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
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 (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 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 Text -> [Text] -> 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 (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 = Parser Scientific -> Text -> Either AnchorName Scientific
forall a. Parser a -> Text -> Either AnchorName a
Atto.parseOnly (Parser Scientific
num Parser Scientific -> Parser Text () -> Parser Scientific
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 (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 (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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Integer
octal))
      Parser Scientific -> Parser Scientific -> Parser Scientific
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 :: ReaderT JSONPath (ConduitM Event o Parse) Value
parseO :: ReaderT JSONPath (ConduitM Event o Parse) Value
parseO = do
    Maybe Event
me <- ConduitT Event o Parse (Maybe Event)
-> ReaderT JSONPath (ConduitM Event o Parse) (Maybe Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT Event o Parse (Maybe Event)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
    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)
-> ReaderT JSONPath (ConduitM Event o Parse) Text
-> ReaderT JSONPath (ConduitM Event o Parse) Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Anchor
-> Style
-> Tag
-> ReaderT JSONPath (ConduitM Event o Parse) Text
forall o.
ByteString
-> Anchor
-> Style
-> Tag
-> ReaderT JSONPath (ConduitM Event o Parse) Text
parseScalar ByteString
v Anchor
a Style
style Tag
tag
        Just (EventSequenceStart Tag
_ SequenceStyle
_ Anchor
a) -> Int
-> Anchor
-> ([Value] -> [Value])
-> ReaderT JSONPath (ConduitM Event o Parse) Value
forall o.
Int
-> Anchor
-> ([Value] -> [Value])
-> ReaderT JSONPath (ConduitM Event o Parse) Value
parseS Int
0 Anchor
a [Value] -> [Value]
forall a. a -> a
id
        Just (EventMappingStart Tag
_ MappingStyle
_ Anchor
a) -> Set Text
-> Anchor
-> HashMap Text Value
-> ReaderT JSONPath (ConduitM Event o Parse) Value
forall o.
Set Text
-> Anchor
-> HashMap Text Value
-> ReaderT JSONPath (ConduitM Event o Parse) Value
parseM Set Text
forall a. Monoid a => a
mempty Anchor
a HashMap Text Value
forall k v. HashMap k v
M.empty
        Just (EventAlias AnchorName
an) -> do
            Maybe Value
m <- AnchorName
-> ReaderT JSONPath (ConduitM Event o Parse) (Maybe Value)
forall e o.
AnchorName -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)
lookupAnchor AnchorName
an
            case Maybe Value
m of
                Maybe Value
Nothing -> IO Value -> ReaderT JSONPath (ConduitM Event o Parse) Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> ReaderT JSONPath (ConduitM Event o Parse) Value)
-> IO Value -> ReaderT JSONPath (ConduitM Event o Parse) Value
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Value
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO Value) -> ParseException -> IO Value
forall a b. (a -> b) -> a -> b
$ AnchorName -> ParseException
UnknownAlias AnchorName
an
                Just Value
v -> Value -> ReaderT JSONPath (ConduitM Event o Parse) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
        Maybe Event
_ -> IO Value -> ReaderT JSONPath (ConduitM Event o Parse) Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> ReaderT JSONPath (ConduitM Event o Parse) Value)
-> IO Value -> ReaderT JSONPath (ConduitM Event o Parse) Value
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Value
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO Value) -> ParseException -> IO Value
forall a b. (a -> b) -> a -> b
$ Maybe Event -> Maybe Event -> ParseException
UnexpectedEvent Maybe Event
me Maybe Event
forall a. Maybe a
Nothing

parseS :: Int
       -> Y.Anchor
       -> ([Value] -> [Value])
       -> ReaderT JSONPath (ConduitM Event o Parse) Value
parseS :: Int
-> Anchor
-> ([Value] -> [Value])
-> ReaderT JSONPath (ConduitM Event o Parse) Value
parseS !Int
n Anchor
a [Value] -> [Value]
front = do
    Maybe Event
me <- ConduitT Event o Parse (Maybe Event)
-> ReaderT JSONPath (ConduitM Event o Parse) (Maybe Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT Event o Parse (Maybe Event)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
    case Maybe Event
me of
        Just Event
EventSequenceEnd -> do
            ConduitT Event o Parse ()
-> ReaderT JSONPath (ConduitM Event o Parse) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ConduitT Event o Parse ()
 -> ReaderT JSONPath (ConduitM Event o Parse) ())
-> ConduitT Event o Parse ()
-> ReaderT JSONPath (ConduitM Event o Parse) ()
forall a b. (a -> b) -> a -> b
$ Int -> ConduitT Event o Parse ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1
            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 []
            (AnchorName -> ReaderT JSONPath (ConduitM Event o Parse) ())
-> Anchor -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> AnchorName -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall e o.
Value -> AnchorName -> ReaderT JSONPath (ConduitM e o Parse) ()
defineAnchor Value
res) Anchor
a
            Value -> ReaderT JSONPath (ConduitM Event o Parse) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res
        Maybe Event
_ -> do
            Value
o <- (JSONPath -> JSONPath)
-> ReaderT JSONPath (ConduitM Event o Parse) Value
-> ReaderT JSONPath (ConduitM Event o Parse) Value
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Int -> JSONPathElement
Index Int
n JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
:) ReaderT JSONPath (ConduitM Event o Parse) Value
forall o. ReaderT JSONPath (ConduitM Event o Parse) Value
parseO
            Int
-> Anchor
-> ([Value] -> [Value])
-> ReaderT JSONPath (ConduitM Event o Parse) Value
forall o.
Int
-> Anchor
-> ([Value] -> [Value])
-> ReaderT JSONPath (ConduitM Event o Parse) Value
parseS (Int -> Int
forall a. Enum a => a -> a
succ Int
n) Anchor
a (([Value] -> [Value])
 -> ReaderT JSONPath (ConduitM Event o Parse) Value)
-> ([Value] -> [Value])
-> ReaderT JSONPath (ConduitM Event o 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 :: Set Text
       -> Y.Anchor
       -> M.HashMap Text Value
       -> ReaderT JSONPath (ConduitM Event o Parse) Value
parseM :: Set Text
-> Anchor
-> HashMap Text Value
-> ReaderT JSONPath (ConduitM Event o Parse) Value
parseM Set Text
mergedKeys Anchor
a HashMap Text Value
front = do
    Maybe Event
me <- ConduitT Event o Parse (Maybe Event)
-> ReaderT JSONPath (ConduitM Event o Parse) (Maybe Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT Event o Parse (Maybe Event)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
    case Maybe Event
me of
        Just Event
EventMappingEnd -> do
            let res :: Value
res = HashMap Text Value -> Value
Object HashMap Text Value
front
            (AnchorName -> ReaderT JSONPath (ConduitM Event o Parse) ())
-> Anchor -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> AnchorName -> ReaderT JSONPath (ConduitM Event o Parse) ()
forall e o.
Value -> AnchorName -> ReaderT JSONPath (ConduitM e o Parse) ()
defineAnchor Value
res) Anchor
a
            Value -> ReaderT JSONPath (ConduitM Event o Parse) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res
        Maybe Event
_ -> do
            Text
s <- case Maybe Event
me of
                    Just (EventScalar ByteString
v Tag
tag Style
style Anchor
a') -> ByteString
-> Anchor
-> Style
-> Tag
-> ReaderT JSONPath (ConduitM Event o Parse) Text
forall o.
ByteString
-> Anchor
-> Style
-> Tag
-> ReaderT JSONPath (ConduitM Event o Parse) Text
parseScalar ByteString
v Anchor
a' Style
style Tag
tag
                    Just (EventAlias AnchorName
an) -> do
                        Maybe Value
m <- AnchorName
-> ReaderT JSONPath (ConduitM Event o Parse) (Maybe Value)
forall e o.
AnchorName -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)
lookupAnchor AnchorName
an
                        case Maybe Value
m of
                            Maybe Value
Nothing -> IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text)
-> IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Text
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO Text) -> ParseException -> IO Text
forall a b. (a -> b) -> a -> b
$ AnchorName -> ParseException
UnknownAlias AnchorName
an
                            Just (String Text
t) -> Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
                            Just Value
v -> IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text)
-> IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Text
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO Text) -> ParseException -> IO Text
forall a b. (a -> b) -> a -> b
$ AnchorName -> Value -> ParseException
NonStringKeyAlias AnchorName
an Value
v
                    Maybe Event
_ -> do
                        JSONPath
path <- ReaderT JSONPath (ConduitM Event o Parse) JSONPath
forall r (m :: * -> *). MonadReader r m => m r
ask
                        IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text)
-> IO Text -> ReaderT JSONPath (ConduitM Event o Parse) Text
forall a b. (a -> b) -> a -> b
$ ParseException -> IO Text
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO Text) -> ParseException -> IO Text
forall a b. (a -> b) -> a -> b
$ JSONPath -> ParseException
NonStringKey JSONPath
path

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

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

parseSrc :: ReaderT JSONPath (ConduitM Event Void Parse) val
         -> ConduitM () Event Parse ()
         -> IO (val, ParseState)
parseSrc :: ReaderT JSONPath (ConduitM Event Void Parse) val
-> ConduitM () Event Parse () -> IO (val, ParseState)
parseSrc ReaderT JSONPath (ConduitM Event Void Parse) val
eventParser ConduitM () Event Parse ()
src = ResourceT IO (val, ParseState) -> IO (val, ParseState)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (val, ParseState) -> IO (val, ParseState))
-> ResourceT IO (val, ParseState) -> IO (val, ParseState)
forall a b. (a -> b) -> a -> b
$ StateT ParseState (ResourceT IO) val
-> ParseState -> ResourceT IO (val, ParseState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
    (ConduitT () Void Parse val -> StateT ParseState (ResourceT IO) val
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void Parse val
 -> StateT ParseState (ResourceT IO) val)
-> ConduitT () Void Parse val
-> StateT ParseState (ResourceT IO) val
forall a b. (a -> b) -> a -> b
$ ConduitM () Event Parse ()
src ConduitM () Event Parse ()
-> ConduitM Event Void Parse val -> ConduitT () Void Parse val
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ReaderT JSONPath (ConduitM Event Void Parse) val
-> JSONPath -> ConduitM Event Void Parse val
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT JSONPath (ConduitM Event Void Parse) val
eventParser [])
    (Map AnchorName Value -> [Warning] -> ParseState
ParseState Map AnchorName Value
forall k a. Map k a
Map.empty [])

mkHelper :: ReaderT JSONPath (ConduitM Event Void 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
         -> ConduitM () Event Parse ()                       -- ^ the libyaml event (string/file) source
         -> IO (Either ParseException a)
mkHelper :: ReaderT JSONPath (ConduitM Event Void Parse) val
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> ConduitM () Event Parse ()
-> IO (Either ParseException a)
mkHelper ReaderT JSONPath (ConduitM Event Void Parse) val
eventParser SomeException -> IO (Either ParseException a)
onOtherExc (val, ParseState) -> Either ParseException a
extractResults ConduitM () Event Parse ()
src = IO (Either ParseException a)
-> [Handler (Either ParseException a)]
-> IO (Either ParseException a)
forall a. IO a -> [Handler a] -> IO 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
<$> ReaderT JSONPath (ConduitM Event Void Parse) val
-> ConduitM () Event Parse () -> IO (val, ParseState)
forall val.
ReaderT JSONPath (ConduitM Event Void Parse) val
-> ConduitM () Event Parse () -> IO (val, ParseState)
parseSrc ReaderT JSONPath (ConduitM Event Void Parse) val
eventParser ConduitM () Event Parse ()
src)
    [ (ParseException -> IO (Either ParseException a))
-> Handler (Either ParseException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ParseException -> IO (Either ParseException a))
 -> Handler (Either ParseException a))
-> (ParseException -> IO (Either ParseException a))
-> Handler (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ \ParseException
pe -> Either ParseException a -> IO (Either ParseException 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 (Either ParseException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((YamlException -> IO (Either ParseException a))
 -> Handler (Either ParseException a))
-> (YamlException -> IO (Either ParseException a))
-> Handler (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ \YamlException
ye -> Either ParseException a -> IO (Either ParseException 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 (Either ParseException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeAsyncException -> IO (Either ParseException a))
 -> Handler (Either ParseException a))
-> (SomeAsyncException -> IO (Either ParseException a))
-> Handler (Either ParseException a)
forall a b. (a -> b) -> a -> b
$ \SomeAsyncException
sae -> SomeAsyncException -> IO (Either ParseException a)
forall e a. Exception e => e -> IO a
throwIO (SomeAsyncException
sae :: SomeAsyncException)
    , (SomeException -> IO (Either ParseException a))
-> Handler (Either ParseException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler SomeException -> IO (Either ParseException a)
onOtherExc
    ]

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

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

catchLeft :: SomeException -> IO (Either ParseException a)
catchLeft :: SomeException -> IO (Either ParseException a)
catchLeft = Either ParseException a -> IO (Either ParseException 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
              => ConduitM () Event Parse ()
              -> IO (Either ParseException ([Warning], a))
decodeHelper_ :: ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], a))
decodeHelper_ = ReaderT JSONPath (ConduitM Event Void Parse) Value
-> (SomeException -> IO (Either ParseException ([Warning], a)))
-> ((Value, ParseState) -> Either ParseException ([Warning], a))
-> ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], a))
forall val a.
ReaderT JSONPath (ConduitM Event Void Parse) val
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> ConduitM () Event Parse ()
-> IO (Either ParseException a)
mkHelper ReaderT JSONPath (ConduitM Event Void Parse) Value
forall o. ReaderT JSONPath (ConduitM Event o Parse) Value
parse SomeException -> IO (Either ParseException ([Warning], a))
forall a. SomeException -> IO (Either ParseException a)
catchLeft (((Value, ParseState) -> Either ParseException ([Warning], a))
 -> ConduitM () Event Parse ()
 -> IO (Either ParseException ([Warning], a)))
-> ((Value, ParseState) -> Either ParseException ([Warning], a))
-> ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], a))
forall a b. (a -> b) -> a -> b
$ \(Value
v, ParseState
st) ->
    case (Value -> Parser a) -> Value -> Either AnchorName a
forall a b. (a -> Parser b) -> a -> Either AnchorName b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v of
        Left AnchorName
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
$ AnchorName -> ParseException
AesonException AnchorName
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
                 => ConduitM () Event Parse ()
                 -> IO (Either ParseException ([Warning], [a]))
decodeAllHelper_ :: ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], [a]))
decodeAllHelper_ = ReaderT JSONPath (ConduitM Event Void Parse) [Value]
-> (SomeException -> IO (Either ParseException ([Warning], [a])))
-> (([Value], ParseState)
    -> Either ParseException ([Warning], [a]))
-> ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], [a]))
forall val a.
ReaderT JSONPath (ConduitM Event Void Parse) val
-> (SomeException -> IO (Either ParseException a))
-> ((val, ParseState) -> Either ParseException a)
-> ConduitM () Event Parse ()
-> IO (Either ParseException a)
mkHelper ReaderT JSONPath (ConduitM Event Void Parse) [Value]
forall o. ReaderT JSONPath (ConduitM Event o Parse) [Value]
parseAll SomeException -> IO (Either ParseException ([Warning], [a]))
forall a. SomeException -> IO (Either ParseException a)
catchLeft ((([Value], ParseState) -> Either ParseException ([Warning], [a]))
 -> ConduitM () Event Parse ()
 -> IO (Either ParseException ([Warning], [a])))
-> (([Value], ParseState)
    -> Either ParseException ([Warning], [a]))
-> ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], [a]))
forall a b. (a -> b) -> a -> b
$ \([Value]
vs, ParseState
st) ->
    case (Value -> Either AnchorName a) -> [Value] -> Either AnchorName [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Value -> Parser a) -> Value -> Either AnchorName a
forall a b. (a -> Parser b) -> a -> Either AnchorName b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON) [Value]
vs of
        Left AnchorName
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
$ AnchorName -> ParseException
AesonException AnchorName
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 -> AnchorName
T.unpack (Text -> AnchorName) -> 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 -> AnchorName
T.unpack (Text -> AnchorName) -> 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 = (AnchorName -> Bool)
-> (Scientific -> Bool) -> Either AnchorName Scientific -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> AnchorName -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> Scientific -> Bool
forall a b. a -> b -> a
const Bool
True) (Either AnchorName Scientific -> Bool)
-> (Text -> Either AnchorName Scientific) -> Text -> Bool
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 :: 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 :: 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 (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 HashMap Text 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 (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) (HashMap Text Value -> [Pair]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Text Value
o)
      where
        pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
        pairToEvents :: Pair -> [Event] -> [Event]
pairToEvents (Text
k, Value
v) = Value -> [Event] -> [Event]
objToEvents' (Text -> Value
String Text
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