module Hydra.Ext.Yaml.Coder (yamlCoder) where

import Hydra.All
import Hydra.Adapters.Term
import qualified Hydra.Impl.Haskell.Dsl.Terms as Terms
import Hydra.Ext.Yaml.Language
import qualified Hydra.Ext.Yaml.Model as YM
import Hydra.Adapters.UtilsEtc

import qualified Control.Monad as CM
import qualified Data.Map as M
import qualified Data.Maybe as Y


literalCoder :: LiteralType -> GraphFlow m (Coder (Context m) (Context m) Literal YM.Scalar)
literalCoder :: forall m.
LiteralType
-> GraphFlow m (Coder (Context m) (Context m) Literal Scalar)
literalCoder LiteralType
at = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case LiteralType
at of
  LiteralType
LiteralTypeBoolean -> Coder {
    coderEncode :: Literal -> Flow (Context m) Scalar
coderEncode = \(LiteralBoolean Bool
b) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Scalar
YM.ScalarBool Bool
b,
    coderDecode :: Scalar -> Flow (Context m) Literal
coderDecode = \Scalar
s -> case Scalar
s of
      YM.ScalarBool Bool
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Literal
LiteralBoolean Bool
b
      Scalar
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"boolean" Scalar
s}
  LiteralTypeFloat FloatType
