{-# 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.Exception (Exception)
import Control.Monad (MonadPlus (..), liftM, ap)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Resource (MonadThrow, throwM)
import Control.Monad.Trans.Writer.Strict (tell, WriterT)
import Data.ByteString (ByteString)
import Data.Conduit
import Data.Conduit.Lift (runWriterC)
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.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Read (signed, decimal)
import Data.Typeable (Typeable)

import Text.Libyaml

newtype YamlParser a = YamlParser
    { forall a. YamlParser a -> AnchorMap -> Either Text a
unYamlParser :: AnchorMap -> Either Text a
    }
instance Functor YamlParser where
    fmap :: forall a b. (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 :: forall a. 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
    <*> :: forall a b. 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 :: forall a. YamlParser a
empty = AnchorName -> YamlParser a
forall a. AnchorName -> YamlParser a
forall (m :: * -> *) a. MonadFail m => AnchorName -> m a
fail AnchorName
"empty"
    <|> :: forall a. YamlParser a -> YamlParser a -> YamlParser a
(<|>) = YamlParser a -> YamlParser a -> YamlParser a
forall 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 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 = AnchorName -> YamlParser a
forall a. AnchorName -> YamlParser a
forall (m :: * -> *) a. MonadFail m => AnchorName -> m a
fail AnchorName
"mempty"
#if !MIN_VERSION_base(4,11,0)
    mappend = (<>)
#endif
instance Monad YamlParser where
    return :: forall a. a -> YamlParser a
return = a -> YamlParser a
forall a. a -> YamlParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    YamlParser AnchorMap -> Either Text a
f >>= :: forall a b. 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 :: forall a. AnchorName -> YamlParser a
fail = (AnchorMap -> Either Text a) -> YamlParser a
forall a. (AnchorMap -> Either Text a) -> YamlParser a
YamlParser ((AnchorMap -> Either Text a) -> YamlParser a)
-> (AnchorName -> AnchorMap -> Either Text a)
-> AnchorName
-> 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)
-> (AnchorName -> Either Text a)
-> AnchorName
-> 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)
-> (AnchorName -> Text) -> AnchorName -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchorName -> Text
pack
instance MonadPlus YamlParser where
    mzero :: forall a. YamlParser a
mzero = AnchorName -> YamlParser a
forall a. AnchorName -> YamlParser a
forall (m :: * -> *) a. MonadFail m => AnchorName -> m a
fail AnchorName
"mzero"
    mplus :: forall a. 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 :: AnchorName -> YamlParser (Maybe YamlValue)
lookupAnchor AnchorName
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
. AnchorName -> AnchorMap -> Maybe YamlValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnchorName
name

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

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

class FromYaml a where
    fromYaml :: YamlValue -> YamlParser a
instance FromYaml YamlValue where
    fromYaml :: YamlValue -> YamlParser YamlValue
fromYaml = YamlValue -> YamlParser YamlValue
forall a. a -> YamlParser a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> YamlParser a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
i
                Either AnchorName (a, Text)
_ -> AnchorName -> m a
forall a. AnchorName -> m a
forall (m :: * -> *) a. MonadFail m => AnchorName -> m a
fail (AnchorName -> m a) -> AnchorName -> m a
forall a b. (a -> b) -> a -> b
$ AnchorName
"Invalid Int: " AnchorName -> AnchorName -> AnchorName
forall a. [a] -> [a] -> [a]
++ Text -> AnchorName
unpack Text
t

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

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

parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a
parseRawDoc :: forall a (m :: * -> *). (FromYaml a, MonadThrow m) => 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 e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a
[(Text, YamlValue)]
o .: :: forall a. FromYaml a => [(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 -> AnchorName -> YamlParser a
forall a. AnchorName -> YamlParser a
forall (m :: * -> *) a. MonadFail m => AnchorName -> m a
fail (AnchorName -> YamlParser a) -> AnchorName -> YamlParser a
forall a b. (a -> b) -> a -> b
$ AnchorName
"Key not found: " AnchorName -> AnchorName -> AnchorName
forall a. [a] -> [a] -> [a]
++ Text -> AnchorName
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 -> AnchorName -> AnchorName
[YamlParseException] -> AnchorName -> AnchorName
YamlParseException -> AnchorName
(Int -> YamlParseException -> AnchorName -> AnchorName)
-> (YamlParseException -> AnchorName)
-> ([YamlParseException] -> AnchorName -> AnchorName)
-> Show YamlParseException
forall a.
(Int -> a -> AnchorName -> AnchorName)
-> (a -> AnchorName) -> ([a] -> AnchorName -> AnchorName) -> Show a
$cshowsPrec :: Int -> YamlParseException -> AnchorName -> AnchorName
showsPrec :: Int -> YamlParseException -> AnchorName -> AnchorName
$cshow :: YamlParseException -> AnchorName
show :: YamlParseException -> AnchorName
$cshowList :: [YamlParseException] -> AnchorName -> AnchorName
showList :: [YamlParseException] -> AnchorName -> AnchorName
Show, Typeable)
instance Exception YamlParseException

sinkValue :: MonadThrow m => ConduitM Event o (WriterT AnchorMap m) YamlValue
sinkValue :: forall (m :: * -> *) o.
MonadThrow m =>
ConduitM Event o (WriterT AnchorMap m) YamlValue
sinkValue =
    ConduitT Event o (WriterT AnchorMap m) YamlValue
forall {o}. ConduitT Event o (WriterT AnchorMap m) YamlValue
start
  where
    start :: ConduitT Event o (WriterT AnchorMap m) YamlValue
start = ConduitT Event o (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT Event o (WriterT AnchorMap m) (Maybe Event)
-> (Maybe Event
    -> ConduitT Event o (WriterT AnchorMap m) YamlValue)
-> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall a b.
ConduitT Event o (WriterT AnchorMap m) a
-> (a -> ConduitT Event o (WriterT AnchorMap m) b)
-> ConduitT Event o (WriterT AnchorMap m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT Event o (WriterT AnchorMap m) YamlValue
-> (Event -> ConduitT Event o (WriterT AnchorMap m) YamlValue)
-> Maybe Event
-> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM YamlParseException
UnexpectedEndOfEvents) Event -> ConduitT Event o (WriterT AnchorMap m) YamlValue
go

    tell' :: Maybe k -> a -> t (WriterT (Map k a) m) a
tell' Maybe k
Nothing a
val = a -> t (WriterT (Map k a) m) a
forall a. a -> t (WriterT (Map k a) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
    tell' (Just k
name) a
val = do
        WriterT (Map k a) m () -> t (WriterT (Map k a) m) ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Map k a) m () -> t (WriterT (Map k a) m) ())
-> WriterT (Map k a) m () -> t (WriterT (Map k a) m) ()
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 -> t (WriterT (Map k a) m) a
forall a. a -> t (WriterT (Map k a) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

    go :: Event -> ConduitT Event o (WriterT AnchorMap m) YamlValue
go Event
EventStreamStart = ConduitT Event o (WriterT AnchorMap m) YamlValue
start
    go Event
EventDocumentStart = ConduitT Event o (WriterT AnchorMap m) YamlValue
start
    go (EventAlias AnchorName
a) = YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall a. a -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue)
-> YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall a b. (a -> b) -> a -> b
$ AnchorName -> YamlValue
Alias AnchorName
a
    go (EventScalar ByteString
a Tag
b Style
c Anchor
d) = Anchor
-> YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall {t :: (* -> *) -> * -> *} {k} {m :: * -> *} {a}.
(MonadTrans t, Ord k, Monad m, Monad (t (WriterT (Map k a) m))) =>
Maybe k -> a -> t (WriterT (Map k a) m) a
tell' Anchor
d (YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue)
-> YamlValue -> ConduitT Event o (WriterT AnchorMap m) 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])
-> ConduitT Event o (WriterT AnchorMap m) [YamlValue]
goS [YamlValue] -> [YamlValue]
forall a. a -> a
id
        let val :: YamlValue
val = [YamlValue] -> Anchor -> YamlValue
Sequence [YamlValue]
vals Anchor
mname
        Anchor
-> YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall {t :: (* -> *) -> * -> *} {k} {m :: * -> *} {a}.
(MonadTrans t, Ord k, Monad m, Monad (t (WriterT (Map k a) m))) =>
Maybe k -> a -> t (WriterT (Map k a) m) a
tell' Anchor
mname YamlValue
val
    go (EventMappingStart Tag
_tag MappingStyle
_style Anchor
mname) = do
        [(Text, YamlValue)]
