{-# 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

-- | Use a 'Parser' to parse a value from Yaml.
--
-- A 'Parser i o' corresponds exactly to a 'i -> Yaml.Parser o' and this function servers as evidence for that.
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
      -- We can't just do 'withBool (maybe "Bool" T.unpack mt)' because then there is an extra context in the error message.
      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