module Hydra.CoreDecoding (
  decodeLiteralType,
  decodeFieldType,
  decodeFieldTypes,
  decodeFloatType,
  decodeFunctionType,
  decodeIntegerType,
  decodeMapType,
  decodeRowType,
  decodeString,
  decodeType,
  decodeLambdaType,
  elementAsTypedTerm,
  fieldTypes,
  requireRecordType,
  requireType,
  requireUnionType,
  typeDependencies,
  typeDependencyNames,
  ) where

import Hydra.Common
import Hydra.Core
import Hydra.Mantle
import Hydra.Module
import Hydra.Lexical
import Hydra.Monads
import Hydra.Rewriting
import qualified Hydra.Impl.Haskell.Dsl.Terms as Terms

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


decodeApplicationType :: Show m => Term m -> GraphFlow m (ApplicationType m)
decodeApplicationType :: forall m. Show m => Term m -> GraphFlow m (ApplicationType m)
decodeApplicationType = forall m b.
Show m =>
(Map FieldName (Term m) -> GraphFlow m b)
-> Term m -> GraphFlow m b
matchRecord forall a b. (a -> b) -> a -> b
$ \Map FieldName (Term m)
m -> forall m. Type m -> Type m -> ApplicationType m
ApplicationType
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_ApplicationType_function forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_ApplicationType_argument forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType

decodeElement :: Show m => Term m -> GraphFlow m Name
decodeElement :: forall m. Show m => Term m -> GraphFlow m Name
decodeElement Term m
term = case forall m. Term m -> Term m
stripTerm Term m
term of
  TermElement Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
name
  Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"element" Term m
term

decodeFieldType :: Show m => Term m -> GraphFlow m (FieldType m)
decodeFieldType :: forall m. Show m => Term m -> GraphFlow m (FieldType m)
decodeFieldType = forall m b.
Show m =>
(Map FieldName (Term m) -> GraphFlow m b)
-> Term m -> GraphFlow m b
matchRecord forall a b. (a -> b) -> a -> b
$ \Map FieldName (Term m)
m -> forall m. FieldName -> Type m -> FieldType m
FieldType
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> FieldName
FieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_FieldType_name forall m. Show m => Term m -> GraphFlow m String
decodeString)
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_FieldType_type forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType

decodeFieldTypes :: Show m => Term m -> GraphFlow m [FieldType m]
decodeFieldTypes :: forall m. Show m => Term m -> GraphFlow m [FieldType m]
decodeFieldTypes Term m
term = case forall m. Term m -> Term m
stripTerm Term m
term of
  TermList [Term m]
els -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM forall m. Show m => Term m -> GraphFlow m (FieldType m)
decodeFieldType [Term m]
els
  Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"list" Term m
term

decodeFloatType :: Show m => Term m -> GraphFlow m FloatType
decodeFloatType :: forall m. Show m => Term m -> GraphFlow m FloatType
decodeFloatType = forall m b. Show m => [(FieldName, b)] -> Term m -> GraphFlow m b
matchEnum [
  (FieldName
_FloatType_bigfloat, FloatType
FloatTypeBigfloat),
  (FieldName
_FloatType_float32, FloatType
FloatTypeFloat32),
  (FieldName
_FloatType_float64, FloatType
FloatTypeFloat64)]

decodeFunctionType :: Show m => Term m -> GraphFlow m (FunctionType m)
decodeFunctionType :: forall m. Show m => Term m -> GraphFlow m (FunctionType m)
decodeFunctionType = forall m b.
Show m =>
(Map FieldName (Term m) -> GraphFlow m b)
-> Term m -> GraphFlow m b
matchRecord forall a b. (a -> b) -> a -> b
$ \Map FieldName (Term m)
m -> forall m. Type m -> Type m -> FunctionType m
FunctionType
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_FunctionType_domain forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_FunctionType_codomain forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType

decodeIntegerType :: Show m => Term m -> GraphFlow m IntegerType
decodeIntegerType :: forall m. Show m => Term m -> GraphFlow m IntegerType
decodeIntegerType = forall m b. Show m => [(FieldName, b)] -> Term m -> GraphFlow m b
matchEnum [
  (FieldName
_IntegerType_bigint, IntegerType
IntegerTypeBigint),
  (FieldName
_IntegerType_int8, IntegerType
IntegerTypeInt8),
  (FieldName
_IntegerType_int16, IntegerType
IntegerTypeInt16),
  (FieldName
_IntegerType_int32, IntegerType
IntegerTypeInt32),
  (FieldName
_IntegerType_int64, IntegerType
IntegerTypeInt64),
  (FieldName
_IntegerType_uint8, IntegerType
IntegerTypeUint8),
  (FieldName
_IntegerType_uint16, IntegerType
IntegerTypeUint16),
  (FieldName
_IntegerType_uint32, IntegerType
IntegerTypeUint32),
  (FieldName
_IntegerType_uint64, IntegerType
IntegerTypeUint64)]

decodeLambdaType :: Show m => Term m -> GraphFlow m (LambdaType m)
decodeLambdaType :: forall m. Show m => Term m -> GraphFlow m (LambdaType m)
decodeLambdaType = forall m b.
Show m =>
(Map FieldName (Term m) -> GraphFlow m b)
-> Term m -> GraphFlow m b
matchRecord forall a b. (a -> b) -> a -> b
$ \Map FieldName (Term m)
m -> forall m. VariableType -> Type m -> LambdaType m
LambdaType
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> VariableType
VariableType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_LambdaType_parameter forall m. Show m => Term m -> GraphFlow m String
decodeString)
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_LambdaType_body forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType

decodeLiteralType :: Show m => Term m -> GraphFlow m LiteralType
decodeLiteralType :: forall m. Show m => Term m -> GraphFlow m LiteralType
decodeLiteralType = forall m b.
Show m =>
[(FieldName, Term m -> GraphFlow m b)] -> Term m -> GraphFlow m b
matchUnion [
  forall b a m. FieldName -> b -> (FieldName, a -> GraphFlow m b)
matchUnitField FieldName
_LiteralType_binary LiteralType
LiteralTypeBinary,
  forall b a m. FieldName -> b -> (FieldName, a -> GraphFlow m b)
matchUnitField FieldName
_LiteralType_boolean LiteralType
LiteralTypeBoolean,
  (FieldName
_LiteralType_float, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FloatType -> LiteralType
LiteralTypeFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m FloatType
decodeFloatType),
  (FieldName
_LiteralType_integer, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IntegerType -> LiteralType
LiteralTypeInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m IntegerType
decodeIntegerType),
  forall b a m. FieldName -> b -> (FieldName, a -> GraphFlow m b)
matchUnitField FieldName
_LiteralType_string LiteralType
LiteralTypeString]

decodeMapType :: Show m => Term m -> GraphFlow m (MapType m)
decodeMapType :: forall m. Show m => Term m -> GraphFlow m (MapType m)
decodeMapType = forall m b.
Show m =>
(Map FieldName (Term m) -> GraphFlow m b)
-> Term m -> GraphFlow m b
matchRecord forall a b. (a -> b) -> a -> b
$ \Map FieldName (Term m)
m -> forall m. Type m -> Type m -> MapType m
MapType
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_MapType_keys forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_MapType_values forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType

decodeRowType :: Show m => Term m -> GraphFlow m (RowType m)
decodeRowType :: forall m. Show m => Term m -> GraphFlow m (RowType m)
decodeRowType = forall m b.
Show m =>
(Map FieldName (Term m) -> GraphFlow m b)
-> Term m -> GraphFlow m b
matchRecord forall a b. (a -> b) -> a -> b
$ \Map FieldName (Term m)
m -> forall m. Name -> Maybe Name -> [FieldType m] -> RowType m
RowType
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Name
Name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_RowType_typeName forall m. Show m => Term m -> GraphFlow m String
decodeString)
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_RowType_extends (forall m s a.
Show m =>
(Term m -> Flow s a) -> Term m -> Flow s (Maybe a)
Terms.expectOptional (\Term m
term -> 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
Terms.expectString Term m
term))
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
_RowType_fields forall m. Show m => Term m -> GraphFlow m [FieldType m]
decodeFieldTypes