_ -> Coder {
    coderEncode :: Literal -> Flow (Context m) Scalar
coderEncode = \(LiteralFloat (FloatValueBigfloat Double
f)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> Scalar
YM.ScalarFloat Double
f,
    coderDecode :: Scalar -> Flow (Context m) Literal
coderDecode = \Scalar
s -> case Scalar
s of
      YM.ScalarFloat Double
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FloatValue -> Literal
LiteralFloat forall a b. (a -> b) -> a -> b
$ Double -> FloatValue
FloatValueBigfloat Double
f
      Scalar
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"floating-point value" Scalar
s}
  LiteralTypeInteger IntegerType
_ -> Coder {
    coderEncode :: Literal -> Flow (Context m) Scalar
coderEncode = \(LiteralInteger (IntegerValueBigint Integer
i)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> Scalar
YM.ScalarInt Integer
i,
    coderDecode :: Scalar -> Flow (Context m) Literal
coderDecode = \Scalar
s -> case Scalar
s of
      YM.ScalarInt Integer
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IntegerValue -> Literal
LiteralInteger forall a b. (a -> b) -> a -> b
$ Integer -> IntegerValue
IntegerValueBigint Integer
i
      Scalar
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"integer" Scalar
s}
  LiteralType
LiteralTypeString -> Coder {
    coderEncode :: Literal -> Flow (Context m) Scalar
coderEncode = \(LiteralString String
s) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Scalar
YM.ScalarStr String
s,
    coderDecode :: Scalar -> Flow (Context m) Literal
coderDecode = \Scalar
s -> case Scalar
s of
      YM.ScalarStr String
s' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Literal
LiteralString String
s'
      Scalar
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"string" Scalar
s}

recordCoder :: (Eq m, Ord m, Read m, Show m) => RowType m -> GraphFlow m (Coder (Context m) (Context m) (Term m) YM.Node)
recordCoder :: forall m.
(Eq m, Ord m, Read m, Show m) =>
RowType m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
recordCoder RowType m
rt = do
    [(FieldType m, Coder (Context m) (Context m) (Term m) Node)]
coders <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (\FieldType m
f -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldType m
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
termCoder (forall m. FieldType m -> Type m
fieldTypeType FieldType m
f)) (forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (forall {m} {m} {s1} {s2}.
Show m =>
[(FieldType m, Coder s1 s2 (Term m) Node)]
-> Term m -> Flow s1 Node
encode [(FieldType m, Coder (Context m) (Context m) (Term m) Node)]
coders) (forall {m} {s1} {s2} {m}.
[(FieldType m, Coder s1 s2 (Term m) Node)]
-> Node -> Flow s2 (Term m)
decode [(FieldType m, Coder (Context m) (Context m) (Term m) Node)]
coders)
  where
    encode :: [(FieldType m, Coder s1 s2 (Term m) Node)]
-> Term m -> Flow s1 Node
encode [(FieldType m, Coder s1 s2 (Term m) Node)]
coders Term m
term = case forall m. Term m -> Term m
stripTerm Term m
term of
      TermRecord (Record Name
_ [Field m]
fields) -> Map Node Node -> Node
YM.NodeMapping forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
Y.catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
CM.zipWithM forall {m} {s1} {s2} {m} {a}.
(FieldType m, Coder s1 s2 (Term m) a)
-> Field m -> Flow s1 (Maybe (Node, a))
encodeField [(FieldType m, Coder s1 s2 (Term m) Node)]
coders [Field m]
fields
        where
          encodeField :: (FieldType m, Coder s1 s2 (Term m) a)
-> Field m -> Flow s1 (Maybe (Node, a))
encodeField (FieldType m
ft, Coder s1 s2 (Term m) a
coder) (Field (FieldName String
fn) Term m
fv) = case (forall m. FieldType m -> Type m
fieldTypeType FieldType m
ft, Term m
fv) of
            (TypeOptional Type m
_, TermOptional Maybe (Term m)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            (Type m, Term m)
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Node
yamlString String
fn) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder s1 s2 (Term m) a
coder Term m
fv)
      Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"record" Term m
term
    decode :: [(FieldType m, Coder s1 s2 (Term m) Node)]
-> Node -> Flow s2 (Term m)
decode [(FieldType m, Coder s1 s2 (Term m) Node)]
coders Node
n = case Node
n of
      YM.NodeMapping Map Node Node
m -> forall m. Name -> [Field m] -> Term m
Terms.record (forall m. RowType m -> Name
rowTypeTypeName RowType m
rt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (forall {m} {s1} {s2} {m}.
Map Node Node
-> (FieldType m, Coder s1 s2 (Term m) Node) -> Flow s2 (Field m)
decodeField Map Node Node
m) [(FieldType m, Coder s1 s2 (Term m) Node)]
coders -- Note: unknown fields are ignored
        where
          decodeField :: Map Node Node
-> (FieldType m, Coder s1 s2 (Term m) Node) -> Flow s2 (Field m)
decodeField Map Node Node
m (FieldType fname :: FieldName
fname@(FieldName String
fn) Type m
ft, Coder s1 s2 (Term m) Node
coder) = do
            Term m
v <- forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder s1 s2 (Term m) Node
coder forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
Y.fromMaybe Node
yamlNull forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> Node
yamlString String
fn) Map Node Node
m
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall m. FieldName -> Term m -> Field m
Field FieldName
fname Term m
v
      Node
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"mapping" Node
n
    getCoder :: Map String a -> String -> m a
getCoder Map String a
coders String
fname = forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe forall {a}. m a
error forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
fname Map String a
coders
      where
        error :: m a
error = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"no such field: " forall a. [a] -> [a] -> [a]
++ String
fname

termCoder :: (Eq m, Ord m, Read m, Show m) => Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) YM.Node)
termCoder :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
termCoder Type m
typ = case forall m. Type m -> Type m
stripType Type m
typ of
  TypeLiteral LiteralType
at -> do
    Coder (Context m) (Context m) Literal Scalar
ac <- forall m.
LiteralType
-> GraphFlow m (Coder (Context m) (Context m) Literal Scalar)
literalCoder LiteralType
at
    forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
      coderEncode :: Term m -> Flow (Context m) Node
coderEncode = \Term m
t -> case Term m
t of
         TermLiteral Literal
av -> Scalar -> Node
YM.NodeScalar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) Literal Scalar
ac Literal
av
         Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"literal" Term m
t,
      coderDecode :: Node -> Flow (Context m) (Term m)
coderDecode = \Node
n -> case Node
n of
        YM.NodeScalar Scalar
s -> forall m. Literal -> Term m
Terms.literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) Literal Scalar
ac Scalar
s
        Node
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"scalar node" Node
n}
  TypeList Type m
lt -> do
    Coder (Context m) (Context m) (Term m) Node
lc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
termCoder Type m
lt
    forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
      coderEncode :: Term m -> Flow (Context m) Node
coderEncode = \Term m
t -> case Term m
t of
         TermList [Term m]
