{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
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
{ 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 "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 "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 f :: AnchorMap -> Either Text a
f >>= :: YamlParser a -> (a -> YamlParser b) -> YamlParser b
>>= g :: 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
$ \am :: AnchorMap
am ->
case AnchorMap -> Either Text a
f AnchorMap
am of
Left t :: Text
t -> Text -> Either Text b
forall a b. a -> Either a b
Left Text
t
Right x :: 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 "mzero"
mplus :: YamlParser a -> YamlParser a -> YamlParser a
mplus a :: YamlParser a
a b :: 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
$ \am :: 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 _ -> YamlParser a -> AnchorMap -> Either Text a
forall a. YamlParser a -> AnchorMap -> Either Text a
unYamlParser YamlParser a
b AnchorMap
am
x :: Either Text a
x -> Either Text a
x
lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue)
lookupAnchor :: String -> YamlParser (Maybe YamlValue)
lookupAnchor name :: 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 name :: String
name expected :: Text
expected f :: YamlValue -> YamlParser a
f = do
Maybe YamlValue
mv <- String -> YamlParser (Maybe YamlValue)
lookupAnchor String
name
case Maybe YamlValue
mv of
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]
++ ": unknown alias " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
Just v :: 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 _ f :: [(Text, YamlValue)] -> YamlParser a
f (Mapping m :: [(Text, YamlValue)]
m _) = [(Text, YamlValue)] -> YamlParser a
f [(Text, YamlValue)]
m
withMapping expected :: Text
expected f :: [(Text, YamlValue)] -> YamlParser a
f (Alias an :: 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 expected :: Text
expected _ v :: 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 _ f :: [YamlValue] -> YamlParser a
f (Sequence s :: [YamlValue]
s _) = [YamlValue] -> YamlParser a
f [YamlValue]
s
withSequence expected :: Text
expected f :: [YamlValue] -> YamlParser a
f (Alias an :: 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 expected :: Text
expected _ v :: 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 _ f :: Text -> YamlParser a
f (Scalar s :: ByteString
s _ _ _) = Text -> YamlParser a
f (Text -> YamlParser a) -> Text -> YamlParser a
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
s
withText expected :: Text
expected f :: Text -> YamlParser a
f (Alias an :: 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 expected :: Text
expected _ v :: 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 expected :: Text
expected v :: 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
[ "Expected "
, Text -> String
unpack Text
expected
, ", but got: "
, String
t
]
where
t :: String
t = case YamlValue
v of
Mapping _ _ -> "mapping"
Sequence _ _ -> "sequence"
Scalar _ _ _ _ -> "scalar"
Alias _ -> "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 "[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 -> 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 "Int" Text -> YamlParser Int
forall a (m :: * -> *). (Integral a, MonadFail m) => Text -> m a
go
where
go :: Text -> m a
go t :: 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 (i :: a
i, "") -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
i
_ -> 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
$ "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 val :: YamlValue
val am :: 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 t :: 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 x :: a
x -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a
o :: [(Text, YamlValue)]
o .: :: [(Text, YamlValue)] -> Text -> YamlParser a
.: k :: 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
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
$ "Key not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
k
Just v :: 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
sinkValue :: MonadThrow m => ConduitM Event o (WriterT AnchorMap m) YamlValue
sinkValue :: ConduitM Event o (WriterT AnchorMap m) YamlValue
sinkValue =
ConduitM 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. Monad m => Consumer i 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 (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 (m :: * -> *) e a. (MonadThrow m, 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' Nothing val :: a
val = a -> t (WriterT (Map k a) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
tell' (Just name :: k
name) val :: a
val = do
WriterT (Map k a) m () -> t (WriterT (Map k a) m) ()
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 (m :: * -> *) a. Monad m => a -> m a
return a
val
go :: Event -> ConduitT Event o (WriterT AnchorMap m) YamlValue
go EventStreamStart = ConduitT Event o (WriterT AnchorMap m) YamlValue
start
go EventDocumentStart = ConduitT Event o (WriterT AnchorMap m) YamlValue
start
go (EventAlias a :: String
a) = YamlValue -> ConduitT Event o (WriterT AnchorMap m) YamlValue
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
$ String -> YamlValue
Alias String
a
go (EventScalar a :: ByteString
a b :: Tag
b c :: Style
c d :: 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
_tag _style :: SequenceStyle
_style mname :: 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
_tag _style :: MappingStyle
_style mname :: 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 e :: Event
e = YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) YamlValue
forall (m :: * -> *) e a. (MonadThrow m, 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 front :: [YamlValue] -> [YamlValue]
front = do
Maybe Event
me <- ConduitT Event o (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
case Maybe Event
me of
Nothing -> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) [YamlValue]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM YamlParseException
UnexpectedEndOfEvents
Just EventSequenceEnd -> [YamlValue] -> ConduitT Event o (WriterT AnchorMap m) [YamlValue]
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 e :: 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 front :: [(Text, YamlValue)] -> [(Text, YamlValue)]
front = do
Maybe Event
mk <- ConduitT Event o (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
case Maybe Event
mk of
Nothing -> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM YamlParseException
UnexpectedEndOfEvents
Just EventMappingEnd -> [(Text, YamlValue)]
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
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 a :: ByteString
a b :: Tag
b c :: Style
c d :: 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 e :: Event
e -> YamlParseException
-> ConduitT Event o (WriterT AnchorMap m) [(Text, YamlValue)]
forall (m :: * -> *) e a. (MonadThrow m, 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 :: 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)
-> ConduitM 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 :: String -> IO a
readYamlFile fp :: String
fp = ConduitT () Void (ResourceT IO) RawDoc -> IO RawDoc
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (String -> ConduitM () Event (ResourceT IO) ()
forall (m :: * -> *) i.
MonadResource m =>
String -> ConduitM i Event m ()
decodeFile String
fp ConduitM () Event (ResourceT IO) ()
-> ConduitM Event Void (ResourceT IO) RawDoc
-> ConduitT () Void (ResourceT IO) RawDoc
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Event Void (ResourceT IO) RawDoc
forall (m :: * -> *) o. MonadThrow m => ConduitM Event o m RawDoc
sinkRawDoc) 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