-- | Adapter framework for types and terms

module Hydra.TermAdapters (
  fieldAdapter,
  functionProxyName,
  functionProxyType,
  termAdapter,
) where

import Hydra.Printing
import Hydra.AdapterUtils
import Hydra.Basics
import Hydra.Strip
import Hydra.Coders
import Hydra.Compute
import Hydra.Core
import Hydra.Schemas
import Hydra.Graph
import Hydra.Lexical
import Hydra.Mantle
import Hydra.Reduction
import Hydra.Rewriting
import Hydra.LiteralAdapters
import Hydra.Dsl.Terms
import Hydra.Reduction
import Hydra.Tier1
import Hydra.Tier2
import qualified Hydra.Dsl.Expect as Expect
import qualified Hydra.Dsl.Types as Types

import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Text.Read as TR
import qualified Data.Maybe as Y


_context :: Name
_context :: Name
_context = String -> Name
Name String
"context"

_record :: Name
_record :: Name
_record = String -> Name
Name String
"record"

fieldAdapter :: FieldType -> Flow (AdapterContext) (SymmetricAdapter (AdapterContext) (FieldType) (Field))
fieldAdapter :: FieldType
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
fieldAdapter FieldType
ftyp = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter TypeAdapter -> TypeAdapter
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
ftyp
  SymmetricAdapter AdapterContext FieldType Field
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext FieldType Field
 -> Flow
      AdapterContext (SymmetricAdapter AdapterContext FieldType Field))
-> SymmetricAdapter AdapterContext FieldType Field
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
forall a b. (a -> b) -> a -> b
$ Bool
-> FieldType
-> FieldType
-> Coder AdapterContext AdapterContext Field Field
-> SymmetricAdapter AdapterContext FieldType Field
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) FieldType
ftyp (FieldType
ftyp { fieldTypeType = adapterTarget ad })
    (Coder AdapterContext AdapterContext Field Field
 -> SymmetricAdapter AdapterContext FieldType Field)
-> Coder AdapterContext AdapterContext Field Field
-> SymmetricAdapter AdapterContext FieldType Field
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Field -> Flow AdapterContext Field)
-> Coder AdapterContext AdapterContext Field Field
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Field -> Flow AdapterContext Field)
 -> Coder AdapterContext AdapterContext Field Field)
-> (CoderDirection -> Field -> Flow AdapterContext Field)
-> Coder AdapterContext AdapterContext Field Field
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (Field Name
name Term
term) -> Name -> Term -> Field
Field Name
name (Term -> Field)
-> Flow AdapterContext Term -> Flow AdapterContext Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term

-- | This function accounts for recursive type definitions
forTypeReference :: Name -> Flow (AdapterContext) (SymmetricAdapter (AdapterContext) (Type) (Term))
forTypeReference :: Name
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forTypeReference Name
name = String
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"adapt named type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name) (Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ do
  let lossy :: Bool
lossy = Bool
False -- Note: we cannot know in advance whether the adapter is lossy or not
  let placeholder :: SymmetricAdapter AdapterContext Type Term
placeholder = Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy (Name -> Type
TypeVariable Name
name) (Name -> Type
TypeVariable Name
name) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$
        \CoderDirection
dir Term
term -> do
          AdapterContext
cx <- Flow AdapterContext AdapterContext
forall s. Flow s s
getState
          case Name
-> Map Name (SymmetricAdapter AdapterContext Type Term)
-> Maybe (SymmetricAdapter AdapterContext Type Term)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name (AdapterContext
-> Map Name (SymmetricAdapter AdapterContext Type Term)
adapterContextAdapters AdapterContext
cx) of
            Maybe (SymmetricAdapter AdapterContext Type Term)
Nothing -> String -> Flow AdapterContext Term
forall a. String -> Flow AdapterContext a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow AdapterContext Term)
-> String -> Flow AdapterContext Term
forall a b. (a -> b) -> a -> b
$ String
"no adapter for reference type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name
            Just SymmetricAdapter AdapterContext Type Term
ad -> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term
  AdapterContext
cx <- Flow AdapterContext AdapterContext
forall s. Flow s s
getState
  let adapters :: Map Name (SymmetricAdapter AdapterContext Type Term)
adapters = AdapterContext
-> Map Name (SymmetricAdapter AdapterContext Type Term)
adapterContextAdapters AdapterContext
cx
  case Name
-> Map Name (SymmetricAdapter AdapterContext Type Term)
-> Maybe (SymmetricAdapter AdapterContext Type Term)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name Map Name (SymmetricAdapter AdapterContext Type Term)
adapters of
    Maybe (SymmetricAdapter AdapterContext Type Term)
Nothing -> do
      -- Insert a placeholder until the actual adapter has been constructed
      AdapterContext -> Flow AdapterContext ()
forall s. s -> Flow s ()
putState (AdapterContext
cx {adapterContextAdapters = M.insert name placeholder adapters})
      Maybe Type