els -> [Node] -> Node
YM.NodeSequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Node
lc) [Term m]
els
         Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"list" Term m
t,
      coderDecode :: Node -> Flow (Context m) (Term m)
coderDecode = \Node
n -> case Node
n of
        YM.NodeSequence [Node]
nodes -> forall m. [Term m] -> Term m
Terms.list forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) Node
lc) [Node]
nodes
        Node
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"sequence" Node
n}
  TypeOptional Type m
ot -> do
    Coder (Context m) (Context m) (Term m) Node
oc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
termCoder Type m
ot
    forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
      coderEncode :: Term m -> Flow (Context m) Node
coderEncode = \Term m
t -> case Term m
t of
         TermOptional Maybe (Term m)
el -> forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Node
yamlNull) (forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Node
oc) Maybe (Term m)
el
         Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"optional" Term m
t,
      coderDecode :: Node -> Flow (Context m) (Term m)
coderDecode = \Node
n -> case Node
n of
        YM.NodeScalar Scalar
YM.ScalarNull -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Maybe (Term m) -> Term m
Terms.optional forall a. Maybe a
Nothing
        Node
_ -> forall m. Maybe (Term m) -> Term m
Terms.optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) Node
oc Node
n}
  TypeMap (MapType Type m
kt Type m
vt) -> do
    Coder (Context m) (Context m) (Term m) Node
kc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
termCoder Type m
kt
    Coder (Context m) (Context m) (Term m) Node
vc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
termCoder Type m
vt
    let encodeEntry :: (Term m, Term m) -> Flow (Context m) (Node, Node)
encodeEntry (Term m
k, Term m
v) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Node
kc Term m
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Node
vc Term m
v
    let decodeEntry :: (Node, Node) -> Flow (Context m) (Term m, Term m)
decodeEntry (Node
k, Node
v) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) Node
kc Node
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) Node
vc Node
v
    forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
      coderEncode :: Term m -> Flow (Context m) Node
coderEncode = \Term m
t -> case Term m
t of
        TermMap Map (Term m) (Term m)
m -> Map Node Node -> Node
YM.NodeMapping forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (Term m, Term m) -> Flow (Context m) (Node, Node)
encodeEntry (forall k a. Map k a -> [(k, a)]
M.toList Map (Term m) (Term m)
m)
        Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"term" Term m
t,
      coderDecode :: Node -> Flow (Context m) (Term m)
coderDecode = \Node
n -> case Node
n of
        YM.NodeMapping Map Node Node
m -> forall m. Map (Term m) (Term m) -> Term m
Terms.map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (Node, Node) -> Flow (Context m) (Term m, Term m)
decodeEntry (forall k a. Map k a -> [(k, a)]
M.toList Map Node Node
m)
        Node
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"mapping" Node
n}
  TypeRecord RowType m
rt -> forall m.
(Eq m, Ord m, Read m, Show m) =>
RowType m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
recordCoder RowType m
rt

yamlCoder :: (Eq m, Ord m, Read m, Show m) => Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) YM.Node)
yamlCoder :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
yamlCoder Type m
typ = do
    Context m
cx <- forall s. Flow s s
getState
    let acx :: AdapterContext m
acx = forall m. Context m -> Language m -> Language m -> AdapterContext m
AdapterContext Context m
cx forall m. Language m
hydraCoreLanguage forall m. Language m
yamlLanguage
    SymmetricAdapter (Context m) (Type m) (Term m)
adapter <- forall s1 a s2. s1 -> Flow s1 a -> Flow s2 a
withState AdapterContext m
acx forall a b. (a -> b) -> a -> b
$ forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
typ
    Coder (Context m) (Context m) (Term m) Node
coder <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Node)
termCoder forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
adapter
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a b c. Coder s s a b -> Coder s s b c -> Coder s s a c
composeCoders (forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter (Context m) (Type m) (Term m)
adapter) Coder (Context m) (Context m) (Term m) Node
coder

yamlNull :: YM.Node
yamlNull :: Node
yamlNull = Scalar -> Node
YM.NodeScalar Scalar
YM.ScalarNull

yamlString :: String -> YM.Node
yamlString :: String -> Node
yamlString = Scalar -> Node
YM.NodeScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Scalar
YM.ScalarStr