{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module YamlParse.Applicative.Implement where
import Control.Applicative
import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import YamlParse.Applicative.Parser
implementParser :: Parser i o -> (i -> Yaml.Parser o)
implementParser :: Parser i o -> i -> Parser o
implementParser = Parser i o -> i -> Parser o
forall i o. Parser i o -> i -> Parser o
go
where
go :: Parser i o -> (i -> Yaml.Parser o)
go :: Parser i o -> i -> Parser o
go = \case
Parser i o
ParseAny -> i -> Parser o
forall (f :: * -> *) a. Applicative f => a -> f a
pure
ParseExtra o -> Parser o
ef Parser i o
p -> \i
i -> do
o
o <- Parser i o -> i -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser i o
p i
i
o -> Parser o
ef o
o
ParseEq o
v Text
t Parser i o
p -> \i
i -> do
o
r <- Parser i o -> i -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser i o
p i
i
if o
r o -> o -> Bool
forall a. Eq a => a -> a -> Bool
== o
v then o -> Parser o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
r else String -> Parser o
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser o) -> String -> Parser o
forall a b. (a -> b) -> a -> b
$ String
"Expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" exactly but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> o -> String
forall a. Show a => a -> String
show o
r
Parser i o
ParseNull -> \i
v -> case i
v of
i
Yaml.Null -> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
i
_ -> String -> Parser o
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser o) -> String -> Parser o
forall a b. (a -> b) -> a -> b
$ String
"Expected 'null' but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> i -> String
forall a. Show a => a -> String
show i
v
ParseMaybe Parser Value o
p -> \i
v -> case i
v of
i
Yaml.Null -> Maybe o -> Parser (Maybe o)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe o
forall a. Maybe a
Nothing
i
_ -> o -> Maybe o
forall a. a -> Maybe a
Just (o -> Maybe o) -> Parser o -> Parser (Maybe o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Value o -> Value -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Value o
p i
Value
v
ParseBool Maybe Text
mt Parser Bool o
p -> case Maybe Text
mt of
Just Text
t -> String -> (Bool -> Parser o) -> Value -> Parser o
forall a. String -> (Bool -> Parser a) -> Value -> Parser a
Yaml.withBool (Text -> String
T.unpack Text
t) ((Bool -> Parser o) -> Value -> Parser o)
-> (Bool -> Parser o) -> Value -> Parser o
forall a b. (a -> b) -> a -> b
$ Parser Bool o -> Bool -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Bool o
p
Maybe Text
Nothing -> \i
v -> case i
v of
Yaml.Bool o -> Parser Bool o -> Bool -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Bool o
p Bool
o
i
_ -> String -> Value -> Parser o
forall a. String -> Value -> Parser a
Aeson.typeMismatch String
"Bool" i
Value
v
ParseString Maybe Text
mt Parser Text o
p -> case Maybe Text
mt of
Just Text
t -> String -> (Text -> Parser o) -> Value -> Parser o
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Yaml.withText (Text -> String
T.unpack Text
t) ((Text -> Parser o) -> Value -> Parser o)
-> (Text -> Parser o) -> Value -> Parser o
forall a b. (a -> b) -> a -> b
$ Parser Text o -> Text -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Text o
p
Maybe Text
Nothing -> \i
v -> case i
v of
Yaml.String o -> Parser Text o -> Text -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Text o
p Text
o
i
_ -> String -> Value -> Parser o
forall a. String -> Value -> Parser a
Aeson.typeMismatch String
"String" i
Value
v
ParseNumber Maybe Text
mt Parser Scientific o
p -> case Maybe Text
mt of
Just Text
t -> String -> (Scientific -> Parser o) -> Value -> Parser o
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
Yaml.withScientific (Text -> String
T.unpack Text
t) ((Scientific -> Parser o) -> Value -> Parser o)
-> (Scientific -> Parser o) -> Value -> Parser o
forall a b. (a -> b) -> a -> b
$ Parser Scientific o -> Scientific -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Scientific o
p
Maybe Text
Nothing -> \i
v -> case i
v of
Yaml.Number o -> Parser Scientific o -> Scientific -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Scientific o
p Scientific
o
i
_ -> String -> Value -> Parser o
forall a. String -> Value -> Parser a
Aeson.typeMismatch String
"Number" i
Value
v
ParseArray Maybe Text
mt Parser Array o
p -> case Maybe Text
mt of
Just Text
t -> String -> (Array -> Parser o) -> Value -> Parser o
forall a. String -> (Array -> Parser a) -> Value -> Parser a
Yaml.withArray (Text -> String
T.unpack Text
t) ((Array -> Parser o) -> Value -> Parser o)
-> (Array -> Parser o) -> Value -> Parser o
forall a b. (a -> b) -> a -> b
$ Parser Array o -> Array -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Array o
p
Maybe Text
Nothing -> \i
v -> case i
v of
Yaml.Array o -> Parser Array o -> Array -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Array o
p Array
o
i
_ -> String -> Value -> Parser o
forall a. String -> Value -> Parser a
Aeson.typeMismatch String
"Array" i
Value
v
ParseObject Maybe Text
mt Parser Object o
p -> case Maybe Text
mt of
Just Text
t -> String -> (Object -> Parser o) -> Value -> Parser o
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Yaml.withObject (Text -> String
T.unpack Text
t) ((Object -> Parser o) -> Value -> Parser o)
-> (Object -> Parser o) -> Value -> Parser o
forall a b. (a -> b) -> a -> b
$ Parser Object o -> Object -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Object o
p
Maybe Text
Nothing -> \i
v -> case i
v of
Yaml.Object o -> Parser Object o -> Object -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Object o
p Object
o
i
_ -> String -> Value -> Parser o
forall a. String -> Value -> Parser a
Aeson.typeMismatch String
"Object" i
Value
v
ParseField Text
key FieldParser o
fp -> \i
o -> case FieldParser o
fp of
FieldParserFmap a -> o
f FieldParser a
fp' -> a -> o
f (a -> o) -> Parser a -> Parser o
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Object a -> Object -> Parser a
forall i o. Parser i o -> i -> Parser o
go (Text -> FieldParser a -> Parser Object a
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
key FieldParser a
fp') i
Object
o
FieldParserRequired YamlParser o
p -> do
Value
v <- i
Object
o Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
Yaml..: Text
key
YamlParser o -> Value -> Parser o
forall i o. Parser i o -> i -> Parser o
go YamlParser o
p Value
v
FieldParserOptional YamlParser o
p -> do
case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key i
Object
o of
Maybe Value
Nothing -> Maybe o -> Parser (Maybe o)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe o
forall a. Maybe a
Nothing
Just Value
v -> o -> Maybe o
forall a. a -> Maybe a
Just (o -> Maybe o) -> Parser o -> Parser (Maybe o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> YamlParser o -> Value -> Parser o
forall i o. Parser i o -> i -> Parser o
go YamlParser o
p Value
v
FieldParserOptionalWithDefault YamlParser o
p o
d -> do
case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key i
Object
o of
Maybe Value
Nothing -> o -> Parser o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
d
Just Value
v -> YamlParser o -> Value -> Parser o
forall i o. Parser i o -> i -> Parser o
go YamlParser o
p Value
v
ParseList Parser Value o
p -> (Value -> Parser o) -> Array -> Parser (Vector o)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Parser Value o -> Value -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser Value o
p)
ParseMap Parser Value v
p -> (Text -> Value -> Parser v) -> Object -> Parser (HashMap Text v)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HM.traverseWithKey ((Text -> Value -> Parser v) -> Object -> Parser (HashMap Text v))
-> (Text -> Value -> Parser v) -> Object -> Parser (HashMap Text v)
forall a b. (a -> b) -> a -> b
$ \Text
_ Value
v -> Parser Value v -> Value -> Parser v
forall i o. Parser i o -> i -> Parser o
go Parser Value v
p Value
v
ParseMapKeys Parser Text k
p Parser Object (HashMap Text v)
pm -> \i
val -> do
HashMap Text v
hm <- Parser Object (HashMap Text v) -> Object -> Parser (HashMap Text v)
forall i o. Parser i o -> i -> Parser o
go Parser Object (HashMap Text v)
pm i
Object
val
[(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(k, v)] -> Map k v) -> Parser [(k, v)] -> Parser (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, v) -> Parser (k, v)) -> [(Text, v)] -> Parser [(k, v)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Text
k, v
v) -> (,) (k -> v -> (k, v)) -> Parser k -> Parser (v -> (k, v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text k -> Text -> Parser k
forall i o. Parser i o -> i -> Parser o
go Parser Text k
p Text
k Parser (v -> (k, v)) -> Parser v -> Parser (k, v)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> v -> Parser v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v) (HashMap Text v -> [(Text, v)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text v
hm)
ParsePure o
v -> Parser o -> i -> Parser o
forall a b. a -> b -> a
const (Parser o -> i -> Parser o) -> Parser o -> i -> Parser o
forall a b. (a -> b) -> a -> b
$ o -> Parser o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
v
ParseAp Parser i (a -> o)
pf Parser i a
p -> \i
v -> Parser i (a -> o) -> i -> Parser (a -> o)
forall i o. Parser i o -> i -> Parser o
go Parser i (a -> o)
pf i
v Parser (a -> o) -> Parser a -> Parser o
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser i a -> i -> Parser a
forall i o. Parser i o -> i -> Parser o
go Parser i a
p i
v
ParseAlt [Parser i o]
ps -> \i
v -> case [Parser i o]
ps of
[] -> String -> Parser o
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No alternatives."
[Parser i o
p] -> Parser i o -> i -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser i o
p i
v
(Parser i o
p' : [Parser i o]
ps') -> Parser i o -> i -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser i o
p' i
v Parser o -> Parser o -> Parser o
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser i o -> i -> Parser o
forall i o. Parser i o -> i -> Parser o
go ([Parser i o] -> Parser i o
forall i o. [Parser i o] -> Parser i o
ParseAlt [Parser i o]
ps') i
v
ParseFmap a -> o
f Parser i a
p -> (a -> o) -> Parser a -> Parser o
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> o
f (Parser a -> Parser o) -> (i -> Parser a) -> i -> Parser o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser i a -> i -> Parser a
forall i o. Parser i o -> i -> Parser o
go Parser i a
p
ParseComment Text
_ Parser i o
p -> Parser i o -> i -> Parser o
forall i o. Parser i o -> i -> Parser o
go Parser i o
p