module Hydra.Adapters.Term (
  fieldAdapter,
  functionProxyName,
  functionProxyType,
  termAdapter,
) where

import Hydra.All
import Hydra.CoreDecoding
import Hydra.Reduction
import Hydra.Adapters.Literal
import Hydra.Adapters.UtilsEtc
import Hydra.Impl.Haskell.Dsl.Terms
import qualified Hydra.Impl.Haskell.Dsl.Types as Types

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


type TypeAdapter m = Type m -> Flow (AdapterContext m) (SymmetricAdapter (Context m) (Type m) (Term m))

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

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

dereferenceNominal :: (Ord m, Read m, Show m) => TypeAdapter m
dereferenceNominal :: forall m. (Ord m, Read m, Show m) => TypeAdapter m
dereferenceNominal t :: Type m
t@(TypeNominal Name
name) = do
  Type m
typ <- forall m a. GraphFlow m a -> Flow (AdapterContext m) a
withEvaluationContext forall a b. (a -> b) -> a -> b
$ do
    -- Note: we just assume the schema term is a reference to hydra/core.Type
    forall s a. String -> Flow s a -> Flow s a
withTrace (String
"dereference nominal type " forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name) forall a b. (a -> b) -> a -> b
$ do
      Element m
el <- forall m a. GraphFlow m a -> GraphFlow m a
withSchemaContext forall a b. (a -> b) -> a -> b
$ forall m. Name -> GraphFlow m (Element m)
requireElement Name
name
      forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Term m
elementData Element m
el
  SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
typ
  forall (m :: * -> *) a. Monad m => a -> m a
return SymmetricAdapter (Context m) (Type m) (Term m)
ad { adapterSource :: Type m
adapterSource = Type m
t }

dropAnnotation :: (Ord m, Read m, Show m) => TypeAdapter m
dropAnnotation :: forall m. (Ord m, Read m, Show m) => TypeAdapter m
dropAnnotation t :: Type m
t@(TypeAnnotated (Annotated Type m
t' m
_)) = do
  SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
t'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
False Type m
t (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
ad) forall a b. (a -> b) -> a -> b
$ forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure

elementToString :: TypeAdapter m
elementToString :: forall m. TypeAdapter m
elementToString t :: Type m
t@(TypeElement Type m
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 m
t forall m. Type m
Types.string forall a b. (a -> b) -> a -> b
$ forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder forall {f :: * -> *} {m} {m}. Applicative f => Term m -> f (Term m)
encode forall {f :: * -> *} {m} {m}. Applicative f => Term m -> f (Term m)
decode
  where
    encode :: Term m -> f (Term m)
encode (TermElement (Name String
name)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string String
name
    decode :: Term m -> f (Term m)
decode (TermLiteral (LiteralString String
name)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Name -> Term m
TermElement forall a b. (a -> b) -> a -> b
$ String -> Name
Name String
name

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

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

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

functionToUnion :: (Ord m, Read m, Show m) => TypeAdapter m
functionToUnion :: forall m. (Ord m, Read m, Show m) => TypeAdapter m
functionToUnion t :: Type m
t@(TypeFunction (FunctionType Type m
dom Type m
_)) = do
    Type m
ut <- Flow (AdapterContext m) (Type m)
unionType
    SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
ut
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter (Context m) (Type m) (Term m)
ad) Type m
t (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
ad) forall a b. (a -> b) -> a -> b
$ forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (forall {m} {s1} {s2} {t1} {t2} {v2}.
Show m =>
Adapter s1 s2 t1 t2 (Term m) v2 -> Term m -> Flow s1 v2
encode SymmetricAdapter (Context m) (Type m) (Term m)
ad) (forall {m} {s1} {s2} {t1} {t2} {v2}.
(Show m, Read m, Ord m) =>
Adapter s1 s2 t1 t2 (Term m) v2 -> v2 -> Flow s2 (Term m)
decode SymmetricAdapter (Context m) (Type m) (Term m)
ad)
  where
    encode :: Adapter s1 s2 t1 t2 (Term m) v2 -> Term m -> Flow s1 v2
encode Adapter s1 s2 t1 t2 (Term m) v2
ad Term m
term = forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (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 m) v2
ad) forall a b. (a -> b) -> a -> b
$ case forall m. Term m -> Term m
stripTerm Term m
term of
      TermFunction Function m
f -> case Function m
f of
        FunctionCompareTo Term m
other -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Function_compareTo Term m
other
        FunctionElimination Elimination m
e -> case Elimination m
e of
          Elimination m
EliminationElement -> forall m. Name -> FieldName -> Term m
unitVariant Name
functionProxyName FieldName
_Elimination_element
          EliminationNominal (Name String
name) -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Elimination_nominal forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string String
name
          EliminationOptional OptionalCases m
_ -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Elimination_optional forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Term m
term -- TODO
          EliminationRecord Projection
_ -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Elimination_record forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Term m
term -- TODO
          EliminationUnion CaseStatement m
_ -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Elimination_union forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Term m
term -- TODO
        FunctionLambda Lambda m
_ -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Function_lambda forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Term m
term -- TODO
        FunctionPrimitive (Name String
name) -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Function_primitive forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string String
name
      TermVariable (Variable String
var) -> forall m. Name -> FieldName -> Term m -> Term m
variant Name
functionProxyName FieldName
_Term_variable forall a b. (a -> b) -> a -> b
$ forall m. String -> Term m
string String
var
    decode :: Adapter s1 s2 t1 t2 (Term m) v2 -> v2 -> Flow s2 (Term m)
decode Adapter s1 s2 t1 t2 (Term m) v2
ad v2
term = do
        (Field FieldName
fname Term m
fterm) <- forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode (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 m) v2
ad) v2
term forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall m s. Show m => Term m -> Flow s (Field m)
expectUnion
        forall a. a -> Maybe a -> a