decodeString :: Show m => Term m -> GraphFlow m String
decodeString :: forall m. Show m => Term m -> GraphFlow m String
decodeString = forall m s. Show m => Term m -> Flow s String
Terms.expectString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Term m -> Term m
stripTerm

decodeType :: Show m => Term m -> GraphFlow m (Type m)
decodeType :: forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType Term m
dat = case Term m
dat of
  TermElement Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Name -> Type m
TypeNominal Name
name
  TermAnnotated (Annotated Term m
term m
ann) -> (\Type m
t -> forall m. Annotated (Type m) m -> Type m
TypeAnnotated forall a b. (a -> b) -> a -> b
$ forall a m. a -> m -> Annotated a m
Annotated Type m
t m
ann) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType Term m
term
  Term m
_ -> forall m b.
Show m =>
[(FieldName, Term m -> GraphFlow m b)] -> Term m -> GraphFlow m b
matchUnion [
--    (_Type_annotated, fmap TypeAnnotated . decodeAnnotated),
    (FieldName
_Type_application, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. ApplicationType m -> Type m
TypeApplication forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (ApplicationType m)
decodeApplicationType),
    (FieldName
_Type_element, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. Type m -> Type m
TypeElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType),
    (FieldName
_Type_function, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. FunctionType m -> Type m
TypeFunction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (FunctionType m)
decodeFunctionType),
    (FieldName
_Type_lambda, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. LambdaType m -> Type m
TypeLambda forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (LambdaType m)
decodeLambdaType),
    (FieldName
_Type_list, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. Type m -> Type m
TypeList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType),
    (FieldName
_Type_literal, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. LiteralType -> Type m
TypeLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m LiteralType
decodeLiteralType),
    (FieldName
_Type_map, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. MapType m -> Type m
TypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (MapType m)
decodeMapType),
    (FieldName
_Type_nominal, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. Name -> Type m
TypeNominal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m Name
decodeElement),
    (FieldName
_Type_optional, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. Type m -> Type m
TypeOptional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType),
    (FieldName
_Type_product, \(TermList [Term m]
types) -> forall m. [Type m] -> Type m
TypeProduct 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. Show m => Term m -> GraphFlow m (Type m)
decodeType [Term m]
types)),
    (FieldName
_Type_record, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. RowType m -> Type m
TypeRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (RowType m)
decodeRowType),
    (FieldName
_Type_set, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. Type m -> Type m
TypeSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType),
    (FieldName
_Type_sum, \(TermList [Term m]
types) -> forall m. [Type m] -> Type m
TypeSum 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. Show m => Term m -> GraphFlow m (Type m)
decodeType [Term m]
types)),
    (FieldName
_Type_union, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. RowType m -> Type m
TypeUnion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m (RowType m)
decodeRowType),
    (FieldName
_Type_variable, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall m. VariableType -> Type m
TypeVariable forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VariableType
VariableType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Show m => Term m -> GraphFlow m String
decodeString)] Term m
dat

elementAsTypedTerm :: (Show m) => Element m -> GraphFlow m (TypedTerm m)
elementAsTypedTerm :: forall m. Show m => Element m -> GraphFlow m (TypedTerm m)
elementAsTypedTerm Element m
el = forall m. Type m -> Term m -> TypedTerm m
TypedTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType (forall m. Element m -> Term m
elementSchema Element m
el) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall m. Element m -> Term m
elementData Element m
el)

