module Hydra.Ext.Yaml.Modules (printModule) where

import Hydra.All
import Hydra.Adapters.Coders
import Hydra.Impl.Haskell.Ext.Yaml.Serde
import Hydra.Ext.Yaml.Coder
import Hydra.Ext.Yaml.Language
import qualified Hydra.Ext.Yaml.Model as YM
import qualified Hydra.Impl.Haskell.Dsl.Types as Types

import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.Map as M


constructModule :: (Ord m, Read m, Show m)
  => Module m
  -> M.Map (Type m) (Coder (Context m) (Context m) (Term m) YM.Node)
  -> [(Element m, TypedTerm m)]
  -> GraphFlow m YM.Node
constructModule :: forall m.
(Ord m, Read m, Show m) =>
Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) Node)
-> [(Element m, TypedTerm m)]
-> GraphFlow m Node
constructModule Module m
mod Map (Type m) (Coder (Context m) (Context m) (Term m) Node)
coders [(Element m, TypedTerm m)]
pairs = do
    [(Node, Node)]
keyvals <- forall s a. String -> Flow s a -> Flow s a
withTrace String
"encoding terms" (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM forall {m}.
(Element m, TypedTerm m) -> Flow (Context m) (Node, Node)
toYaml [(Element m, TypedTerm m)]
pairs)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map Node Node -> Node
YM.NodeMapping forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Node, Node)]
keyvals
  where
    toYaml :: (Element m, TypedTerm m) -> Flow (Context m) (Node, Node)
toYaml (Element m
el, (TypedTerm Type m
typ Term m
term)) = forall s a. String -> Flow s a -> Flow s a
withTrace (String
"element " forall a. [a] -> [a] -> [a]
++ Name -> String
unName (forall m. Element m -> Name
elementName Element m
el)) forall a b. (a -> b) -> a -> b
$ do
      Term m -> GraphFlow m Node
encode <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Type m
typ Map (Type m) (Coder (Context m) (Context m) (Term m) Node)
coders of
        Maybe (Coder (Context m) (Context m) (Term m) Node)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"no coder found for type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type m
typ
        Just Coder (Context m) (Context m) (Term m) Node
coder -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Node
coder
      Node
node <- Term m -> GraphFlow m Node
encode Term m
term
      forall (m :: * -> *) a. Monad m => a -> m a
return (Scalar -> Node
YM.NodeScalar forall a b. (a -> b) -> a -> b
$ String -> Scalar
YM.ScalarStr forall a b. (a -> b) -> a -> b
$ Name -> String
localNameOf forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Name
elementName Element m
el, Node
node)
    ns :: String
ns = Namespace -> String
unNamespace forall a b. (a -> b) -> a -> b
$ forall m. Module m -> Namespace
moduleNamespace Module m
mod
    localNameOf :: Name -> String
localNameOf Name
name = forall a. Int -> [a] -> [a]
L.drop (Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
ns) forall a b. (a -> b) -> a -> b
$ Name -> String
unName Name
name

printModule :: (Ord m, Read m, Show m) => Module m -> GraphFlow m (M.Map FilePath String)
printModule :: forall m.
(Ord m, Read m, Show m) =>
Module m -> GraphFlow m (Map String String)
printModule Module m
mod = forall s a. String -> Flow s a -> Flow s a
withTrace (String
"print module " forall a. [a] -> [a] -> [a]
++ (Namespace -> String
unNamespace forall a b. (a -> b) -> a -> b
$ forall m. Module m -> Namespace
moduleNamespace Module m
mod)) forall a b. (a -> b) -> a -> b
$ do
    Node
node <- forall m e d.
(Ord m, Read m, Show m) =>
Language m
-> (Term m -> GraphFlow m e)
-> (Module m
    -> Map (Type m) (Coder (Context m) (Context m) (Term m) e)
    -> [(Element m, TypedTerm m)]
    -> GraphFlow m d)
-> Module m
-> GraphFlow m d
transformModule forall m. Language m
yamlLanguage forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
encodeTerm forall m.
(Ord m, Read m, Show m) =>
Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) Node)
-> [(Element m, TypedTerm m)]
-> GraphFlow m Node
constructModule Module m
mod
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String
path, Node -> String
hydraYamlToString Node
node)]
  where
    path :: String
path = Bool -> FileExtension -> Namespace -> String
namespaceToFilePath Bool
False (String -> FileExtension
FileExtension String
"yaml") forall a b. (a -> b) -> a -> b
$ forall m. Module m -> Namespace
moduleNamespace Module m
mod
    encodeTerm :: p -> m a
encodeTerm p
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"only type definitions are expected in this mapping to YAML"