{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
-- | NOTE: This module is a highly experimental preview release. It may change
-- drastically, or be entirely removed, in a future release.
module Data.Yaml.Parser where

import Control.Applicative
import Control.Monad (MonadPlus (..), liftM, ap)
import Control.Exception.Safe
import Control.Monad.IO.Class
import Control.Monad.Trans.Writer.Strict (tell, WriterT, runWriterT)
import Data.ByteString (ByteString)
import qualified Data.Map as Map
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid (..))
#endif
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup(..))
#endif
import Data.Yaml.Internal
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Read (signed, decimal)

import           Streamly.Prelude (SerialT)
import Streamly.Internal.Data.Parser (Parser)
import qualified Streamly.Internal.Data.Stream.IsStream.Eliminate as Stream
import qualified Streamly.Internal.Data.Stream.StreamK as K
import Streamly.Internal.Data.Parser.ParserK.Type (fromEffect, die)

import Text.Libyaml

newtype YamlParser a = YamlParser
    { YamlParser a -> AnchorMap -> Either Text a
unYamlParser :: AnchorMap -> Either Text a
    }
instance Functor YamlParser where
    fmap :: (a -> b) -> YamlParser a -> YamlParser b
fmap = (a -> b) -> YamlParser a -> YamlParser b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative YamlParser where
    pure :: a -> YamlParser a
pure = (AnchorMap -> Either Text a) -> YamlParser a
forall a. (AnchorMap -> Either Text a) -> YamlParser a
YamlParser ((AnchorMap -> Either Text a) -> YamlParser a)
-> (a -> AnchorMap -> Either Text a) -> a -> YamlParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text a -> AnchorMap -> Either Text a
forall a b. a -> b -> a
const (Either Text a -> AnchorMap -> Either Text a)
-> (a -> Either Text a) -> a -> AnchorMap -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either Text a
forall a b. b -> Either a b
Right
    <*> :: YamlParser (a -> b) -> YamlParser a -> YamlParser b
(<*>) = YamlParser (a -> b) -> YamlParser a -> YamlParser b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Alternative YamlParser where
    empty :: YamlParser a
empty = String -> YamlParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty"
    <|> :: YamlParser a -> YamlParser a -> YamlParser a
(<|>) = YamlParser a -> YamlParser a -> YamlParser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Semigroup (YamlParser a) where
    <> :: YamlParser a -> YamlParser a -> YamlParser a
(<>) = YamlParser a -> YamlParser a -> YamlParser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Monoid (YamlParser a) where
    mempty :: YamlParser a
mempty = String -> YamlParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mempty"
#if !MIN_VERSION_base(4,11,0)
    mappend = (<>)
#endif
instance Monad YamlParser where
    return :: a -> YamlParser a
return = a -> YamlParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    YamlParser AnchorMap -> Either Text a
f >>= :: YamlParser a -> (a -> YamlParser b) -> YamlParser b
>>= a -> YamlParser b
g = (AnchorMap -> Either Text b) -> YamlParser b
forall a. (AnchorMap -> Either Text a) -> YamlParser a
YamlParser ((AnchorMap -> Either Text b) -> YamlParser b)
-> (AnchorMap -> Either Text b) -> YamlParser b
forall a b. (a -> b) -> a -> b
$ \AnchorMap
am ->
        case AnchorMap -> Either Text a
f AnchorMap
am of
            Left Text
t -> Text -> Either Text b
forall a b. a -> Either a b
Left Text
t
            Right a
x -> YamlParser b -> AnchorMap -> Either Text b
forall a. YamlParser a -> AnchorMap -> Either Text a
unYamlParser (a -> YamlParser b
g a
x) AnchorMap
am
#if MIN_VERSION_base(4,13,0)
instance MonadFail YamlParser where
#endif
    fail :: String -> YamlParser a
fail = (AnchorMap -> Either Text a) -> YamlParser a
forall a. (AnchorMap -> Either Text a) -> YamlParser a
YamlParser ((AnchorMap -> Either Text a) -> YamlParser a)
-> (String -> AnchorMap -> Either Text a) -> String -> YamlParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text a -> AnchorMap -> Either Text a
forall a b. a -> b -> a
const (Either Text a -> AnchorMap -> Either Text a)
-> (String -> Either Text a)
-> String
-> AnchorMap
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a)
-> (String -> Text) -> String -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
instance MonadPlus YamlParser where
    mzero :: YamlParser a