fieldTypes :: Show m => Type m -> GraphFlow m (M.Map FieldName (Type m))
fieldTypes :: forall m. Show m => Type m -> GraphFlow m (Map FieldName (Type m))
fieldTypes Type m
t = case forall m. Type m -> Type m
stripType Type m
t of
    TypeRecord RowType m
rt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {m}. [FieldType m] -> Map FieldName (Type m)
toMap forall a b. (a -> b) -> a -> b
$ forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
    TypeUnion RowType m
rt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {m}. [FieldType m] -> Map FieldName (Type m)
toMap forall a b. (a -> b) -> a -> b
$ forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
    TypeElement Type m
et -> forall m. Show m => Type m -> GraphFlow m (Map FieldName (Type m))
fieldTypes Type m
et
    TypeNominal Name
name -> do
      forall s a. String -> Flow s a -> Flow s a
withTrace (String
"field types of " forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name) forall a b. (a -> b) -> a -> b
$ do
        Element m
el <- forall m. Name -> GraphFlow m (Element m)
requireElement Name
name
        forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType (forall m. Element m -> Term m
elementData Element m
el) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall m. Show m => Type m -> GraphFlow m (Map FieldName (Type m))
fieldTypes
    TypeLambda (LambdaType VariableType
_ Type m
body) -> forall m. Show m => Type m -> GraphFlow m (Map FieldName (Type m))
fieldTypes Type m
body
    Type m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"record or union type" Type m
t
  where
    toMap :: [FieldType m] -> Map FieldName (Type m)
toMap [FieldType m]
fields = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall {m}. FieldType m -> (FieldName, Type m)
toPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldType m]
fields)
    toPair :: FieldType m -> (FieldName, Type m)
toPair (FieldType FieldName
fname Type m
ftype) = (FieldName
fname, Type m
ftype)

getField :: M.Map FieldName (Term m) -> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField :: forall m b.
Map FieldName (Term m)
-> FieldName -> (Term m -> GraphFlow m b) -> GraphFlow m b
getField Map FieldName (Term m)
m FieldName
fname Term m -> GraphFlow m b
decode = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FieldName
fname Map FieldName (Term m)
m of
  Maybe (Term m)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"expected field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FieldName
fname forall a. [a] -> [a] -> [a]
++ String
" not found"
  Just Term m
val -> Term m -> GraphFlow m b
decode Term m
val

matchEnum :: Show m => [(FieldName, b)] -> Term m -> GraphFlow m b
matchEnum :: forall m b. Show m => [(FieldName, b)] -> Term m -> GraphFlow m b
matchEnum = forall m b.
Show m =>
[(FieldName, Term m -> GraphFlow m b)] -> Term m -> GraphFlow m b
matchUnion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b a m. FieldName -> b -> (FieldName, a -> GraphFlow m b)
matchUnitField)

matchRecord :: Show m => (M.Map FieldName (Term m) -> GraphFlow m b) -> Term m -> GraphFlow m b
matchRecord :: forall m b.
Show m =>
(Map FieldName (Term m) -> GraphFlow m b)
-> Term m -> GraphFlow m b
matchRecord Map FieldName (Term m) -> GraphFlow m b
decode Term m
term = do
  Term m
term1 <- forall m. Term m -> GraphFlow m (Term m)
deref Term m
term
  case forall m. Term m -> Term m
stripTerm Term m
term1 of
    TermRecord (Record Name
_ [Field m]
fields) -> Map FieldName (Term m) -> GraphFlow m b
decode forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Field FieldName
fname Term m
val) -> (FieldName
fname, Term m
val)) [Field m]
fields
    Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"record" Term m
term1

matchUnion :: Show m => [(FieldName, Term m -> GraphFlow m b)] -> Term m -> GraphFlow m b
matchUnion :: forall m b.
Show m =>
[(FieldName, Term m -> GraphFlow m b)] -> Term m -> GraphFlow m b
matchUnion [(FieldName, Term m -> GraphFlow m b)]
pairs Term m
term = do
    Term m