Y.fromMaybe (forall {m :: * -> *} {a}. MonadFail m => FieldName -> m a
notFound FieldName
fname) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FieldName
fname forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
          (FieldName
_Elimination_element, forall {f :: * -> *} {p} {m}. Applicative f => p -> f (Term m)
forTerm Term m
fterm),
          (FieldName
_Elimination_nominal, forall {m} {s} {m}. Show m => Term m -> Flow s (Term m)
forNominal Term m
fterm),
          (FieldName
_Elimination_optional, forall {b} {m} {s}. (Read b, Show m) => Term m -> Flow s b
forOptionalCases Term m
fterm),
          (FieldName
_Elimination_record, forall {b} {m} {s}. (Read b, Show m) => Term m -> Flow s b
forProjection Term m
fterm),
          (FieldName
_Elimination_union, forall {b} {m} {s}. (Read b, Show m) => Term m -> Flow s b
forCases Term m
fterm),
          (FieldName
_Function_compareTo, forall {f :: * -> *} {m}. Applicative f => Term m -> f (Term m)
forCompareTo Term m
fterm),
          (FieldName
_Function_lambda, forall {b} {m} {s}. (Read b, Show m) => Term m -> Flow s b
forLambda Term m
fterm),
          (FieldName
_Function_primitive, forall {m} {s} {m}. Show m => Term m -> Flow s (Term m)
forPrimitive Term m
fterm),
          (FieldName
_Term_variable, forall {m} {s} {m}. Show m => Term m -> Flow s (Term m)
forVariable Term m
fterm)]
      where
        notFound :: FieldName -> m a
notFound FieldName
fname = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected field: " forall a. [a] -> [a] -> [a]
++ FieldName -> String
unFieldName FieldName
fname
        forCases :: Term m -> Flow s b
forCases Term m
fterm = forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m s. Show m => Term m -> Flow s String
expectString Term m
fterm -- TODO
        forCompareTo :: Term m -> f (Term m)
forCompareTo Term m
fterm = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Term m
compareTo Term m
fterm
        forTerm :: p -> f (Term m)
forTerm p
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall m. Term m
delta
        forLambda :: Term m -> Flow s b
forLambda Term m
fterm = forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m s. Show m => Term m -> Flow s String
expectString Term m
fterm -- TODO
        forNominal :: Term m -> Flow s (Term m)
forNominal Term m
fterm = forall m. Name -> Term m
eliminateNominal forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m s. Show m => Term m -> Flow s String
expectString Term m
fterm
        forOptionalCases :: Term m -> Flow s b
forOptionalCases Term m
fterm = forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m s. Show m => Term m -> Flow s String
expectString Term m
fterm -- TODO
        forPrimitive :: Term m -> Flow s (Term m)
forPrimitive Term m
fterm = forall m. Name -> Term m
primitive forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m s. Show m => Term m -> Flow s String
expectString Term m
fterm
        forProjection :: Term m -> Flow s b
forProjection Term m
fterm = forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m s. Show m => Term m -> Flow s String
expectString Term m
fterm -- TODO
        forVariable :: Term m -> Flow s (Term m)
