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

import Hydra.Kernel
import Hydra.TermAdapters
import Hydra.Langs.Yaml.Language
import Hydra.AdapterUtils
import qualified Hydra.Langs.Yaml.Model as YM
import qualified Hydra.Dsl.Terms as Terms

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


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

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

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

yamlCoder :: Type -> Flow (Graph) (Coder (Graph) (Graph) (Term) YM.Node)
yamlCoder :: Type -> Flow Graph (Coder Graph Graph Term Node)
yamlCoder Type
typ = do
  SymmetricAdapter Graph Type Term
adapter <- Language -> Type -> Flow Graph (SymmetricAdapter Graph Type Term)
languageAdapter Language
yamlLanguage Type
typ
  Coder Graph Graph Term Node
coder <- Type -> Flow Graph (Coder Graph Graph Term Node)
termCoder (Type -> Flow Graph (Coder Graph Graph Term Node))
-> Type -> Flow Graph (Coder Graph Graph Term Node)
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter Graph Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter Graph Type Term
adapter
  Coder Graph Graph Term Node
-> Flow Graph (Coder Graph Graph Term Node)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Coder Graph Graph Term Node
 -> Flow Graph (Coder Graph Graph Term Node))
-> Coder Graph Graph Term Node
-> Flow Graph (Coder Graph Graph Term Node)
forall a b. (a -> b) -> a -> b
$ Coder Graph Graph Term Term
-> Coder Graph Graph Term Node -> Coder Graph Graph Term Node
forall s a b c. Coder s s a b -> Coder s s b c -> Coder s s a c
composeCoders (SymmetricAdapter Graph Type Term -> Coder Graph Graph Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter Graph Type Term
adapter) Coder Graph Graph Term 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 (Scalar -> Node) -> (String -> Scalar) -> String -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Scalar
YM.ScalarStr