term1 <- forall m. Term m -> GraphFlow m (Term m)
deref Term m
term
    case forall m. Term m -> Term m
stripTerm Term m
term1 of
      TermUnion (Union Name
_ (Field FieldName
fname Term m
val)) -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FieldName
fname Map FieldName (Term m -> GraphFlow m b)
mapping of
        Maybe (Term m -> GraphFlow m b)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"no matching case for field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FieldName
fname
        Just Term m -> GraphFlow m b
f -> Term m -> GraphFlow m b
f Term m
val
      Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected (String
"union with one of {" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " (FieldName -> String
unFieldName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FieldName, Term m -> GraphFlow m b)]
pairs) forall a. [a] -> [a] -> [a]
++ String
"}") Term m
term
  where
    mapping :: Map FieldName (Term m -> GraphFlow m b)
mapping = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(FieldName, Term m -> GraphFlow m b)]
pairs

matchUnitField :: FieldName -> b -> (FieldName, a -> GraphFlow m b)
matchUnitField :: forall b a m. FieldName -> b -> (FieldName, a -> GraphFlow m b)
matchUnitField FieldName
fname b
x = (FieldName
fname, \a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x)

requireRecordType :: Show m => Bool -> Name -> GraphFlow m (RowType m)
requireRecordType :: forall m. Show m => Bool -> Name -> GraphFlow m (RowType m)
requireRecordType Bool
infer = forall m.
Show m =>
String
-> Bool
-> (Type m -> Maybe (RowType m))
-> Name
-> GraphFlow m (RowType m)
requireRowType String
"record" Bool
infer forall a b. (a -> b) -> a -> b
$ \Type m
t -> case Type m
t of
  TypeRecord RowType m
rt -> forall a. a -> Maybe a
Just RowType m
rt
  Type m
_ -> forall a. Maybe a
Nothing

requireRowType :: Show m => String -> Bool -> (Type m -> Maybe (RowType m)) -> Name -> GraphFlow m (RowType m)
requireRowType :: forall m.
Show m =>
String
-> Bool
-> (Type m -> Maybe (RowType m))
-> Name
-> GraphFlow m (RowType m)
requireRowType String
label Bool
infer Type m -> Maybe (RowType m)
getter Name
name = do
  Type m
t <- forall m a. GraphFlow m a -> GraphFlow m a
withSchemaContext forall a b. (a -> b) -> a -> b
$ forall m. Show m => Name -> GraphFlow m (Type m)
requireType Name
name
  case Type m -> Maybe (RowType m)
getter (forall m. Type m -> Type m
rawType Type m
t) of
    Just RowType m
rt -> if Bool
infer
      then case forall m. RowType m -> Maybe Name
rowTypeExtends RowType m
rt of
        Maybe Name
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return RowType m
rt
        Just Name
name' -> do
          RowType m
rt' <- forall m.
Show m =>
String
-> Bool
-> (Type m -> Maybe (RowType m))
-> Name
-> GraphFlow m (RowType m)
requireRowType String
label Bool
True Type m -> Maybe (RowType m)
getter Name
name'
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall m. Name -> Maybe Name -> [FieldType m] -> RowType m
RowType Name
name forall a. Maybe a
Nothing (forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt' forall a. [a] -> [a] -> [a]
++ forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt)
      else forall (m :: * -> *) a. Monad m => a -> m a
return RowType m
rt
    Maybe (RowType m)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
name forall a. [a] -> [a] -> [a]
++ String
" does not resolve to a " forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
" type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type m
t
  where
    rawType :: Type m -> Type m
rawType Type m
t = case Type m
t of
      TypeAnnotated (Annotated Type m
t' m
_) -> Type m -> Type m
rawType Type m
t'
      TypeLambda (LambdaType VariableType
_ Type m
body) -> Type m -> Type m
rawType Type m
body -- Note: throwing away quantification here
      Type m
