-- | Entry point for Hydra's adapter (type/term rewriting) framework.
--   An adapter takes a type expression which is supported in a source language, and rewrites it to a type which is supported by a target language.
--   In parallel, terms conforming to the original type are rewritten. Both levels of the transformation are bidirectional.

module Hydra.Adapters.Coders where

import Hydra.Kernel
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