mzero = String -> YamlParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mzero"
    mplus :: YamlParser a -> YamlParser a -> YamlParser a
mplus YamlParser a
a YamlParser a
b = (AnchorMap -> Either Text a) -> YamlParser a
forall a. (AnchorMap -> Either Text a) -> YamlParser a
YamlParser ((AnchorMap -> Either Text a) -> YamlParser a)
-> (AnchorMap -> Either Text a) -> YamlParser a
forall a b. (a -> b) -> a -> b
$ \AnchorMap
am ->
        case YamlParser a -> AnchorMap -> Either Text a
forall a. YamlParser a -> AnchorMap -> Either Text a
unYamlParser YamlParser a
a AnchorMap
am of
            Left Text
_ -> YamlParser a -> AnchorMap -> Either Text a
forall a. YamlParser a -> AnchorMap -> Either Text a
unYamlParser YamlParser a
b AnchorMap
am
            Either Text a
x -> Either Text a
x

lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue)
lookupAnchor :: String -> YamlParser (Maybe YamlValue)
lookupAnchor String
name = (AnchorMap -> Either Text (Maybe YamlValue))
-> YamlParser (Maybe YamlValue)
forall a. (AnchorMap -> Either Text a) -> YamlParser a
YamlParser ((AnchorMap -> Either Text (Maybe YamlValue))
 -> YamlParser (Maybe YamlValue))
-> (AnchorMap -> Either Text (Maybe YamlValue))
-> YamlParser (Maybe YamlValue)
forall a b. (a -> b) -> a -> b
$ Maybe YamlValue -> Either Text (Maybe YamlValue)
forall a b. b -> Either a b
Right (Maybe YamlValue -> Either Text (Maybe YamlValue))
-> (AnchorMap -> Maybe YamlValue)
-> AnchorMap
-> Either Text (Maybe YamlValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AnchorMap -> Maybe YamlValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name

withAnchor :: AnchorName -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
withAnchor :: String -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
withAnchor String
name Text
expected YamlValue -> YamlParser a
f = do
    Maybe YamlValue
mv <- String -> YamlParser (Maybe YamlValue)
lookupAnchor String
name
    case Maybe YamlValue
mv of
        Maybe YamlValue
Nothing -> String -> YamlParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> YamlParser a) -> String -> YamlParser a
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": unknown alias " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
        Just YamlValue
v -> YamlValue -> YamlParser a
f YamlValue
v

withMapping :: Text -> ([(Text, YamlValue)] -> YamlParser a) -> YamlValue -> YamlParser a
withMapping :: Text
-> ([(Text, YamlValue)] -> YamlParser a)
-> YamlValue
-> YamlParser a
withMapping Text
_ [(Text, YamlValue)] -> YamlParser a
f (Mapping [(Text, YamlValue)]
m Anchor
_) = [(Text, YamlValue)] -> YamlParser a
f [(Text, YamlValue)]
m
withMapping Text
expected [(Text, YamlValue)] -> YamlParser a
f (Alias String
an) = String -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
forall a.
String -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
withAnchor String
an Text
expected ((YamlValue -> YamlParser a) -> YamlParser a)
-> (YamlValue -> YamlParser a) -> YamlParser a
forall a b. (a -> b) -> a -> b
$ Text
-> ([(Text, YamlValue)] -> YamlParser a)
-> YamlValue
-> YamlParser a
forall a.
Text
-> ([(Text, YamlValue)] -> YamlParser a)
-> YamlValue
-> YamlParser a
withMapping Text
expected [(Text, YamlValue)] -> YamlParser a
f
withMapping Text
expected [(Text, YamlValue)] -> YamlParser a
_ YamlValue
v = Text -> YamlValue -> YamlParser a
forall a. Text -> YamlValue -> YamlParser a
typeMismatch Text
expected YamlValue
v

withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
withSequence Text
_ [YamlValue] -> YamlParser a
f (Sequence [YamlValue]
s Anchor
_) = [YamlValue] -> YamlParser a
f [YamlValue]
s
withSequence Text
expected [YamlValue] -> YamlParser a
f (Alias String
an) = String -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
forall a.
String -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
withAnchor String
an Text
expected ((YamlValue -> YamlParser a) -> YamlParser a)
-> (YamlValue -> YamlParser a) -> YamlParser a
forall a b. (a -> b) -> a -> b
$ Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
forall a.
Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
withSequence Text
expected [YamlValue] -> YamlParser a
f
withSequence Text
expected [YamlValue] -> YamlParser a
_ YamlValue
v = Text -> YamlValue -> YamlParser a
forall a. Text -> YamlValue -> YamlParser a
typeMismatch Text
expected YamlValue
v

withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
withText Text
_ Text -> YamlParser a
f (Scalar ByteString
s Tag
_ Style
_ Anchor
_) = Text -> YamlParser a
f (Text -> YamlParser a) -> Text -> YamlParser a
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
s
withText Text
expected Text -> YamlParser a
f (Alias String
an) = String -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
forall a.
String -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
withAnchor String
an Text
expected ((YamlValue -> YamlParser a) -> YamlParser a)
-> (YamlValue -> YamlParser a) -> YamlParser a
forall a b. (a -> b) -> a -> b
$ Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
forall a.
Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
withText Text
expected Text -> YamlParser a
f
withText Text
expected Text -> YamlParser a
_ YamlValue
v = Text -> YamlValue -> YamlParser a
forall a. Text -> YamlValue -> YamlParser a
typeMismatch Text
expected YamlValue
v

typeMismatch :: Text -> YamlValue -> YamlParser a
typeMismatch :: Text -> YamlValue -> YamlParser a
typeMismatch Text
expected YamlValue
v =
    String -> YamlParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> YamlParser a) -> String -> YamlParser a
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Expected "
        , Text -> String
unpack Text
expected
        , String
", but got: "
        , String
t
        ]
  where
    t :: String
t = case YamlValue
v of
        Mapping [(Text, YamlValue)]
_ Anchor
_ -> String
"mapping"
        Sequence [YamlValue]
_ Anchor
_ -> String
"sequence"
        Scalar ByteString
_ Tag
_ Style
_ Anchor
_ -> String
"scalar"
        Alias String
_ -> String
"alias"

class FromYaml a where
    fromYaml :: YamlValue -> YamlParser a
instance FromYaml YamlValue where
    fromYaml :: YamlValue -> YamlParser YamlValue
fromYaml = YamlValue -> YamlParser YamlValue
forall (m :: * -> *) a. Monad m => a -> m a
return
instance FromYaml a => FromYaml [a] where
    fromYaml :: YamlValue -> YamlParser [a]
fromYaml = Text
-> ([YamlValue] -> YamlParser [a]) -> YamlValue -> YamlParser [a]
forall a.
Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
withSequence Text
"[a]" ((YamlValue -> YamlParser a) -> [YamlValue] -> YamlParser [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM YamlValue -> YamlParser a
forall a. FromYaml a => YamlValue -> YamlParser a
fromYaml)
instance FromYaml Text where
    fromYaml :: YamlValue -> YamlParser Text
fromYaml = Text -> (Text -> YamlParser Text) -> YamlValue -> YamlParser Text
forall a.
Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
withText Text
"Text" Text -> YamlParser Text
forall (m :: * -> *) a. Monad m => a -> m a
return
instance FromYaml Int where
    fromYaml :: YamlValue -> YamlParser Int
fromYaml =
        Text -> (Text -> YamlParser Int) -> YamlValue -> YamlParser Int
forall a.
Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
withText Text
"Int" Text -> YamlParser Int
forall a (m :: * -> *). (Integral a, MonadFail m) => Text -> m a
go
      where
        go :: Text -> m a
go Text
t =
            case Reader a -> Reader a
forall a. Num a => Reader a -> Reader a
signed Reader a
forall a. Integral a => Reader a
decimal Text
t of
                Right (a
i, Text
"") -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
i
                Either String (a, Text)
_ -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Invalid Int: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
t

data YamlValue
    = Mapping [(Text, YamlValue)] Anchor
    | Sequence [YamlValue] Anchor
    | Scalar ByteString Tag Style Anchor
    | Alias AnchorName
    deriving Int -> YamlValue -> String -> String
[YamlValue] -> String -> String
YamlValue -> String
(Int -> YamlValue -> String -> String)
-> (YamlValue -> String)
-> ([YamlValue] -> String -> String)
-> Show YamlValue
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [YamlValue] -> String -> String
$cshowList :: [YamlValue] -> String -> String
show :: YamlValue -> String
$cshow :: YamlValue -> String
showsPrec :: Int -> YamlValue -> String -> String
$cshowsPrec :: Int -> YamlValue -> String -> String
Show

type AnchorMap = Map.Map AnchorName YamlValue
data RawDoc = RawDoc YamlValue AnchorMap
    deriving Int -> RawDoc -> String -> String
[RawDoc] -> String -> String
RawDoc -> String
(Int -> RawDoc -> String -> String)
-> (RawDoc -> String)
-> ([RawDoc] -> String -> String)
-> Show RawDoc
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RawDoc] -> String -> String
$cshowList :: [RawDoc] -> String -> String
show :: RawDoc -> String
$cshow :: RawDoc -> String
showsPrec :: Int -> RawDoc -> String -> String
$cshowsPrec :: Int -> RawDoc -> String -> String
Show

parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a
parseRawDoc :: RawDoc -> m a
parseRawDoc (RawDoc YamlValue
val AnchorMap
am) =
    case YamlParser a -> AnchorMap -> Either Text a
forall a. YamlParser a -> AnchorMap -> Either Text a
unYamlParser (YamlValue -> YamlParser a
forall a. FromYaml a => YamlValue -> YamlParser a
fromYaml YamlValue
val) AnchorMap
am of
        Left Text
t -> YamlParseException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (YamlParseException -> m a) -> YamlParseException -> m a
forall a b. (a -> b) -> a -> b
$ Text -> YamlParseException
FromYamlException Text
t
        Right a
x -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a
[(Text, YamlValue)]
o .: :: [(Text, YamlValue)] -> Text -> YamlParser a
.: Text
k =
    case Text -> [(Text, YamlValue)] -> Maybe YamlValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, YamlValue)]
o of
        Maybe YamlValue
Nothing -> String -> YamlParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> YamlParser a) -> String -> YamlParser a
forall a b. (a -> b) -> a -> b
$ String
"Key not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
k
        Just YamlValue
v -> YamlValue -> YamlParser a
forall a. FromYaml a => YamlValue -> YamlParser a
fromYaml YamlValue
v

data YamlParseException
    = UnexpectedEndOfEvents
    | UnexpectedEvent Event
    | FromYamlException Text
    deriving (Int -> YamlParseException -> String -> String
[YamlParseException] -> String -> String
YamlParseException -> String
(Int -> YamlParseException -> String -> String)
-> (YamlParseException -> String)
-> ([YamlParseException] -> String -> String)
-> Show YamlParseException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [YamlParseException] -> String -> String
$cshowList :: [YamlParseException] -> String -> String
show :: YamlParseException -> String
$cshow :: YamlParseException -> String
showsPrec :: Int -> YamlParseException -> String -> String
$cshowsPrec :: Int -> YamlParseException -> String -> String
Show, Typeable)
instance Exception YamlParseException

{-# INLINE sinkValue #-}
sinkValue :: (MonadIO m, MonadCatch m, MonadThrow m) => Parser (WriterT AnchorMap m) Event YamlValue
sinkValue :: Parser (WriterT AnchorMap m) Event YamlValue
sinkValue = Parser (WriterT AnchorMap m) Event YamlValue
start
  where
    start :: Parser (WriterT AnchorMap m) Event YamlValue
start = Parser (WriterT AnchorMap m) Event (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => Parser m a (Maybe a)
anyEvent Parser (WriterT AnchorMap m) Event (Maybe Event)
-> (Maybe Event -> Parser (WriterT AnchorMap m) Event YamlValue)
-> Parser (WriterT AnchorMap m) Event YamlValue
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser (WriterT AnchorMap m) Event YamlValue
-> (Event -> Parser (WriterT AnchorMap m) Event YamlValue)
-> Maybe Event
-> Parser (WriterT AnchorMap m) Event YamlValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser (WriterT AnchorMap m) Event YamlValue
forall (m :: * -> *) a b. String -> Parser m a b
die String
"Unexpected end of events") Event -> Parser (WriterT AnchorMap m) Event YamlValue
go

    tell' :: Maybe k -> a -> Parser (WriterT (Map k a) m) a a
tell' Maybe k
Nothing a
val = a -> Parser (WriterT (Map k a) m) a a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
    tell' (Just k
name) a
val = do
        WriterT (Map k a) m () -> Parser (WriterT (Map k a) m) a ()
