{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
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.Data.Stream (Stream)
import Streamly.Data.ParserK (ParserK)
import qualified Streamly.Data.Stream as Stream
import qualified Streamly.Data.StreamK as StreamK
import qualified Streamly.Data.ParserK as ParserK
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 (m :: * -> *) e a.
(HasCallStack, 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 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
{-# INLINE sinkValue #-}
sinkValue :: (MonadIO m, MonadCatch m, MonadThrow m) => ParserK Event (WriterT AnchorMap m) YamlValue
sinkValue :: forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadThrow m) =>
ParserK Event (WriterT AnchorMap m) YamlValue
sinkValue = ParserK Event (WriterT AnchorMap m) YamlValue
start
where
start :: ParserK Event (WriterT AnchorMap m) YamlValue
start = ParserK Event (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent ParserK Event (WriterT AnchorMap m) (Maybe Event)
-> (Maybe Event -> ParserK Event (WriterT AnchorMap m) YamlValue)
-> ParserK Event (WriterT AnchorMap m) YamlValue
forall a b.
ParserK Event (WriterT AnchorMap m) a
-> (a -> ParserK Event (WriterT AnchorMap m) b)
-> ParserK Event (WriterT AnchorMap m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParserK Event (WriterT AnchorMap m) YamlValue
-> (Event -> ParserK Event (WriterT AnchorMap m) YamlValue)
-> Maybe Event
-> ParserK Event (WriterT AnchorMap m) YamlValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AnchorName -> ParserK Event (WriterT AnchorMap m) YamlValue
forall a (m :: * -> *) b. AnchorName -> ParserK a m b
ParserK.die AnchorName
"Unexpected end of events") Event -> ParserK Event (WriterT AnchorMap m) YamlValue
go
tell' :: Maybe k -> a -> ParserK a (WriterT (Map k a) m) a
tell' Maybe k
Nothing a
val = a -> ParserK a (WriterT (Map k a) m) a
forall a. a -> ParserK a (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 () -> ParserK a (WriterT (Map k a) m) ()
forall (m :: * -> *) b a. Monad m => m b -> ParserK a m b
ParserK.fromEffect (WriterT (Map k a) m () -> ParserK a (WriterT (Map k a) m) ())
-> WriterT (Map k a) m () -> ParserK a (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 -> ParserK a (WriterT (Map k a) m) a
forall a. a -> ParserK a (WriterT (Map k a) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
go :: Event -> ParserK Event (WriterT AnchorMap m) YamlValue
go Event
EventStreamStart = ParserK Event (WriterT AnchorMap m) YamlValue
start
go Event
EventDocumentStart = ParserK Event (WriterT AnchorMap m) YamlValue
start
go (EventAlias AnchorName
a) = YamlValue -> ParserK Event (WriterT AnchorMap m) YamlValue
forall a. a -> ParserK Event (WriterT AnchorMap m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (YamlValue -> ParserK Event (WriterT AnchorMap m) YamlValue)
-> YamlValue -> ParserK Event (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 -> ParserK Event (WriterT AnchorMap m) YamlValue
forall {k} {m :: * -> *} {a} {a}.
(Ord k, Monad m) =>
Maybe k -> a -> ParserK a (WriterT (Map k a) m) a
tell' Anchor
d (YamlValue -> ParserK Event (WriterT AnchorMap m) YamlValue)
-> YamlValue -> ParserK Event (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])
-> ParserK Event (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 -> ParserK Event (WriterT AnchorMap m) YamlValue
forall {k} {m :: * -> *} {a} {a}.
(Ord k, Monad m) =>
Maybe k -> a -> ParserK a (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)])
-> ParserK Event (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 -> ParserK Event (WriterT AnchorMap m) YamlValue
forall {k} {m :: * -> *} {a} {a}.
(Ord k, Monad m) =>
Maybe k -> a -> ParserK a (WriterT (Map k a) m) a
tell' Anchor
mname YamlValue
val
go Event
e = Maybe Event -> ParserK Event (WriterT AnchorMap m) YamlValue
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> ParserK a m b
missed (Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e)
goS :: ([YamlValue] -> [YamlValue])
-> ParserK Event (WriterT AnchorMap m) [YamlValue]
goS [YamlValue] -> [YamlValue]
front = do
Maybe Event
me <- ParserK Event (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
case Maybe Event
me of
Maybe Event
Nothing -> AnchorName -> ParserK Event (WriterT AnchorMap m) [YamlValue]
forall a (m :: * -> *) b. AnchorName -> ParserK a m b
ParserK.die AnchorName
"Unexpected end of events"
Just Event
EventSequenceEnd -> [YamlValue] -> ParserK Event (WriterT AnchorMap m) [YamlValue]
forall a. a -> ParserK Event (WriterT AnchorMap m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([YamlValue] -> ParserK Event (WriterT AnchorMap m) [YamlValue])
-> [YamlValue] -> ParserK Event (WriterT AnchorMap m) [YamlValue]
forall a b. (a -> b) -> a -> b
$ [YamlValue] -> [YamlValue]
front []
Just Event
e -> do
YamlValue
val <- Event -> ParserK Event (WriterT AnchorMap m) YamlValue
go Event
e
([YamlValue] -> [YamlValue])
-> ParserK Event (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)])
-> ParserK Event (WriterT AnchorMap m) [(Text, YamlValue)]
goM [(Text, YamlValue)] -> [(Text, YamlValue)]
front = do
Maybe Event
mk <- ParserK Event (WriterT AnchorMap m) (Maybe Event)
forall (m :: * -> *) a. MonadCatch m => ParserK a m (Maybe a)
anyEvent
case Maybe Event
mk of
Maybe Event
Nothing -> AnchorName
-> ParserK Event (WriterT AnchorMap m) [(Text, YamlValue)]
forall a (m :: * -> *) b. AnchorName -> ParserK a m b
ParserK.die AnchorName
"Unexpected end of events"
Just Event
EventMappingEnd -> [(Text, YamlValue)]
-> ParserK Event (WriterT AnchorMap m) [(Text, YamlValue)]
forall a. a -> ParserK Event (WriterT AnchorMap m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, YamlValue)]
-> ParserK Event (WriterT AnchorMap m) [(Text, YamlValue)])
-> [(Text, YamlValue)]
-> ParserK Event (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 -> ParserK Event (WriterT AnchorMap m) YamlValue
forall {k} {m :: * -> *} {a} {a}.
(Ord k, Monad m) =>
Maybe k -> a -> ParserK a (WriterT (Map k a) m) a
tell' Anchor
d (YamlValue -> ParserK Event (WriterT AnchorMap m) YamlValue)
-> YamlValue -> ParserK Event (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 <- ParserK Event (WriterT AnchorMap m) YamlValue
start
([(Text, YamlValue)] -> [(Text, YamlValue)])
-> ParserK Event (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 -> Maybe Event
-> ParserK Event (WriterT AnchorMap m) [(Text, YamlValue)]
forall (m :: * -> *) a b.
(MonadIO m, MonadThrow m) =>
Maybe Event -> ParserK a m b
missed (Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e)
{-# INLINE sinkRawDoc #-}
sinkRawDoc :: Stream IO Event -> IO RawDoc
sinkRawDoc :: Stream IO Event -> IO RawDoc
sinkRawDoc Stream IO Event
src = do
(Either ParseError YamlValue
res, AnchorMap
aMap) <- WriterT AnchorMap IO (Either ParseError YamlValue)
-> IO (Either ParseError YamlValue, AnchorMap)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (ParserK Event (WriterT AnchorMap IO) YamlValue
-> StreamK (WriterT AnchorMap IO) Event
-> WriterT AnchorMap IO (Either ParseError YamlValue)
forall (m :: * -> *) a b.
Monad m =>
ParserK a m b -> StreamK m a -> m (Either ParseError b)
StreamK.parse ParserK Event (WriterT AnchorMap IO) YamlValue
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadThrow m) =>
ParserK Event (WriterT AnchorMap m) YamlValue
sinkValue (Stream (WriterT AnchorMap IO) Event
-> StreamK (WriterT AnchorMap IO) Event
forall (m :: * -> *) a. Monad m => Stream m a -> StreamK m a
StreamK.fromStream ((forall x. IO x -> WriterT AnchorMap IO x)
-> Stream IO Event -> Stream (WriterT AnchorMap IO) Event
forall (n :: * -> *) (m :: * -> *) a.
Monad n =>
(forall x. m x -> n x) -> Stream m a -> Stream n a
Stream.morphInner IO x -> WriterT AnchorMap IO x
forall x. IO x -> WriterT AnchorMap IO x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Stream IO Event
src)))
case Either ParseError YamlValue
res of
Left ParseError
err -> YamlException -> IO RawDoc
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (YamlException -> IO RawDoc) -> YamlException -> IO RawDoc
forall a b. (a -> b) -> a -> b
$ AnchorName -> YamlException
YamlException (AnchorName -> YamlException) -> AnchorName -> YamlException
forall a b. (a -> b) -> a -> b
$ ParseError -> AnchorName
forall e. Exception e => e -> AnchorName
displayException ParseError
err
Right YamlValue
val -> RawDoc -> IO RawDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawDoc -> IO RawDoc) -> RawDoc -> IO RawDoc
forall a b. (a -> b) -> a -> b
$ YamlValue -> AnchorMap -> RawDoc
RawDoc YamlValue
val AnchorMap
aMap
readYamlFile :: FromYaml a => FilePath -> IO a
readYamlFile :: forall a. FromYaml a => AnchorName -> IO a
readYamlFile AnchorName
fp = Stream IO Event -> IO RawDoc
sinkRawDoc (AnchorName -> Stream IO Event
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadMask m) =>
AnchorName -> Stream m Event
decodeFile AnchorName
fp) 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