mt <- Flow Graph (Maybe Type) -> Flow AdapterContext (Maybe Type)
forall x. Flow Graph x -> Flow AdapterContext x
withGraphContext (Flow Graph (Maybe Type) -> Flow AdapterContext (Maybe Type))
-> Flow Graph (Maybe Type) -> Flow AdapterContext (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Type -> Flow Graph (Maybe Type)
resolveType (Type -> Flow Graph (Maybe Type))
-> Type -> Flow Graph (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Name -> Type
TypeVariable Name
name
      case Maybe Type
mt of
        Maybe Type
Nothing -> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy (Name -> Type
TypeVariable Name
name) (Name -> Type
TypeVariable Name
name) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ (Term -> Flow AdapterContext Term)
-> CoderDirection -> Term -> Flow AdapterContext Term
forall a b. a -> b -> a
const Term -> Flow AdapterContext Term
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Just Type
t -> do
          SymmetricAdapter AdapterContext Type Term
actual <- TypeAdapter
termAdapter Type
t
          AdapterContext -> Flow AdapterContext ()
forall s. s -> Flow s ()
putState (AdapterContext
cx {adapterContextAdapters = M.insert name actual adapters})
          SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return SymmetricAdapter AdapterContext Type Term
actual
    Just SymmetricAdapter AdapterContext Type Term
ad -> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SymmetricAdapter AdapterContext Type Term
ad

functionProxyName :: Name
functionProxyName :: Name
functionProxyName = String -> Name
Name String
"hydra/core.FunctionProxy"

functionProxyType :: Type -> Type
functionProxyType :: Type -> Type
functionProxyType Type
dom = RowType -> Type
TypeUnion (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ Name -> [FieldType] -> RowType
RowType Name
functionProxyName [
  Name -> Type -> FieldType
FieldType Name
_Elimination_wrap Type
Types.string,
  Name -> Type -> FieldType
FieldType Name
_Elimination_optional Type
Types.string,
  Name -> Type -> FieldType
FieldType Name
_Elimination_record Type
Types.string,
  Name -> Type -> FieldType
FieldType Name
_Elimination_union Type
Types.string, -- TODO (TypeRecord cases)
  Name -> Type -> FieldType
FieldType Name
_Function_lambda Type
Types.string, -- TODO (TypeRecord [FieldType _Lambda_parameter Types.string, FieldType _Lambda_body cod]),
  Name -> Type -> FieldType
FieldType Name
_Function_primitive Type
Types.string,
  Name -> Type -> FieldType
FieldType Name
_Term_variable Type
Types.string]

functionToUnion :: TypeAdapter
functionToUnion :: TypeAdapter
functionToUnion t :: Type
t@(TypeFunction (FunctionType Type
dom Type
_)) = do
    Type
ut <- Flow AdapterContext Type
unionType
    SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
ut
    SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (Term -> Flow AdapterContext Term)
-> (Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (SymmetricAdapter AdapterContext Type Term
-> Term -> Flow AdapterContext Term
forall {s1} {s2} {t1} {t2} {v2}.
Adapter s1 s2 t1 t2 Term v2 -> Term -> Flow s1 v2
encode SymmetricAdapter AdapterContext Type Term
ad) (SymmetricAdapter AdapterContext Type Term
-> Term -> Flow AdapterContext Term
forall {s1} {s2} {t1} {t2} {v2}.
Adapter s1 s2 t1 t2 Term v2 -> v2 -> Flow s2 Term
decode SymmetricAdapter AdapterContext Type Term
ad)
  where
    encode :: Adapter s1 s2 t1 t2 Term v2 -> Term -> Flow s1 v2
encode Adapter s1 s2 t1 t2 Term v2
ad Term
term = Coder s1 s2 Term v2 -> Term -> Flow s1 v2
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (Adapter s1 s2 t1 t2 Term v2 -> Coder s1 s2 Term v2
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s1 s2 t1 t2 Term v2
ad) (Term -> Flow s1 v2) -> Term -> Flow s1 v2
forall a b. (a -> b) -> a -> b
$ case Term -> Term
fullyStripTerm Term
term of
      TermFunction Function
f -> case Function
f of
        FunctionElimination Elimination
e -> case Elimination
e of
          EliminationWrap (Name String
name) -> Name -> Name -> Term -> Term
variant Name
functionProxyName Name
_Elimination_wrap (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string String
name
          EliminationOptional OptionalCases
_ -> Name -> Name -> Term -> Term
variant Name
functionProxyName Name
_Elimination_optional (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string (String -> Term) -> String -> Term
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
term -- TODO
          EliminationRecord Projection
_ -> Name -> Name -> Term -> Term
variant Name
functionProxyName Name
_Elimination_record (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string (String -> Term) -> String -> Term
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
term -- TODO
          EliminationUnion CaseStatement
_ -> Name -> Name -> Term -> Term
variant Name
functionProxyName Name
_Elimination_union (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string (String -> Term) -> String -> Term
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
term -- TODO
        FunctionLambda Lambda
_ -> Name -> Name -> Term -> Term
variant Name
functionProxyName Name
_Function_lambda (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string (String -> Term) -> String -> Term
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
term -- TODO
        FunctionPrimitive (Name String
name) -> Name -> Name -> Term -> Term
variant Name
functionProxyName Name
_Function_primitive (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string String
name
      TermVariable (Name String
var) -> Name -> Name -> Term -> Term
variant Name
functionProxyName Name
_Term_variable (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string String
var

    decode :: Adapter s1 s2 t1 t2 Term v2 -> v2 -> Flow s2 Term
decode Adapter s1 s2 t1 t2 Term v2
ad v2
term = do
        (Field Name
fname Term
fterm) <- Coder s1 s2 Term v2 -> v2 -> Flow s2 Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode (Adapter s1 s2 t1 t2 Term v2 -> Coder s1 s2 Term v2
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s1 s2 t1 t2 Term v2
ad) v2
term Flow s2 Term -> (Term -> Flow s2 Field) -> Flow s2 Field
forall a b. Flow s2 a -> (a -> Flow s2 b) -> Flow s2 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> Flow s2 Field
forall s. Term -> Flow s Field
Expect.injection
        Flow s2 Term -> Maybe (Flow s2 Term) -> Flow s2 Term
forall a. a -> Maybe a -> a
Y.fromMaybe (Name -> Flow s2 Term
forall {m :: * -> *} {a}. MonadFail m => Name -> m a
notFound Name
fname) (Maybe (Flow s2 Term) -> Flow s2 Term)
-> Maybe (Flow s2 Term) -> Flow s2 Term
forall a b. (a -> b) -> a -> b
$ Name -> Map Name (Flow s2 Term) -> Maybe (Flow s2 Term)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname (Map Name (Flow s2 Term) -> Maybe (Flow s2 Term))
-> Map Name (Flow s2 Term) -> Maybe (Flow s2 Term)
forall a b. (a -> b) -> a -> b
$ [(Name, Flow s2 Term)] -> Map Name (Flow s2 Term)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
          (Name
_Elimination_wrap, Term -> Flow s2 Term
forall {s}. Term -> Flow s Term
forWrapped Term
fterm),
          (Name
_Elimination_optional, Term -> Flow s2 Term
forall {b} {s}. Read b => Term -> Flow s b
forOptionalCases Term
fterm),
          (Name
_Elimination_record, Term -> Flow s2 Term
forall {b} {s}. Read b => Term -> Flow s b
forProjection Term
fterm),
          (Name
_Elimination_union, Term -> Flow s2 Term
forall {b} {s}. Read b => Term -> Flow s b
forCases Term
fterm),
          (Name
_Function_lambda, Term -> Flow s2 Term
forall {b} {s}. Read b => Term -> Flow s b
forLambda Term
fterm),
          (Name
_Function_primitive, Term -> Flow s2 Term
forall {s}. Term -> Flow s Term
forPrimitive Term
fterm),
          (Name
_Term_variable, Term -> Flow s2 Term
forall {s}. Term -> Flow s Term
forVariable Term
fterm)]
      where
        notFound :: Name -> m a
notFound Name
fname = 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
"unexpected field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
fname
        forCases :: Term -> Flow s b
forCases Term
fterm = String -> b
forall a. Read a => String -> a
read (String -> b) -> Flow s String -> Flow s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
fterm -- TODO
        forLambda :: Term -> Flow s b
forLambda Term
fterm = String -> b
forall a. Read a => String -> a
read (String -> b) -> Flow s String -> Flow s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
fterm -- TODO
        forWrapped :: Term -> Flow s Term
forWrapped Term
fterm = Name -> Term
unwrap (Name -> Term) -> (String -> Name) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Name (String -> Term) -> Flow s String -> Flow s Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
fterm
        forOptionalCases :: Term -> Flow s b
forOptionalCases Term
fterm = String -> b
forall a. Read a => String -> a
read (String -> b) -> Flow s String -> Flow s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
fterm -- TODO
        forPrimitive :: Term -> Flow s Term
forPrimitive Term
fterm = Name -> Term
primitive (Name -> Term) -> (String -> Name) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Name (String -> Term) -> Flow s String -> Flow s Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
fterm
        forProjection :: Term -> Flow s b
forProjection Term
fterm = String -> b
forall a. Read a => String -> a
read (String -> b) -> Flow s String -> Flow s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
fterm -- TODO
        forVariable :: Term -> Flow s Term
forVariable Term
fterm = String -> Term
var (String -> Term) -> Flow s String -> Flow s Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
fterm

    unionType :: Flow AdapterContext Type
unionType = do
      SymmetricAdapter AdapterContext Type Term
domAd <- TypeAdapter
termAdapter Type
dom
      Type -> Flow AdapterContext Type
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Flow AdapterContext Type)
-> Type -> Flow AdapterContext Type
forall a b. (a -> b) -> a -> b
$ RowType -> Type
TypeUnion (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ Name -> [FieldType] -> RowType
RowType Name
functionProxyName [
        Name -> Type -> FieldType
FieldType Name
_Elimination_wrap Type
Types.string,
        Name -> Type -> FieldType
FieldType Name
_Elimination_optional Type
Types.string,
        Name -> Type -> FieldType
FieldType Name
_Elimination_record Type
Types.string,
        Name -> Type -> FieldType
FieldType Name
_Elimination_union Type
Types.string, -- TODO (TypeRecord cases)
        Name -> Type -> FieldType
FieldType Name
_Function_lambda Type
Types.string, -- TODO (TypeRecord [FieldType _Lambda_parameter Types.string, FieldType _Lambda_body cod]),
        Name -> Type -> FieldType
FieldType Name
_Function_primitive Type
Types.string,
        Name -> Type -> FieldType
FieldType Name
_Term_variable Type
Types.string]

lambdaToMonotype :: TypeAdapter
lambdaToMonotype :: TypeAdapter
lambdaToMonotype t :: Type
t@(TypeLambda (LambdaType Name
_ Type
body)) = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
body
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return SymmetricAdapter AdapterContext Type Term
ad {adapterSource = t}

listToSet :: TypeAdapter
listToSet :: TypeAdapter
listToSet t :: Type
t@(TypeSet Type
st) = do
    SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter TypeAdapter -> TypeAdapter
forall a b. (a -> b) -> a -> b
$ Type -> Type
Types.list Type
st
    SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (Term -> Flow AdapterContext Term)
-> (Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (SymmetricAdapter AdapterContext Type Term
-> Term -> Flow AdapterContext Term
forall {s1} {s2} {t1} {t2} {v2}.
Adapter s1 s2 t1 t2 Term v2 -> Term -> Flow s1 v2
encode SymmetricAdapter AdapterContext Type Term
ad) (SymmetricAdapter AdapterContext Type Term
-> Term -> Flow AdapterContext Term
forall {s1} {s2} {t1} {t2} {v2}.
Adapter s1 s2 t1 t2 Term v2 -> v2 -> Flow s2 Term
decode SymmetricAdapter AdapterContext Type Term
ad)
  where
    encode :: Adapter s1 s2 t1 t2 Term v2 -> Term -> Flow s1 v2
encode Adapter s1 s2 t1 t2 Term v2
ad (TermSet Set Term
s) = Coder s1 s2 Term v2 -> Term -> Flow s1 v2
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (Adapter s1 s2 t1 t2 Term v2 -> Coder s1 s2 Term v2
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s1 s2 t1 t2 Term v2
ad) (Term -> Flow s1 v2) -> Term -> Flow s1 v2
forall a b. (a -> b) -> a -> b
$ [Term] -> Term
TermList ([Term] -> Term) -> [Term] -> Term
forall a b. (a -> b) -> a -> b
$ Set Term -> [Term]
forall a. Set a -> [a]
S.toList Set Term
s
    decode :: Adapter s1 s2 t1 t2 Term v2 -> v2 -> Flow s2 Term
decode Adapter s1 s2 t1 t2 Term v2
ad v2
term = Set Term -> Term
TermSet (Set Term -> Term) -> (Term -> Set Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term] -> Set Term
forall a. Ord a => [a] -> Set a
S.fromList ([Term] -> Set Term) -> (Term -> [Term]) -> Term -> Set Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(TermList [Term]
l') -> [Term]
l') (Term -> Term) -> Flow s2 Term -> Flow s2 Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coder s1 s2 Term v2 -> v2 -> Flow s2 Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode (Adapter s1 s2 t1 t2 Term v2 -> Coder s1 s2 Term v2
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s1 s2 t1 t2 Term v2
ad) v2
term

optionalToList :: TypeAdapter
optionalToList :: TypeAdapter
optionalToList t :: Type
t@(TypeOptional Type
ot) = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
ot
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
False Type
t (Type -> Type
Types.list (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ Coder {
    coderEncode :: Term -> Flow AdapterContext Term
coderEncode = \(TermOptional Maybe Term
m) -> Flow AdapterContext Term
-> (Term -> Flow AdapterContext Term)
-> Maybe Term
-> Flow AdapterContext Term
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe
      (Term -> Flow AdapterContext Term
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Flow AdapterContext Term)
-> Term -> Flow AdapterContext Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Term
list [])
      ((Term -> Term)
-> Flow AdapterContext Term -> Flow AdapterContext Term
forall a b.
(a -> b) -> Flow AdapterContext a -> Flow AdapterContext b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ Term
r -> [Term] -> Term
list [Term
r]) (Flow AdapterContext Term -> Flow AdapterContext Term)
-> (Term -> Flow AdapterContext Term)
-> Term
-> Flow AdapterContext Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coder AdapterContext AdapterContext Term Term
-> Term -> Flow AdapterContext Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad)) Maybe Term
m,
    coderDecode :: Term -> Flow AdapterContext Term
coderDecode = \(TermList [Term]
l) -> Maybe Term -> Term
optional (Maybe Term -> Term)
-> Flow AdapterContext (Maybe Term) -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if [Term] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Term]
l then
      Maybe Term -> Flow AdapterContext (Maybe Term)
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Term
forall a. Maybe a
Nothing
      else Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term)
-> Flow AdapterContext Term -> Flow AdapterContext (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coder AdapterContext AdapterContext Term Term
-> Term -> Flow AdapterContext Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) ([Term] -> Term
forall a. HasCallStack => [a] -> a
L.head [Term]
l)}

-- TODO: only tested for type mappings; not yet for types+terms
passApplication :: TypeAdapter
passApplication :: TypeAdapter
passApplication Type
t = do
    Type
reduced <- Flow Graph Type -> Flow AdapterContext Type
forall x. Flow Graph x -> Flow AdapterContext x
withGraphContext (Flow Graph Type -> Flow AdapterContext Type)
-> Flow Graph Type -> Flow AdapterContext Type
forall a b. (a -> b) -> a -> b
$ Type -> Flow Graph Type
betaReduceType Type
t
    SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
reduced
    SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t Type
reduced (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$
      \CoderDirection
dir Term
term -> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term

passFunction :: TypeAdapter
passFunction :: TypeAdapter
passFunction t :: Type
t@(TypeFunction (FunctionType Type
dom Type
cod)) = do
    SymmetricAdapter AdapterContext Type Term
domAd <- TypeAdapter
termAdapter Type
dom
    SymmetricAdapter AdapterContext Type Term
codAd <- TypeAdapter
termAdapter Type
cod
    Map Name (SymmetricAdapter AdapterContext FieldType Field)
caseAds <- case Type -> Type
stripType Type
dom of
      TypeUnion RowType
rt -> [(Name, SymmetricAdapter AdapterContext FieldType Field)]
-> Map Name (SymmetricAdapter AdapterContext FieldType Field)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, SymmetricAdapter AdapterContext FieldType Field)]
 -> Map Name (SymmetricAdapter AdapterContext FieldType Field))
-> ([SymmetricAdapter AdapterContext FieldType Field]
    -> [(Name, SymmetricAdapter AdapterContext FieldType Field)])
-> [SymmetricAdapter AdapterContext FieldType Field]
-> Map Name (SymmetricAdapter AdapterContext FieldType Field)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name]
-> [SymmetricAdapter AdapterContext FieldType Field]
-> [(Name, SymmetricAdapter AdapterContext FieldType Field)]
forall a b. [a] -> [b] -> [(a, b)]
L.zip (FieldType -> Name
fieldTypeName (FieldType -> Name) -> [FieldType] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowType -> [FieldType]
rowTypeFields RowType
rt)
        ([SymmetricAdapter AdapterContext FieldType Field]
 -> Map Name (SymmetricAdapter AdapterContext FieldType Field))
-> Flow
     AdapterContext [SymmetricAdapter AdapterContext FieldType Field]
-> Flow
     AdapterContext
     (Map Name (SymmetricAdapter AdapterContext FieldType Field))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldType
 -> Flow
      AdapterContext (SymmetricAdapter AdapterContext FieldType Field))
-> [FieldType]
-> Flow
     AdapterContext [SymmetricAdapter AdapterContext FieldType 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 (\FieldType
f -> FieldType
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
fieldAdapter (FieldType
 -> Flow
      AdapterContext (SymmetricAdapter AdapterContext FieldType Field))
-> FieldType
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
forall a b. (a -> b) -> a -> b
$ Name -> Type -> FieldType
FieldType (FieldType -> Name
fieldTypeName FieldType
f) (FunctionType -> Type
TypeFunction (FunctionType -> Type) -> FunctionType -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> FunctionType
FunctionType (FieldType -> Type
fieldTypeType FieldType
f) Type
cod)) (RowType -> [FieldType]
rowTypeFields RowType
rt)
      Type
_ -> Map Name (SymmetricAdapter AdapterContext FieldType Field)
-> Flow
     AdapterContext
     (Map Name (SymmetricAdapter AdapterContext FieldType Field))
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Name (SymmetricAdapter AdapterContext FieldType Field)
forall k a. Map k a
M.empty
    Maybe (SymmetricAdapter AdapterContext Type Term)
optionAd <- case Type -> Type
stripType Type
dom of
      TypeOptional Type
ot -> SymmetricAdapter AdapterContext Type Term
-> Maybe (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Maybe a
Just (SymmetricAdapter AdapterContext Type Term
 -> Maybe (SymmetricAdapter AdapterContext Type Term))
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
-> Flow
     AdapterContext (Maybe (SymmetricAdapter AdapterContext Type Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeAdapter
termAdapter (Type -> Type -> Type
Types.function Type
ot Type
cod)
      Type
_ -> Maybe (SymmetricAdapter AdapterContext Type Term)
-> Flow
     AdapterContext (Maybe (SymmetricAdapter AdapterContext Type Term))
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SymmetricAdapter AdapterContext Type Term)
forall a. Maybe a
Nothing
    let lossy :: Bool
lossy = SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
codAd Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (SymmetricAdapter AdapterContext FieldType Field -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy (SymmetricAdapter AdapterContext FieldType Field -> Bool)
-> ((Name, SymmetricAdapter AdapterContext FieldType Field)
    -> SymmetricAdapter AdapterContext FieldType Field)
-> (Name, SymmetricAdapter AdapterContext FieldType Field)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, SymmetricAdapter AdapterContext FieldType Field)
-> SymmetricAdapter AdapterContext FieldType Field
forall a b. (a, b) -> b
snd ((Name, SymmetricAdapter AdapterContext FieldType Field) -> Bool)
-> [(Name, SymmetricAdapter AdapterContext FieldType Field)]
-> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (SymmetricAdapter AdapterContext FieldType Field)
-> [(Name, SymmetricAdapter AdapterContext FieldType Field)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name (SymmetricAdapter AdapterContext FieldType Field)
caseAds)
    let target :: Type
target = Type -> Type -> Type
Types.function (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
domAd) (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
codAd)
    SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy Type
t Type
target
      (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir Term
term -> case Term -> Term
fullyStripTerm Term
term of
        TermFunction Function
f -> Function -> Term
TermFunction (Function -> Term)
-> Flow AdapterContext Function -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Function
f of
          FunctionElimination Elimination
e -> Elimination -> Function
FunctionElimination (Elimination -> Function)
-> Flow AdapterContext Elimination -> Flow AdapterContext Function
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Elimination
e of
            EliminationOptional (OptionalCases Term
nothing Term
just) -> OptionalCases -> Elimination
EliminationOptional (OptionalCases -> Elimination)
-> Flow AdapterContext OptionalCases
-> Flow AdapterContext Elimination
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (
              Term -> Term -> OptionalCases
OptionalCases
                (Term -> Term -> OptionalCases)
-> Flow AdapterContext Term
-> Flow AdapterContext (Term -> OptionalCases)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
codAd) Term
nothing
                Flow AdapterContext (Term -> OptionalCases)
-> Flow AdapterContext Term -> Flow AdapterContext OptionalCases
forall a b.
Flow AdapterContext (a -> b)
-> Flow AdapterContext a -> Flow AdapterContext b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder (SymmetricAdapter AdapterContext Type Term
 -> Coder AdapterContext AdapterContext Term Term)
-> SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ Maybe (SymmetricAdapter AdapterContext Type Term)
-> SymmetricAdapter AdapterContext Type Term
forall a. HasCallStack => Maybe a -> a
Y.fromJust Maybe (SymmetricAdapter AdapterContext Type Term)
optionAd) Term
just))
            EliminationUnion (CaseStatement Name
n Maybe Term
def [Field]
cases) -> do
                [Field]
rcases <- (Field -> Flow AdapterContext Field)
-> [Field] -> Flow AdapterContext [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 (\Field
f -> CoderDirection
-> Coder AdapterContext AdapterContext Field Field
-> Field
-> Flow AdapterContext Field
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (Name -> Coder AdapterContext AdapterContext Field Field
getCoder (Name -> Coder AdapterContext AdapterContext Field Field)
-> Name -> Coder AdapterContext AdapterContext Field Field
forall a b. (a -> b) -> a -> b
$ Field -> Name
fieldName Field
f) Field
f) [Field]
cases
                Maybe Term
rdef <- case Maybe Term
def of
                  Maybe Term
Nothing -> Maybe Term -> Flow AdapterContext (Maybe Term)
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Term
forall a. Maybe a
Nothing
                  Just Term
d -> Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term)
-> Flow AdapterContext Term -> Flow AdapterContext (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
codAd) Term
d
                Elimination -> Flow AdapterContext Elimination
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (Elimination -> Flow AdapterContext Elimination)
-> Elimination -> Flow AdapterContext Elimination
forall a b. (a -> b) -> a -> b
$ CaseStatement -> Elimination
EliminationUnion (CaseStatement -> Elimination) -> CaseStatement -> Elimination
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Term -> [Field] -> CaseStatement
CaseStatement Name
n Maybe Term
rdef [Field]
rcases
              where
                -- Note: this causes unrecognized cases to simply be passed through;
                --       it is not the job of this adapter to catch validation issues.
                getCoder :: Name -> Coder AdapterContext AdapterContext Field Field
getCoder Name
fname = Coder AdapterContext AdapterContext Field Field
-> (SymmetricAdapter AdapterContext FieldType Field
    -> Coder AdapterContext AdapterContext Field Field)
-> Maybe (SymmetricAdapter AdapterContext FieldType Field)
-> Coder AdapterContext AdapterContext Field Field
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe Coder AdapterContext AdapterContext Field Field
forall s a. Coder s s a a
idCoder SymmetricAdapter AdapterContext FieldType Field
-> Coder AdapterContext AdapterContext Field Field
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder (Maybe (SymmetricAdapter AdapterContext FieldType Field)
 -> Coder AdapterContext AdapterContext Field Field)
-> Maybe (SymmetricAdapter AdapterContext FieldType Field)
-> Coder AdapterContext AdapterContext Field Field
forall a b. (a -> b) -> a -> b
$ Name
-> Map Name (SymmetricAdapter AdapterContext FieldType Field)
-> Maybe (SymmetricAdapter AdapterContext FieldType Field)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname Map Name (SymmetricAdapter AdapterContext FieldType Field)
caseAds
          FunctionLambda (Lambda Name
var Maybe Type
d Term
body) -> Lambda -> Function
FunctionLambda (Lambda -> Function)
-> Flow AdapterContext Lambda -> Flow AdapterContext Function
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Maybe Type -> Term -> Lambda
Lambda Name
var Maybe Type
d (Term -> Lambda)
-> Flow AdapterContext Term -> Flow AdapterContext Lambda
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
codAd) Term
body)
          FunctionPrimitive Name
name -> Function -> Flow AdapterContext Function
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Flow AdapterContext Function)
-> Function -> Flow AdapterContext Function
forall a b. (a -> b) -> a -> b
$ Name -> Function
FunctionPrimitive Name
name
--        _ -> unexpected "function term" $ show term
        Term
t -> Term -> Flow AdapterContext Term
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
t

passLambda :: TypeAdapter
passLambda :: TypeAdapter
passLambda t :: Type
t@(TypeLambda (LambdaType (Name String
v) Type
body)) = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
body
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t (String -> Type -> Type
Types.lambda String
v (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad)
    (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir Term
term -> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term

passLiteral :: TypeAdapter
passLiteral :: TypeAdapter
passLiteral (TypeLiteral LiteralType
at) = do
  SymmetricAdapter AdapterContext LiteralType Literal
ad <- LiteralType
-> Flow
     AdapterContext
     (SymmetricAdapter AdapterContext LiteralType Literal)
forall s.
LiteralType
-> Flow AdapterContext (SymmetricAdapter s LiteralType Literal)
literalAdapter LiteralType
at
  let step :: Coder AdapterContext AdapterContext Term Term
step = (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir Term
term -> do
        Literal
l <- Term -> Flow AdapterContext Literal
forall s. Term -> Flow s Literal
Expect.literal Term
term
        Literal -> Term
literal (Literal -> Term)
-> Flow AdapterContext Literal -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Literal Literal
-> Literal
-> Flow AdapterContext Literal
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext LiteralType Literal
-> Coder AdapterContext AdapterContext Literal Literal
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext LiteralType Literal
ad) Literal
l
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext LiteralType Literal -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext LiteralType Literal
ad) (LiteralType -> Type
Types.literal (LiteralType -> Type) -> LiteralType -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext LiteralType Literal -> LiteralType
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t1
adapterSource SymmetricAdapter AdapterContext LiteralType Literal
ad) (LiteralType -> Type
Types.literal (LiteralType -> Type) -> LiteralType -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext LiteralType Literal -> LiteralType
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext LiteralType Literal
ad) Coder AdapterContext AdapterContext Term Term
step

passList :: TypeAdapter
passList :: TypeAdapter
passList t :: Type
t@(TypeList Type
lt) = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
lt
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t (Type -> Type
Types.list (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad)
    (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermList [Term]
terms) -> [Term] -> Term
list ([Term] -> Term)
-> Flow AdapterContext [Term] -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> Flow AdapterContext Term)
-> [Term] -> Flow AdapterContext [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 (CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (Coder AdapterContext AdapterContext Term Term
 -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) [Term]
terms

passMap :: TypeAdapter
passMap :: TypeAdapter
passMap t :: Type
t@(TypeMap (MapType Type
kt Type
vt)) = do
  SymmetricAdapter AdapterContext Type Term
kad <- TypeAdapter
termAdapter Type
kt
  SymmetricAdapter AdapterContext Type Term
vad <- TypeAdapter
termAdapter Type
vt
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
kad Bool -> Bool -> Bool
|| SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
vad)
    Type
t (Type -> Type -> Type
Types.map (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
kad) (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
vad))
    (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermMap Map Term Term
m) -> Map Term Term -> Term
TermMap (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 AdapterContext [(Term, Term)] -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term, Term) -> Flow AdapterContext (Term, Term))
-> [(Term, Term)] -> Flow AdapterContext [(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 (\(Term
k, Term
v) -> (,) (Term -> Term -> (Term, Term))
-> Flow AdapterContext Term
-> Flow AdapterContext (Term -> (Term, Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
kad) Term
k Flow AdapterContext (Term -> (Term, Term))
-> Flow AdapterContext Term -> Flow AdapterContext (Term, Term)
forall a b.
Flow AdapterContext (a -> b)
-> Flow AdapterContext a -> Flow AdapterContext b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
vad) Term
v)
        (Map Term Term -> [(Term, Term)]
forall k a. Map k a -> [(k, a)]
M.toList Map Term Term
m)

passOptional :: TypeAdapter
passOptional :: TypeAdapter
passOptional t :: Type
t@(TypeOptional Type
ot) = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
ot
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t (Type -> Type
Types.optional (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$
    (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir Term
term -> case Term -> Term
fullyStripTerm Term
term of
      (TermOptional Maybe Term
m) -> Maybe Term -> Term
TermOptional (Maybe Term -> Term)
-> Flow AdapterContext (Maybe Term) -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe Term
m of
        Maybe Term
Nothing -> Maybe Term -> Flow AdapterContext (Maybe Term)
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Term
forall a. Maybe a
Nothing
        Just Term
term' -> Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term)
-> Flow AdapterContext Term -> Flow AdapterContext (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term'
      Term
t -> Term -> Flow AdapterContext Term
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
term
--      t -> fail $ "expected optional term, found: " ++ show t

passProduct :: TypeAdapter
passProduct :: TypeAdapter
passProduct t :: Type
t@(TypeProduct [Type]
types) = do
  [SymmetricAdapter AdapterContext Type Term]
ads <- TypeAdapter
-> [Type]
-> Flow AdapterContext [SymmetricAdapter AdapterContext Type 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 TypeAdapter
termAdapter [Type]
types
  let lossy :: Bool
lossy = (Bool -> SymmetricAdapter AdapterContext Type Term -> Bool)
-> Bool -> [SymmetricAdapter AdapterContext Type Term] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
b SymmetricAdapter AdapterContext Type Term
ad -> Bool
b Bool -> Bool -> Bool
|| SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Bool
False [SymmetricAdapter AdapterContext Type Term]
ads
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy Type
t ([Type] -> Type
Types.product (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget (SymmetricAdapter AdapterContext Type Term -> Type)
-> [SymmetricAdapter AdapterContext Type Term] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SymmetricAdapter AdapterContext Type Term]
ads))
    (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermProduct [Term]
tuple) -> [Term] -> Term
TermProduct ([Term] -> Term)
-> Flow AdapterContext [Term] -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term
 -> SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext Term)
-> [Term]
-> [SymmetricAdapter AdapterContext Type Term]
-> Flow AdapterContext [Term]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
CM.zipWithM (\Term
term SymmetricAdapter AdapterContext Type Term
ad -> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term) [Term]
tuple [SymmetricAdapter AdapterContext Type Term]
ads)

passRecord :: TypeAdapter
passRecord :: TypeAdapter
passRecord t :: Type
t@(TypeRecord RowType
rt) = do
  [SymmetricAdapter AdapterContext FieldType Field]
adapters <- (FieldType
 -> Flow
      AdapterContext (SymmetricAdapter AdapterContext FieldType Field))
-> [FieldType]
-> Flow
     AdapterContext [SymmetricAdapter AdapterContext FieldType 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 FieldType
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
fieldAdapter (RowType -> [FieldType]
rowTypeFields RowType
rt)
  let lossy :: Bool
lossy = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext FieldType Field -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy (SymmetricAdapter AdapterContext FieldType Field -> Bool)
-> [SymmetricAdapter AdapterContext FieldType Field] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SymmetricAdapter AdapterContext FieldType Field]
adapters
  let sfields' :: [FieldType]
sfields' = SymmetricAdapter AdapterContext FieldType Field -> FieldType
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget (SymmetricAdapter AdapterContext FieldType Field -> FieldType)
-> [SymmetricAdapter AdapterContext FieldType Field] -> [FieldType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SymmetricAdapter AdapterContext FieldType Field]
adapters
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy Type
t (RowType -> Type
TypeRecord (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ RowType
rt {rowTypeFields = sfields'}) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional
    ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermRecord (Record Name
_ [Field]
dfields)) -> Name -> [Field] -> Term
record (RowType -> Name
rowTypeTypeName RowType
rt) ([Field] -> Term)
-> Flow AdapterContext [Field] -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SymmetricAdapter AdapterContext FieldType Field
 -> Field -> Flow AdapterContext Field)
-> [SymmetricAdapter AdapterContext FieldType Field]
-> [Field]
-> Flow AdapterContext [Field]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
CM.zipWithM (CoderDirection
-> Coder AdapterContext AdapterContext Field Field
-> Field
-> Flow AdapterContext Field
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (Coder AdapterContext AdapterContext Field Field
 -> Field -> Flow AdapterContext Field)
-> (SymmetricAdapter AdapterContext FieldType Field
    -> Coder AdapterContext AdapterContext Field Field)
-> SymmetricAdapter AdapterContext FieldType Field
-> Field
-> Flow AdapterContext Field
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetricAdapter AdapterContext FieldType Field
-> Coder AdapterContext AdapterContext Field Field
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder) [SymmetricAdapter AdapterContext FieldType Field]
adapters [Field]
dfields

passSet :: TypeAdapter
passSet :: TypeAdapter
passSet t :: Type
t@(TypeSet Type
st) = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
st
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t (Type -> Type
Types.set (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad)
    (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermSet Set Term
terms) -> Set Term -> Term
set (Set Term -> Term) -> ([Term] -> Set Term) -> [Term] -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term] -> Set Term
forall a. Ord a => [a] -> Set a
S.fromList
      ([Term] -> Term)
-> Flow AdapterContext [Term] -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> Flow AdapterContext Term)
-> [Term] -> Flow AdapterContext [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 (CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad)) (Set Term -> [Term]
forall a. Set a -> [a]
S.toList Set Term
terms)

passSum :: TypeAdapter
passSum :: TypeAdapter
passSum t :: Type
t@(TypeSum [Type]
types) = do
  [SymmetricAdapter AdapterContext Type Term]
ads <- TypeAdapter
-> [Type]
-> Flow AdapterContext [SymmetricAdapter AdapterContext Type 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 TypeAdapter
termAdapter [Type]
types
  let lossy :: Bool
lossy = (Bool -> SymmetricAdapter AdapterContext Type Term -> Bool)
-> Bool -> [SymmetricAdapter AdapterContext Type Term] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
b SymmetricAdapter AdapterContext Type Term
ad -> Bool
b Bool -> Bool -> Bool
|| SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Bool
False [SymmetricAdapter AdapterContext Type Term]
ads
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy Type
t ([Type] -> Type
Types.sum (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget (SymmetricAdapter AdapterContext Type Term -> Type)
-> [SymmetricAdapter AdapterContext Type Term] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SymmetricAdapter AdapterContext Type Term]
ads))
    (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermSum (Sum Int
i Int
n Term
term)) -> Sum -> Term
TermSum (Sum -> Term) -> (Term -> Sum) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Term -> Sum
Sum Int
i Int
n (Term -> Term)
-> Flow AdapterContext Term -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder (SymmetricAdapter AdapterContext Type Term
 -> Coder AdapterContext AdapterContext Term Term)
-> SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ [SymmetricAdapter AdapterContext Type Term]
ads [SymmetricAdapter AdapterContext Type Term]
-> Int -> SymmetricAdapter AdapterContext Type Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Term
term

passUnion :: TypeAdapter
passUnion :: TypeAdapter
passUnion t :: Type
t@(TypeUnion RowType
rt) = do
    Map Name (SymmetricAdapter AdapterContext FieldType Field)
adapters <- [(Name, SymmetricAdapter AdapterContext FieldType Field)]
-> Map Name (SymmetricAdapter AdapterContext FieldType Field)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, SymmetricAdapter AdapterContext FieldType Field)]
 -> Map Name (SymmetricAdapter AdapterContext FieldType Field))
-> Flow
     AdapterContext
     [(Name, SymmetricAdapter AdapterContext FieldType Field)]
-> Flow
     AdapterContext
     (Map Name (SymmetricAdapter AdapterContext FieldType Field))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldType
 -> Flow
      AdapterContext
      (Name, SymmetricAdapter AdapterContext FieldType Field))
-> [FieldType]
-> Flow
     AdapterContext
     [(Name, SymmetricAdapter AdapterContext FieldType 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 (\FieldType
f -> (SymmetricAdapter AdapterContext FieldType Field
 -> (Name, SymmetricAdapter AdapterContext FieldType Field))
-> Flow
     AdapterContext
     (SymmetricAdapter AdapterContext FieldType Field
      -> (Name, SymmetricAdapter AdapterContext FieldType Field))
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((,) (FieldType -> Name
fieldTypeName FieldType
f)) Flow
  AdapterContext
  (SymmetricAdapter AdapterContext FieldType Field
   -> (Name, SymmetricAdapter AdapterContext FieldType Field))
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
-> Flow
     AdapterContext
     (Name, SymmetricAdapter AdapterContext FieldType Field)
forall a b.
Flow AdapterContext (a -> b)
-> Flow AdapterContext a -> Flow AdapterContext b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldType
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
fieldAdapter FieldType
f) [FieldType]
sfields
    let lossy :: Bool
lossy = Map Name Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Map Name Bool -> Bool) -> Map Name Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext FieldType Field -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy (SymmetricAdapter AdapterContext FieldType Field -> Bool)
-> Map Name (SymmetricAdapter AdapterContext FieldType Field)
-> Map Name Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (SymmetricAdapter AdapterContext FieldType Field)
adapters
    let sfields' :: [FieldType]
sfields' = SymmetricAdapter AdapterContext FieldType Field -> FieldType
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget (SymmetricAdapter AdapterContext FieldType Field -> FieldType)
-> ((Name, SymmetricAdapter AdapterContext FieldType Field)
    -> SymmetricAdapter AdapterContext FieldType Field)
-> (Name, SymmetricAdapter AdapterContext FieldType Field)
-> FieldType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, SymmetricAdapter AdapterContext FieldType Field)
-> SymmetricAdapter AdapterContext FieldType Field
forall a b. (a, b) -> b
snd ((Name, SymmetricAdapter AdapterContext FieldType Field)
 -> FieldType)
-> [(Name, SymmetricAdapter AdapterContext FieldType Field)]
-> [FieldType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (SymmetricAdapter AdapterContext FieldType Field)
-> [(Name, SymmetricAdapter AdapterContext FieldType Field)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name (SymmetricAdapter AdapterContext FieldType Field)
adapters
    SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy Type
t (RowType -> Type
TypeUnion (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ RowType
rt {rowTypeFields = sfields'})
      (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir Term
term -> do
        Field
dfield <- Term -> Flow AdapterContext Field
forall s. Term -> Flow s Field
Expect.injection Term
term
        SymmetricAdapter AdapterContext FieldType Field
ad <- Map Name (SymmetricAdapter AdapterContext FieldType Field)
-> Field
-> Flow
     AdapterContext (SymmetricAdapter AdapterContext FieldType Field)
forall {m :: * -> *} {a}. MonadFail m => Map Name a -> Field -> m a
getAdapter Map Name (SymmetricAdapter AdapterContext FieldType Field)
adapters Field
dfield
        Injection -> Term
TermUnion (Injection -> Term) -> (Field -> Injection) -> Field -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Field -> Injection
Injection Name
nm (Field -> Term)
-> Flow AdapterContext Field -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Field Field
-> Field
-> Flow AdapterContext Field
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext FieldType Field
-> Coder AdapterContext AdapterContext Field Field
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext FieldType Field
ad) Field
dfield
  where
    getAdapter :: Map Name a -> Field -> m a
getAdapter Map Name a
adapters Field
f = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (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]
++ Name -> String
unName (Field -> Name
fieldName Field
f)) 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
$ Name -> Map Name a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Field -> Name
fieldName Field
f) Map Name a
adapters
    sfields :: [FieldType]
sfields = RowType -> [FieldType]
rowTypeFields RowType
rt
    nm :: Name
nm = RowType -> Name
rowTypeTypeName RowType
rt

passWrapped :: TypeAdapter
passWrapped :: TypeAdapter
passWrapped wt :: Type
wt@(TypeWrap (WrappedType Name
tname Type
t)) = do
  SymmetricAdapter AdapterContext Type Term
adapter <- TypeAdapter
termAdapter Type
t
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
adapter) Type
wt (Name -> Type -> Type
Types.wrapWithName Name
tname (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
adapter)
    (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermWrap (WrappedTerm Name
_ Term
term)) -> WrappedTerm -> Term
TermWrap (WrappedTerm -> Term) -> (Term -> WrappedTerm) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Term -> WrappedTerm
WrappedTerm Name
tname (Term -> Term)
-> Flow AdapterContext Term -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
adapter) Term
term

simplifyApplication :: TypeAdapter
simplifyApplication :: TypeAdapter
simplifyApplication t :: Type
t@(TypeApplication (ApplicationType Type
lhs Type
_)) = do
  SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
lhs
  SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
False Type
t (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional ((CoderDirection -> Term -> Flow AdapterContext Term)
 -> Coder AdapterContext AdapterContext Term Term)
-> (CoderDirection -> Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir Term
term -> CoderDirection
-> Coder AdapterContext AdapterContext Term Term
-> Term
-> Flow AdapterContext Term
forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term

-- Note: those constructors which cannot be mapped meaningfully at this time are simply
--       preserved as strings using Haskell's derived show/read format.
termAdapter :: TypeAdapter
termAdapter :: TypeAdapter
termAdapter Type
typ = case Type
typ of
    TypeAnnotated (AnnotatedType Type
typ2 Map Name Term
ann) -> do
      SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
typ2
      SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return SymmetricAdapter AdapterContext Type Term
ad {adapterTarget = TypeAnnotated $ AnnotatedType (adapterTarget ad) ann}
    Type
_ -> String
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"adapter for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
describeType Type
typ ) (Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ case Type
typ of
      -- Account for let-bound variables
      TypeVariable Name
name -> Name
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forTypeReference Name
name
      Type
_ -> do
          AdapterContext
g <- Flow AdapterContext AdapterContext
forall s. Flow s s
getState
          (Type
 -> [Flow
       AdapterContext (SymmetricAdapter AdapterContext Type Term)])
-> (Type -> Bool) -> (Type -> String) -> TypeAdapter
forall t so si v.
(Eq t, Ord t, Show t) =>
(t -> [Flow so (SymmetricAdapter si t v)])
-> (t -> Bool)
-> (t -> String)
-> t
-> Flow so (SymmetricAdapter si t v)
chooseAdapter (AdapterContext
-> Type
-> [Flow
      AdapterContext (SymmetricAdapter AdapterContext Type Term)]
alts AdapterContext
g) (AdapterContext -> Type -> Bool
supported AdapterContext
g) Type -> String
describeType Type
typ
        where
          alts :: AdapterContext
-> Type
-> [Flow
      AdapterContext (SymmetricAdapter AdapterContext Type Term)]
alts AdapterContext
g Type
t = (\TypeAdapter
c -> TypeAdapter
c Type
t) (TypeAdapter
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> [TypeAdapter]
-> [Flow
      AdapterContext (SymmetricAdapter AdapterContext Type Term)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              if AdapterContext -> Type -> Bool
supportedAtTopLevel AdapterContext
g Type
t
                then Type -> [TypeAdapter]
pass Type
t
                else Type -> [TypeAdapter]
trySubstitution Type
t
            where
              supportedAtTopLevel :: AdapterContext -> Type -> Bool
supportedAtTopLevel AdapterContext
g Type
t = AdapterContext -> Type -> Bool
variantIsSupported AdapterContext
g Type
t Bool -> Bool -> Bool
&& LanguageConstraints -> Type -> Bool
languageConstraintsTypes (AdapterContext -> LanguageConstraints
constraints AdapterContext
g) Type
t
              pass :: Type -> [TypeAdapter]
pass Type
t = case Type -> TypeVariant
typeVariant (Type -> Type
stripType Type
t) of
                TypeVariant
TypeVariantApplication -> [TypeAdapter
passApplication]
                TypeVariant
TypeVariantFunction ->  [TypeAdapter
passFunction]
                TypeVariant
TypeVariantLambda -> [TypeAdapter
passLambda]
                TypeVariant
TypeVariantList -> [TypeAdapter
passList]
                TypeVariant
TypeVariantLiteral -> [TypeAdapter
passLiteral]
                TypeVariant
TypeVariantMap -> [TypeAdapter
passMap]
                TypeVariant
TypeVariantOptional -> [TypeAdapter
passOptional, TypeAdapter
optionalToList]
                TypeVariant
TypeVariantProduct -> [TypeAdapter
passProduct]
                TypeVariant
TypeVariantRecord -> [TypeAdapter
passRecord]
                TypeVariant
TypeVariantSet -> [TypeAdapter
passSet]
                TypeVariant
TypeVariantSum -> [TypeAdapter
passSum]
                TypeVariant
TypeVariantUnion -> [TypeAdapter
passUnion]
                TypeVariant
TypeVariantWrap -> [TypeAdapter
passWrapped]
                TypeVariant
_ -> []
              trySubstitution :: Type -> [TypeAdapter]
trySubstitution Type
t = case Type -> TypeVariant
typeVariant Type
t of
                TypeVariant
TypeVariantApplication -> [TypeAdapter
simplifyApplication]
                TypeVariant
TypeVariantFunction -> [TypeAdapter
functionToUnion]
                TypeVariant
TypeVariantLambda -> [TypeAdapter
lambdaToMonotype]
                TypeVariant
TypeVariantOptional -> [TypeAdapter
optionalToList]
                TypeVariant
TypeVariantSet ->  [TypeAdapter
listToSet]
                TypeVariant
TypeVariantUnion -> [TypeAdapter
unionToRecord]
                TypeVariant
TypeVariantWrap -> [TypeAdapter
wrapToUnwrapped]
                TypeVariant
_ -> [TypeAdapter
unsupportedToString]
    where
      constraints :: AdapterContext -> LanguageConstraints
constraints = Language -> LanguageConstraints
languageConstraints (Language -> LanguageConstraints)
-> (AdapterContext -> Language)
-> AdapterContext
-> LanguageConstraints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdapterContext -> Language
adapterContextLanguage
      supported :: AdapterContext -> Type -> Bool
supported = LanguageConstraints -> Type -> Bool
typeIsSupported (LanguageConstraints -> Type -> Bool)
-> (AdapterContext -> LanguageConstraints)
-> AdapterContext
-> Type
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdapterContext -> LanguageConstraints
constraints
      variantIsSupported :: AdapterContext -> Type -> Bool
variantIsSupported AdapterContext
g Type
t = TypeVariant -> Set TypeVariant -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Type -> TypeVariant
typeVariant Type
t) (Set TypeVariant -> Bool) -> Set TypeVariant -> Bool
forall a b. (a -> b) -> a -> b
$ LanguageConstraints -> Set TypeVariant
languageConstraintsTypeVariants (AdapterContext -> LanguageConstraints
constraints AdapterContext
g)

---- Caution: possibility of an infinite loop if neither unions, optionals, nor lists are supported
unionToRecord :: TypeAdapter
unionToRecord :: TypeAdapter
unionToRecord t :: Type
t@(TypeUnion RowType
rt) = do
    let target :: Type
target = RowType -> Type
TypeRecord (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ RowType
rt {rowTypeFields = makeOptional <$> sfields}
    SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
target
    SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (SymmetricAdapter AdapterContext Type Term -> Bool
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter AdapterContext Type Term
ad) Type
t (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ Coder {
      coderEncode :: Term -> Flow AdapterContext Term
coderEncode = \Term
term' -> do
        (Field Name
fn Term
term) <- Name -> Term -> Flow AdapterContext Field
forall s. Name -> Term -> Flow s Field
Expect.injectionWithName (RowType -> Name
rowTypeTypeName RowType
rt) Term
term'
        Coder AdapterContext AdapterContext Term Term
-> Term -> Flow AdapterContext Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) (Term -> Flow AdapterContext Term)
-> Term -> Flow AdapterContext Term
forall a b. (a -> b) -> a -> b
$ Name -> [Field] -> Term
record Name
nm (Term -> Name -> FieldType -> Field
toRecordField Term
term Name
fn (FieldType -> Field) -> [FieldType] -> [Field]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldType]
sfields),
      coderDecode :: Term -> Flow AdapterContext Term
coderDecode = \Term
term -> do
        TermRecord (Record Name
_ [Field]
fields) <- Coder AdapterContext AdapterContext Term Term
-> Term -> Flow AdapterContext Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode (SymmetricAdapter AdapterContext Type Term
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter AdapterContext Type Term
ad) Term
term
        Name -> Field -> Term
inject Name
nm (Field -> Term)
-> Flow AdapterContext Field -> Flow AdapterContext Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Term -> Type -> [Field] -> Flow AdapterContext Field
forall {m :: * -> *} {a} {a} {p}.
(MonadFail m, Show a, Show a) =>
a -> p -> a -> [Field] -> m Field
fromRecordFields Term
term (Record -> Term
TermRecord (Name -> [Field] -> Record
Record Name
nm [Field]
fields)) (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) [Field]
fields}
  where
    nm :: Name
nm = RowType -> Name
rowTypeTypeName RowType
rt
    sfields :: [FieldType]
sfields = RowType -> [FieldType]
rowTypeFields RowType
rt

    makeOptional :: FieldType -> FieldType
makeOptional (FieldType Name
fn Type
ft) = Name -> Type -> FieldType
FieldType Name
fn (Type -> FieldType) -> Type -> FieldType
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Type -> Type
beneathTypeAnnotations Type -> Type
Types.optional Type
ft

    toRecordField :: Term -> Name -> FieldType -> Field
toRecordField Term
term Name
fn (FieldType Name
fn' Type
_) = Name -> Term -> Field
Field Name
fn' (Term -> Field) -> Term -> Field
forall a b. (a -> b) -> a -> b
$
      Maybe Term -> Term
TermOptional (Maybe Term -> Term) -> Maybe Term -> Term
forall a b. (a -> b) -> a -> b
$ if Name
fn' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fn then Term -> Maybe Term
forall a. a -> Maybe a
Just Term
term else Maybe Term
forall a. Maybe a
Nothing

    fromRecordFields :: a -> p -> a -> [Field] -> m Field
fromRecordFields a
term p
term' a
t' [Field]
fields = if [Field] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Field]
matches
        then String -> m Field
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Field) -> String -> m Field
forall a b. (a -> b) -> a -> b
$ String
"cannot convert term back to union: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
term
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where type = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    and target type = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
t'
        else Field -> m Field
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field -> m Field) -> Field -> m Field
forall a b. (a -> b) -> a -> b
$ [Field] -> Field
forall a. HasCallStack => [a] -> a
L.head [Field]
matches
      where
        matches :: [Field]
matches = (Field -> Maybe Field) -> [Field] -> [Field]
forall a b. (a -> Maybe b) -> [a] -> [b]
Y.mapMaybe (\(Field Name
fn (TermOptional Maybe Term
opt)) -> (Field -> Maybe Field
forall a. a -> Maybe a
Just (Field -> Maybe Field) -> (Term -> Field) -> Term -> Maybe Field
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Term -> Field
Field Name
fn) (Term -> Maybe Field) -> Maybe Term -> Maybe Field
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Term
opt) [Field]
fields

unsupportedToString :: TypeAdapter
unsupportedToString :: TypeAdapter
unsupportedToString Type
t = SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
False Type
t Type
Types.string (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (Term -> Flow AdapterContext Term)
-> (Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder Term -> Flow AdapterContext Term
forall {f :: * -> *} {a}. (Applicative f, Show a) => a -> f Term
encode Term -> Flow AdapterContext Term
forall {b} {s}. Read b => Term -> Flow s b
decode
  where
    -- TODO: use JSON for encoding and decoding unsupported terms, rather than Haskell's read/show
    encode :: a -> f Term
encode a
term = Term -> f Term
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> f Term) -> Term -> f Term
forall a b. (a -> b) -> a -> b
$ String -> Term
string (String -> Term) -> String -> Term
forall a b. (a -> b) -> a -> b
$ String
"unsupported: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
term
    decode :: Term -> Flow s b
decode Term
term = do
      String
s <- Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
term
      case String -> Either String b
forall a. Read a => String -> Either String a
TR.readEither String
s of
        Left String
msg -> String -> Flow s b
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s b) -> String -> Flow s b
forall a b. (a -> b) -> a -> b
$ String
"could not decode unsupported term: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        Right b
t -> b -> Flow s b
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
t

wrapToUnwrapped :: TypeAdapter
wrapToUnwrapped :: TypeAdapter
wrapToUnwrapped t :: Type
t@(TypeWrap (WrappedType Name
tname Type
typ)) = do
    SymmetricAdapter AdapterContext Type Term
ad <- TypeAdapter
termAdapter Type
typ
    SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a. a -> Flow AdapterContext a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter AdapterContext Type Term
 -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term))
-> SymmetricAdapter AdapterContext Type Term
-> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type
-> Type
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
False Type
t (SymmetricAdapter AdapterContext Type Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter AdapterContext Type Term
ad) (Coder AdapterContext AdapterContext Term Term
 -> SymmetricAdapter AdapterContext Type Term)
-> Coder AdapterContext AdapterContext Term Term
-> SymmetricAdapter AdapterContext Type Term
forall a b. (a -> b) -> a -> b
$ (Term -> Flow AdapterContext Term)
-> (Term -> Flow AdapterContext Term)
-> Coder AdapterContext AdapterContext Term Term
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (SymmetricAdapter AdapterContext Type Term
-> Term -> Flow AdapterContext Term
forall {s1} {s2} {t1} {t2} {v2}.
Adapter s1 s2 t1 t2 Term v2 -> Term -> Flow s1 v2
encode SymmetricAdapter AdapterContext Type Term
ad) (SymmetricAdapter AdapterContext Type Term
-> Term -> Flow AdapterContext Term
forall {s1} {s2} {t1} {t2} {v2}.
Adapter s1 s2 t1 t2 Term v2 -> v2 -> Flow s2 Term
decode SymmetricAdapter AdapterContext Type Term
ad)
  where
    encode :: Adapter s s2 t1 t2 Term b -> Term -> Flow s b
encode Adapter s s2 t1 t2 Term b
ad Term
term = Name -> Term -> Flow s Term
forall s. Name -> Term -> Flow s Term
Expect.wrap Name
tname Term
term Flow s Term -> (Term -> Flow s b) -> Flow s b
forall a b. Flow s a -> (a -> Flow s b) -> Flow s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Coder s s2 Term b -> Term -> Flow s b
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (Adapter s s2 t1 t2 Term b -> Coder s s2 Term b
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s s2 t1 t2 Term b
ad)
    decode :: Adapter s1 s2 t1 t2 Term v2 -> v2 -> Flow s2 Term
decode Adapter s1 s2 t1 t2 Term v2
ad v2
term = do
      Term
decoded <- Coder s1 s2 Term v2 -> v2 -> Flow s2 Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode (Adapter s1 s2 t1 t2 Term v2 -> Coder s1 s2 Term v2
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s1 s2 t1 t2 Term v2
ad) v2
term
      Term -> Flow s2 Term
forall a. a -> Flow s2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s2 Term) -> Term -> Flow s2 Term
forall a b. (a -> b) -> a -> b
$ WrappedTerm -> Term
TermWrap (WrappedTerm -> Term) -> WrappedTerm -> Term
forall a b. (a -> b) -> a -> b
$ Name -> Term -> WrappedTerm
WrappedTerm Name
tname Term
decoded

withGraphContext :: Flow (Graph) x -> Flow (AdapterContext) x
withGraphContext :: forall x. Flow Graph x -> Flow AdapterContext x
withGraphContext Flow Graph x
f = do
  AdapterContext
cx <- Flow AdapterContext AdapterContext
forall s. Flow s s
getState
  Graph -> Flow Graph x -> Flow AdapterContext x
forall s1 a s2. s1 -> Flow s1 a -> Flow s2 a
withState (AdapterContext -> Graph
adapterContextGraph AdapterContext
cx) Flow Graph x
f