forall (m :: * -> *) b a. Monad m => m b -> Parser m a b
fromEffect (WriterT (Map k a) m () -> Parser (WriterT (Map k a) m) a ())
-> WriterT (Map k a) m () -> Parser (WriterT (Map k a) m) a ()
forall a b. (a -> b) -> a -> b
$ Map k a -> WriterT (Map k a) m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Map k a -> WriterT (Map k a) m ())
-> Map k a -> WriterT (Map k a) m ()
forall a b. (a -> b) -> a -> b
$ k -> a -> Map k a
forall k a. k -> a -> Map k a
Map.singleton k
name a
val
        a -> Parser (WriterT (Map k a) m) a a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

    go :: Event -> Parser (WriterT AnchorMap m) Event YamlValue
go Event
EventStreamStart = Parser (WriterT AnchorMap m) Event YamlValue
start
    go Event
EventDocumentStart = Parser (WriterT AnchorMap m) Event YamlValue
start
    go (EventAlias String
a) = YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall (m :: * -> *) a. Monad m => a -> m a
return (YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue)
-> YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall a b. (a -> b) -> a -> b
$ String -> YamlValue
Alias String
a
    go (EventScalar ByteString
a Tag
b Style
c Anchor
d) = Anchor -> YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall k (m :: * -> *) a a.
(Ord k, Monad m) =>
Maybe k -> a -> Parser (WriterT (Map k a) m) a a
tell' Anchor
d (YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue)
-> YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall a b. (a -> b) -> a -> b
$ ByteString -> Tag -> Style -> Anchor -> YamlValue
Scalar ByteString
a Tag
b Style
c Anchor
d
    go (EventSequenceStart Tag
_tag SequenceStyle
_style Anchor
mname) = do
        [YamlValue]
vals <- ([YamlValue] -> [YamlValue])
-> Parser (WriterT AnchorMap m) Event [YamlValue]
goS [YamlValue] -> [YamlValue]
forall a. a -> a
id
        let val :: YamlValue
val = [YamlValue] -> Anchor -> YamlValue
Sequence [YamlValue]
vals Anchor
mname
        Anchor -> YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall k (m :: * -> *) a a.
(Ord k, Monad m) =>
Maybe k -> a -> Parser (WriterT (Map k a) m) a a
tell' Anchor
mname YamlValue
val
    go (EventMappingStart Tag
_tag MappingStyle
_style Anchor
mname) = do
        [(Text, YamlValue)]
pairs <- ([(Text, YamlValue)] -> [(Text, YamlValue)])
-> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)]
goM [(Text, YamlValue)] -> [(Text, YamlValue)]
forall a. a -> a
id
        let val :: YamlValue
val = [(Text, YamlValue)] -> Anchor -> YamlValue
Mapping [(Text, YamlValue)]
pairs Anchor
mname
        Anchor -> YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall k (m :: * -> *) a a.
(Ord k, Monad m) =>
Maybe k -> a -> Parser (WriterT (Map k a) m) a a
tell' Anchor
mname YamlValue
val
    go Event
e = Maybe Event -> Parser (WriterT AnchorMap m) Event YamlValue
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> Parser m a b
missed (Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e)

    goS :: ([YamlValue] -> [YamlValue])
-> Parser (WriterT AnchorMap m) Event [YamlValue]
goS [YamlValue] -> [YamlValue]
front = do
        Maybe Event
me <- Parser (WriterT AnchorMap m) Event (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => Parser m a (Maybe a)
anyEvent
        case Maybe Event
me of
            Maybe Event
Nothing -> String -> Parser (WriterT AnchorMap m) Event [YamlValue]
forall (m :: * -> *) a b. String -> Parser m a b
die String
"Unexpected end of events"
            Just Event
EventSequenceEnd -> [YamlValue] -> Parser (WriterT AnchorMap m) Event [YamlValue]
forall (m :: * -> *) a. Monad m => a -> m a
return ([YamlValue] -> Parser (WriterT AnchorMap m) Event [YamlValue])
-> [YamlValue] -> Parser (WriterT AnchorMap m) Event [YamlValue]
forall a b. (a -> b) -> a -> b
$ [YamlValue] -> [YamlValue]
front []
            Just Event
e -> do
                YamlValue
val <- Event -> Parser (WriterT AnchorMap m) Event YamlValue
go Event
e
                ([YamlValue] -> [YamlValue])
-> Parser (WriterT AnchorMap m) Event [YamlValue]
goS ([YamlValue] -> [YamlValue]
front ([YamlValue] -> [YamlValue])
-> ([YamlValue] -> [YamlValue]) -> [YamlValue] -> [YamlValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (YamlValue
valYamlValue -> [YamlValue] -> [YamlValue]
forall a. a -> [a] -> [a]
:))

    goM :: ([(Text, YamlValue)] -> [(Text, YamlValue)])
-> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)]
goM [(Text, YamlValue)] -> [(Text, YamlValue)]
front = do
        Maybe Event