forVariable Term m
fterm = forall m. String -> Term m
variable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m s. Show m => Term m -> Flow s String
expectString Term m
fterm

    unionType :: Flow (AdapterContext m) (Type m)
unionType = do
      SymmetricAdapter (Context m) (Type m) (Term m)
domAd <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
dom
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall m. RowType m -> Type m
TypeUnion forall a b. (a -> b) -> a -> b
$ forall m. Name -> Maybe Name -> [FieldType m] -> RowType m
RowType Name
functionProxyName forall a. Maybe a
Nothing [
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Elimination_element forall m. Type m
Types.unit,
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Elimination_nominal forall m. Type m
Types.string,
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Elimination_optional forall m. Type m
Types.string,
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Elimination_record forall m. Type m
Types.string,
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Elimination_union forall m. Type m
Types.string, -- TODO (TypeRecord cases)
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Function_compareTo (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
domAd),
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Function_lambda forall m. Type m
Types.string, -- TODO (TypeRecord [FieldType _Lambda_parameter Types.string, FieldType _Lambda_body cod]),
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Function_primitive forall m. Type m
Types.string,
        forall m. FieldName -> Type m -> FieldType m
FieldType FieldName
_Term_variable forall m. Type m
Types.string]

lambdaToMonotype :: (Ord m, Read m, Show m) => TypeAdapter m
lambdaToMonotype :: forall m. (Ord m, Read m, Show m) => TypeAdapter m
lambdaToMonotype t :: Type m
t@(TypeLambda (LambdaType VariableType
_ Type m
body)) = do
  SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
body
  forall (m :: * -> *) a. Monad m => a -> m a
return SymmetricAdapter (Context m) (Type m) (Term m)
ad {adapterSource :: Type m
adapterSource = Type m
t}

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

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

passAnnotated :: (Ord m, Read m, Show m) => Type m -> Flow (AdapterContext m) (SymmetricAdapter (Context m) (Type m) v)
passAnnotated :: forall m v.
(Ord m, Read m, Show m) =>
Type m
-> Flow
     (AdapterContext m) (SymmetricAdapter (Context m) (Type m) v)
passAnnotated t :: Type m
t@(TypeAnnotated (Annotated Type m
at m
ann)) = do
  SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
at
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter (Context m) (Type m) (Term m)
ad) Type m
t (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
ad) forall a b. (a -> b) -> a -> b
$ forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir v
term -> forall (f :: * -> *) a. Applicative f => a -> f a
pure v
term

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

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

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

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

passList :: (Ord m, Read m, Show m) => TypeAdapter m
passList :: forall m. (Ord m, Read m, Show m) => TypeAdapter m
passList t :: Type m
t@(TypeList Type m
lt) = do
  SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
lt
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> Bool
adapterIsLossy SymmetricAdapter (Context m) (Type m) (Term m)
ad) Type m
t (forall m. Type m -> Type m
Types.list forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
ad)
    forall a b. (a -> b) -> a -> b
$ forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir (TermList [Term m]
terms) -> forall m. [Term m] -> Term m
list forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (forall s a. CoderDirection -> Coder s s a a -> a -> Flow s a
encodeDecode CoderDirection
dir forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter (Context m) (Type m) (Term m)
ad) [Term m]
terms

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

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

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

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

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

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

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

simplifyApplication :: (Ord m, Read m, Show m) => TypeAdapter m
simplifyApplication :: forall m. (Ord m, Read m, Show m) => TypeAdapter m
simplifyApplication t :: Type m
t@(TypeApplication (ApplicationType Type m
lhs Type m
_)) = do
  SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
lhs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 m
t (forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
ad) forall a b. (a -> b) -> a -> b
$ forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional forall a b. (a -> b) -> a -> b
$ \CoderDirection
dir Term m
term -> forall s a. CoderDirection -> Coder s s a a -> a -> Flow s a
encodeDecode CoderDirection
dir (forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter (Context m) (Type m) (Term m)
ad) Term m
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 :: (Ord m, Read m, Show m) => TypeAdapter m
termAdapter :: forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
typ = do
   AdapterContext m
acx <- forall s. Flow s s
getState
   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 (forall {m} {m}.
(Ord m, Read m, Show m) =>
AdapterContext m
-> Type m
-> [Flow
      (AdapterContext m)
      (SymmetricAdapter (Context m) (Type m) (Term m))]
alts AdapterContext m
acx) (forall {m}. AdapterContext m -> Type m -> Bool
supported AdapterContext m
acx) forall m. Type m -> String
describeType Type m
typ
  where
    alts :: AdapterContext m