_ -> Type m
t

requireType :: Show m => Name -> GraphFlow m (Type m)
requireType :: forall m. Show m => Name -> GraphFlow m (Type m)
requireType Name
name = forall s a. String -> Flow s a -> Flow s a
withTrace String
"require type" forall a b. (a -> b) -> a -> b
$ do
  Element m
el <- 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

requireUnionType :: Show m => Bool -> Name -> GraphFlow m (RowType m)
requireUnionType :: forall m. Show m => Bool -> Name -> GraphFlow m (RowType m)
requireUnionType Bool
infer = forall m.
Show m =>
String
-> Bool
-> (Type m -> Maybe (RowType m))
-> Name
-> GraphFlow m (RowType m)
requireRowType String
"union" Bool
infer forall a b. (a -> b) -> a -> b
$ \Type m
t -> case Type m
t of
  TypeUnion RowType m
rt -> forall a. a -> Maybe a
Just RowType m
rt
  Type m
_ -> forall a. Maybe a
Nothing

typeDependencies :: Show m => Name -> GraphFlow m (M.Map Name (Type m))
typeDependencies :: forall m. Show m => Name -> GraphFlow m (Map Name (Type m))
typeDependencies Name
name = forall {m}.
Show m =>
Set Name
-> Map Name (Type m) -> Flow (Context m) (Map Name (Type m))
deps (forall a. Ord a => [a] -> Set a
S.fromList [Name
name]) forall k a. Map k a
M.empty
  where
    deps :: Set Name
-> Map Name (Type m) -> Flow (Context m) (Map Name (Type m))
deps Set Name
seeds Map Name (Type m)
names = if forall a. Set a -> Bool
S.null Set Name
seeds
        then forall (m :: * -> *) a. Monad m => a -> m a
return Map Name (Type m)
names
        else do
          [(Name, Type m)]
pairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM forall {m}. Show m => Name -> Flow (Context m) (Name, Type m)
toPair forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Name
seeds
          let newNames :: Map Name (Type m)
newNames = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Name (Type m)
names (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, Type m)]
pairs)
          let refs :: Set Name
refs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl forall a. Ord a => Set a -> Set a -> Set a
S.union forall a. Set a
S.empty (forall m. Type m -> Set Name
typeDependencyNames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Type m)]
pairs))
          let visited :: Set Name
visited = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map Name (Type m)
names
          let newSeeds :: Set Name
newSeeds = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set Name
refs Set Name
visited
          Set Name
-> Map Name (Type m) -> Flow (Context m) (Map Name (Type m))
deps Set Name
newSeeds Map Name (Type m)
newNames
      where
        toPair :: Name -> Flow (Context m) (Name, Type m)
toPair Name
name = do
          Type m
typ <- forall m. Show m => Name -> GraphFlow m (Type m)
requireType Name
name
          forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Type m
typ)

    requireType :: Name -> Flow (Context m) (Type m)
requireType Name
name = do
      forall s a. String -> Flow s a -> Flow s a
withTrace (String
"type dependencies of " forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name) forall a b. (a -> b) -> a -> b
$ do
        Element m
el <- forall m. Name -> GraphFlow m (Element m)
requireElement Name
name
        forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType (forall m. Element m -> Term m
elementData Element m
el)

typeDependencyNames :: Type m -> S.Set Name
typeDependencyNames :: forall m. Type m -> Set Name
typeDependencyNames = forall a m.
TraversalOrder -> (a -> Type m -> a) -> a -> Type m -> a
foldOverType TraversalOrder
TraversalOrderPre forall {m}. Set Name -> Type m -> Set Name
addNames forall a. Set a
S.empty
  where
    addNames :: Set Name -> Type m -> Set Name
addNames Set Name
names Type m
typ = case Type m
typ of
      TypeNominal Name
name -> forall a. Ord a => a -> Set a -> Set a
S.insert Name
name Set Name
names
      Type m
_ -> Set Name
names