pairs <- ([(Text, YamlValue)] -> [(Text, YamlValue)])
-> ConduitT Event o (WriterT AnchorMap m) [(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 -> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall {t :: (* -> *) -> * -> *} {k} {m :: * -> *} {a}.
(MonadTrans t, Ord k, Monad m, Monad (t (WriterT (Map k a) m))) =>
Maybe k -> a -> t (WriterT (Map k a) m) a
tell' Anchor
mname YamlValue
val

    go Event
e = YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (YamlParseException
 -> ConduitT Event o (WriterT AnchorMap m) YamlValue)
-> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall a b. (a -> b) -> a -> b
$ Event -> YamlParseException
UnexpectedEvent Event
e

    goS :: ([YamlValue] -> [YamlValue])
-> ConduitT Event o (WriterT AnchorMap m) [YamlValue]
goS [YamlValue] -> [YamlValue]
front = do
        Maybe Event
me <- ConduitT Event o (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
        case Maybe Event
me of
            Maybe Event
Nothing -> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) [YamlValue]
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM YamlParseException
UnexpectedEndOfEvents
            Just Event
EventSequenceEnd -> [YamlValue] -> ConduitT Event o (WriterT AnchorMap m) [YamlValue]
forall a. a -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([YamlValue] -> ConduitT Event o (WriterT AnchorMap m) [YamlValue])
-> [YamlValue]
-> ConduitT Event o (WriterT AnchorMap m) [YamlValue]
forall a b. (a -> b) -> a -> b
$ [YamlValue] -> [YamlValue]
front []
            Just Event
e -> do
                YamlValue
val <- Event -> ConduitT Event o (WriterT AnchorMap m) YamlValue
go Event
e
                ([YamlValue] -> [YamlValue])
-> ConduitT Event o (WriterT AnchorMap m) [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)])
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
goM [(Text, YamlValue)] -> [(Text, YamlValue)]
front = do
        Maybe Event
mk <- ConduitT Event o (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
        case Maybe Event
mk of
            Maybe Event
Nothing -> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM YamlParseException
UnexpectedEndOfEvents
            Just Event
EventMappingEnd -> [(Text, YamlValue)]
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
forall a. a -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, YamlValue)]
 -> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)])
-> [(Text, YamlValue)]
-> ConduitT Event o (WriterT AnchorMap m) [(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 -> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall {t :: (* -> *) -> * -> *} {k} {m :: * -> *} {a}.
(MonadTrans t, Ord k, Monad m, Monad (t (WriterT (Map k a) m))) =>
Maybe k -> a -> t (WriterT (Map k a) m) a
tell' Anchor
d (YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue)
-> YamlValue -> ConduitT Event o (WriterT AnchorMap m) 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 <- ConduitT Event o (WriterT AnchorMap m) YamlValue
start
                ([(Text, YamlValue)] -> [(Text, YamlValue)])
-> ConduitT Event o (WriterT AnchorMap m) [(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 -> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT Event o (WriterT AnchorMap m) a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (YamlParseException
 -> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)])
-> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
forall a b. (a -> b) -> a -> b
$ Event -> YamlParseException
UnexpectedEvent Event
e

sinkRawDoc :: MonadThrow m => ConduitM Event o m RawDoc
sinkRawDoc :: forall (m :: * -> *) o. MonadThrow m => ConduitM Event o m RawDoc
sinkRawDoc = (YamlValue -> AnchorMap -> RawDoc)
-> (YamlValue, AnchorMap) -> RawDoc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry YamlValue -> AnchorMap -> RawDoc
RawDoc ((YamlValue, AnchorMap) -> RawDoc)
-> ConduitT Event o m (YamlValue, AnchorMap)
-> ConduitT Event o m RawDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o (WriterT AnchorMap m) YamlValue
-> ConduitT Event o m (YamlValue, AnchorMap)
forall (m :: * -> *) w i o r.
(Monad m, Monoid w) =>
ConduitT i o (WriterT w m) r -> ConduitT i o m (r, w)
runWriterC ConduitT Event o (WriterT AnchorMap m) YamlValue
forall (m :: * -> *) o.
MonadThrow m =>
ConduitM Event o (WriterT AnchorMap m) YamlValue
sinkValue

readYamlFile :: FromYaml a => FilePath -> IO a
readYamlFile :: forall a. FromYaml a => AnchorName -> IO a
readYamlFile AnchorName
fp = ConduitT () Void (ResourceT IO) RawDoc -> IO RawDoc
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (AnchorName -> ConduitM () Event (ResourceT IO) ()
forall (m :: * -> *) i.
MonadResource m =>
AnchorName -> ConduitM i Event m ()
decodeFile AnchorName
fp ConduitM () Event (ResourceT IO) ()
-> ConduitT Event Void (ResourceT IO) RawDoc
-> ConduitT () Void (ResourceT IO) RawDoc
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Event Void (ResourceT IO) RawDoc
forall (m :: * -> *) o. MonadThrow m => ConduitM Event o m RawDoc
sinkRawDoc) IO RawDoc -> (RawDoc -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
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