mk <- Parser (WriterT AnchorMap m) Event (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => Parser m a (Maybe a)
anyEvent
        case Maybe Event
mk of
            Maybe Event
Nothing -> String -> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)]
forall (m :: * -> *) a b. String -> Parser m a b
die String
"Unexpected end of events"
            Just Event
EventMappingEnd -> [(Text, YamlValue)]
-> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, YamlValue)]
 -> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)])
-> [(Text, YamlValue)]
-> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)]
forall a b. (a -> b) -> a -> b
$ [(Text, YamlValue)] -> [(Text, YamlValue)]
front []
            Just (EventScalar ByteString
a Tag
b Style
c Anchor
d) -> do
                YamlValue
_ <- Anchor -> YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall k (m :: * -> *) a a.
(Ord k, Monad m) =>
Maybe k -> a -> Parser (WriterT (Map k a) m) a a
tell' Anchor
d (YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue)
-> YamlValue -> Parser (WriterT AnchorMap m) Event YamlValue
forall a b. (a -> b) -> a -> b
$ ByteString -> Tag -> Style -> Anchor -> YamlValue
Scalar ByteString
a Tag
b Style
c Anchor
d
                let k :: Text
k = ByteString -> Text
decodeUtf8 ByteString
a
                YamlValue
v <- Parser (WriterT AnchorMap m) Event YamlValue
start
                ([(Text, YamlValue)] -> [(Text, YamlValue)])
-> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)]
goM ([(Text, YamlValue)] -> [(Text, YamlValue)]
front ([(Text, YamlValue)] -> [(Text, YamlValue)])
-> ([(Text, YamlValue)] -> [(Text, YamlValue)])
-> [(Text, YamlValue)]
-> [(Text, YamlValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
k, YamlValue
v)(Text, YamlValue) -> [(Text, YamlValue)] -> [(Text, YamlValue)]
forall a. a -> [a] -> [a]
:))
            Just Event
e -> Maybe Event
-> Parser (WriterT AnchorMap m) Event [(Text, YamlValue)]
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> Parser m a b
missed (Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e)

{-# INLINE sinkRawDoc #-}
sinkRawDoc :: SerialT IO Event -> IO RawDoc
sinkRawDoc :: SerialT IO Event -> IO RawDoc
sinkRawDoc SerialT IO Event
src = do
    (YamlValue -> AnchorMap -> RawDoc)
-> (YamlValue, AnchorMap) -> RawDoc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry YamlValue -> AnchorMap -> RawDoc
RawDoc ((YamlValue, AnchorMap) -> RawDoc)
-> IO (YamlValue, AnchorMap) -> IO RawDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT AnchorMap IO YamlValue -> IO (YamlValue, AnchorMap)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (Parser (WriterT AnchorMap IO) Event YamlValue
-> SerialT (WriterT AnchorMap IO) Event
-> WriterT AnchorMap IO YamlValue
forall (m :: * -> *) a b.
MonadThrow m =>
Parser m a b -> SerialT m a -> m b
Stream.parse Parser (WriterT AnchorMap IO) Event YamlValue
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadThrow m) =>
Parser (WriterT AnchorMap m) Event YamlValue
sinkValue ((forall x. IO x -> WriterT AnchorMap IO x)
-> SerialT IO Event -> SerialT (WriterT AnchorMap IO) Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *) a.
(IsStream t, Monad m, Monad n) =>
(forall x. m x -> n x) -> t m a -> t n a
K.hoist forall x. IO x -> WriterT AnchorMap IO x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO SerialT IO Event
src))

readYamlFile :: FromYaml a => FilePath -> IO a
readYamlFile :: String -> IO a
readYamlFile String
fp = SerialT IO Event -> IO RawDoc
sinkRawDoc (String -> SerialT IO Event
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
String -> SerialT m Event
decodeFile String
fp) IO RawDoc -> (RawDoc -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawDoc -> IO a
forall a (m :: * -> *). (FromYaml a, MonadThrow m) => RawDoc -> m a
parseRawDoc