module Hydra.Adapters.Coders where

import Hydra.All
import Hydra.CoreDecoding
import Hydra.Adapters.Term
import Hydra.Adapters.UtilsEtc

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


adaptType :: (Ord m, Read m, Show m) => Language m -> Type m -> GraphFlow m (Type m)
adaptType :: forall m.
(Ord m, Read m, Show m) =>
Language m -> Type m -> GraphFlow m (Type m)
adaptType Language m
targetLang Type m
t = 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 Language m
targetLang
    SymmetricAdapter (Context m) (Type m) (Term m)
ad <- 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
t
    forall (m :: * -> *) a. Monad m => a -> m a
return 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)
ad

transformModule :: (Ord m, Read m, Show m)
  => Language m
  -> (Term m -> GraphFlow m e)
  -> (Module m -> 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 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 Language m
lang Term m -> GraphFlow m e
encodeTerm Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) e)
-> [(Element m, TypedTerm m)]
-> GraphFlow m d
createModule Module m
mod = do
    [TypedTerm m]
pairs <- forall m a. GraphFlow m a -> GraphFlow m a
withSchemaContext forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM forall m. Show m => Element m -> GraphFlow m (TypedTerm m)
elementAsTypedTerm [Element m]
els
    let types :: [Type m]
types = forall a. Eq a => [a] -> [a]
L.nub (forall m. TypedTerm m -> Type m
typedTermType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypedTerm m]
pairs)
    Map (Type m) (Coder (Context m) (Context m) (Term m) e)
coders <- [Type m]
-> Flow
     (Context m)
     (Map (Type m) (Coder (Context m) (Context m) (Term m) e))
codersFor [Type m]
types
    Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) e)
-> [(Element m, TypedTerm m)]
-> GraphFlow m d
createModule Module m
mod Map (Type m) (Coder (Context m) (Context m) (Term m) e)
coders forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
L.zip [Element m]
els [TypedTerm m]
pairs
  where
    els :: [Element m]
els = forall m. Module m -> [Element m]
moduleElements Module m
mod

    codersFor :: [Type m]
-> Flow
     (Context m)
     (Map (Type m) (Coder (Context m) (Context m) (Term m) e))
codersFor [Type m]
types = do
      [Coder (Context m) (Context m) (Term m) e]
cdrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Type m
-> Flow (Context m) (Coder (Context m) (Context m) (Term m) e)
constructCoder [Type m]
types
      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 forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
L.zip [Type m]
types [Coder (Context m) (Context m) (Term m) e]
cdrs

    constructCoder :: Type m
-> Flow (Context m) (Coder (Context m) (Context m) (Term m) e)
constructCoder Type m
typ = forall s a. String -> Flow s a -> Flow s a
withTrace (String
"coder for " forall a. [a] -> [a] -> [a]
++ forall m. Type m -> String
describeType Type m
typ) forall a b. (a -> b) -> a -> b
$ 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 Language m
lang
        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) e
coder <- forall {f :: * -> *} {p}.
Applicative f =>
p -> f (Coder (Context m) (Context m) (Term m) e)
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) e
coder
      where
        termCoder :: p -> f (Coder (Context m) (Context m) (Term m) e)
termCoder p
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a s b. (a -> Flow s b) -> Coder s s a b
unidirectionalCoder Term m -> GraphFlow m e
encodeTerm