-> Type m
-> [Flow
      (AdapterContext m)
      (SymmetricAdapter (Context m) (Type m) (Term m))]
alts AdapterContext m
acx Type m
t = (\Type m
-> Flow
     (AdapterContext m) (SymmetricAdapter (Context m) (Type m) (Term m))
c -> Type m
-> Flow
     (AdapterContext m) (SymmetricAdapter (Context m) (Type m) (Term m))
c Type m
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if forall {m} {m}. AdapterContext m -> Type m -> Bool
variantIsSupported AdapterContext m
acx Type m
t
      then case forall m. Type m -> TypeVariant
typeVariant Type m
t of
        TypeVariant
TypeVariantAnnotated -> [forall m v.
(Ord m, Read m, Show m) =>
Type m
-> Flow
     (AdapterContext m) (SymmetricAdapter (Context m) (Type m) v)
passAnnotated]
        TypeVariant
TypeVariantApplication -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passApplication]
        TypeVariant
TypeVariantFunction ->  [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passFunction]
        TypeVariant
TypeVariantLambda -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passLambda]
        TypeVariant
TypeVariantList -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passList]
        TypeVariant
TypeVariantLiteral -> [forall m. TypeAdapter m
passLiteral]
        TypeVariant
TypeVariantMap -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passMap]
        TypeVariant
TypeVariantOptional -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passOptional, forall m. (Ord m, Read m, Show m) => TypeAdapter m
optionalToList]
        TypeVariant
TypeVariantProduct -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passProduct]
        TypeVariant
TypeVariantRecord -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passRecord]
        TypeVariant
TypeVariantSet -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passSet]
        TypeVariant
TypeVariantSum -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passSum]
        TypeVariant
TypeVariantUnion -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
passUnion]
        TypeVariant
_ -> []
      else case forall m. Type m -> TypeVariant
typeVariant Type m
t of
        TypeVariant
TypeVariantAnnotated -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
dropAnnotation]
        TypeVariant
TypeVariantApplication -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
simplifyApplication]
        TypeVariant
TypeVariantElement -> [forall m. TypeAdapter m
elementToString]
        TypeVariant
TypeVariantFunction -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
functionToUnion]
        TypeVariant
TypeVariantLambda -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
lambdaToMonotype]
        TypeVariant
TypeVariantNominal -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
dereferenceNominal]
        TypeVariant
TypeVariantOptional -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
optionalToList]
        TypeVariant
TypeVariantSet ->  [forall m. (Ord m, Read m, Show m) => TypeAdapter m
listToSet]
        TypeVariant
TypeVariantUnion -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
unionToRecord]
        TypeVariant
_ -> [forall m. (Ord m, Read m, Show m) => TypeAdapter m
unsupportedToString]

    constraints :: AdapterContext m -> LanguageConstraints m
constraints AdapterContext m
acx = forall m. Language m -> LanguageConstraints m
languageConstraints forall a b. (a -> b) -> a -> b
$ forall m. AdapterContext m -> Language m
adapterContextTarget AdapterContext m
acx
    supported :: AdapterContext m -> Type m -> Bool
supported AdapterContext m
acx = forall m. LanguageConstraints m -> Type m -> Bool
typeIsSupported (forall {m}. AdapterContext m -> LanguageConstraints m
constraints AdapterContext m
acx)
    variantIsSupported :: AdapterContext m -> Type m -> Bool
variantIsSupported AdapterContext m
acx Type m
t = forall a. Ord a => a -> Set a -> Bool
S.member (forall m. Type m -> TypeVariant
typeVariant Type m
t) forall a b. (a -> b) -> a -> b
$ forall m. LanguageConstraints m -> Set TypeVariant
languageConstraintsTypeVariants (forall {m}. AdapterContext m -> LanguageConstraints m
constraints AdapterContext m
acx)

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

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

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

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

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

withEvaluationContext :: GraphFlow m a -> Flow (AdapterContext m) a
withEvaluationContext :: forall m a. GraphFlow m a -> Flow (AdapterContext m) a
withEvaluationContext GraphFlow m a
f = do
  AdapterContext m
acx <- forall s. Flow s s
getState
  forall s1 a s2. s1 -> Flow s1 a -> Flow s2 a
withState (forall m. AdapterContext m -> Context m
adapterContextEvaluation AdapterContext m
acx) GraphFlow m a
f