{-# LANGUAGE CPP #-}
{-# 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
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as HM
import qualified Data.Aeson.Key as K
#else
import qualified Data.HashMap.Strict as HM
#endif
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import YamlParse.Applicative.Parser
#if MIN_VERSION_aeson(2,0,0)
fromText :: T.Text -> K.Key
fromText :: Text -> Key
fromText = Text -> Key
K.fromText
toText :: K.Key -> T.Text
toText :: Key -> Text
toText = Key -> Text
K.toText
#else
fromText :: T.Text -> T.Text
fromText = id
toText :: T.Text -> T.Text
toText = id
#endif
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 -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
Yaml..: Text -> Key
fromText 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 Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
HM.lookup (Text -> Key
fromText 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 Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
HM.lookup (Text -> Key
fromText 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 -> (Key -> Value -> Parser v) -> Object -> Parser (KeyMap v)
forall (f :: * -> *) v1 v2.
Applicative f =>
(Key -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)
HM.traverseWithKey ((Key -> Value -> Parser v) -> Object -> Parser (KeyMap v))
-> (Key -> Value -> Parser v) -> Object -> Parser (KeyMap v)
forall a b. (a -> b) -> a -> b
$ \Key
_ 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 (KeyMap v)
pm -> \i
val -> do
KeyMap v
hm <- Parser Object (KeyMap v) -> Object -> Parser (KeyMap v)
forall i o. Parser i o -> i -> Parser o
go Parser Object (KeyMap 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
<$> ((Key, v) -> Parser (k, v)) -> [(Key, v)] -> Parser [(k, v)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Key
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 (Key -> Text
toText Key
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) (KeyMap v -> [(Key, v)]
forall v. KeyMap v -> [(Key, v)]
HM.toList KeyMap 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