-- | A utility which instantiates a nonrecursive type with default values.

module Hydra.Tools.Templating where

import Hydra.Kernel

import qualified Data.Map as M
import qualified Data.Set as S


-- | Create a graph schema from a graph which contains nothing but encoded type definitions.
graphToSchema :: Graph -> Flow Graph (M.Map Name Type)
graphToSchema :: Graph -> Flow Graph (Map Name Type)
graphToSchema Graph
g = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> Flow Graph [(Name, Type)] -> Flow Graph (Map Name Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Name, Element) -> Flow Graph (Name, Type))
-> [(Name, Element)] -> Flow Graph [(Name, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, Element) -> Flow Graph (Name, Type)
forall {a}. (a, Element) -> Flow Graph (a, Type)
toPair ([(Name, Element)] -> Flow Graph [(Name, Type)])
-> [(Name, Element)] -> Flow Graph [(Name, Type)]
forall a b. (a -> b) -> a -> b
$ Map Name Element -> [(Name, Element)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Name Element -> [(Name, Element)])
-> Map Name Element -> [(Name, Element)]
forall a b. (a -> b) -> a -> b
$ Graph -> Map Name Element
graphElements Graph
g)
  where
    toPair :: (a, Element) -> Flow Graph (a, Type)
toPair (a
name, Element
el) = do
      Type
t <- Term -> Flow Graph Type
coreDecodeType (Term -> Flow Graph Type) -> Term -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ Element -> Term
elementData Element
el
      (a, Type) -> Flow Graph (a, Type)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
name, Type
t)

-- | Given a graph schema and a nonrecursive type, instantiate it with default values.
--   If the minimal flag is set, the smallest possible term is produced; otherwise,
--   exactly one subterm is produced for constructors which do not otherwise require one, e.g. in lists and optionals.
insantiateTemplate :: Bool -> M.Map Name Type -> Type -> Flow s Term
insantiateTemplate :: forall s. Bool -> Map Name Type -> Type -> Flow s Term
insantiateTemplate Bool
minimal Map Name Type
schema Type
t = case Type
t of
    TypeAnnotated (AnnotatedType Type
t Map String Term
_) -> Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
t
    TypeApplication ApplicationType
_ -> Flow s Term
forall {a}. Flow s a
noPoly
    TypeFunction FunctionType
_ -> Flow s Term
forall {a}. Flow s a
noPoly
    TypeLambda LambdaType
_ -> Flow s Term
forall {a}. Flow s a
noPoly
    TypeList Type
et -> if Bool
minimal
      then Term -> Flow s Term
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Term
TermList []
      else do
        Term
e <- Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
et
        Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Term
TermList [Term
e]
    TypeLiteral LiteralType
lt -> Term -> Flow s Term
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Literal -> Term
TermLiteral (Literal -> Term) -> Literal -> Term
forall a b. (a -> b) -> a -> b
$ case LiteralType
lt of
      LiteralType
LiteralTypeBinary -> String -> Literal
LiteralString String
""
      LiteralType
LiteralTypeBoolean -> Bool -> Literal
LiteralBoolean Bool
False
      LiteralTypeInteger IntegerType
it -> IntegerValue -> Literal
LiteralInteger (IntegerValue -> Literal) -> IntegerValue -> Literal
forall a b. (a -> b) -> a -> b
$ case IntegerType
it of
        IntegerType
IntegerTypeBigint -> Integer -> IntegerValue
IntegerValueBigint Integer
0
        IntegerType
IntegerTypeInt8 -> Int8 -> IntegerValue
IntegerValueInt8 Int8
0
        IntegerType
IntegerTypeInt16 -> Int16 -> IntegerValue
IntegerValueInt16 Int16
0
        IntegerType
IntegerTypeInt32 -> Int -> IntegerValue
IntegerValueInt32 Int
0
        IntegerType
IntegerTypeInt64 -> Int64 -> IntegerValue
IntegerValueInt64 Int64
0
        IntegerType
IntegerTypeUint8 -> Int16 -> IntegerValue
IntegerValueUint8 Int16
0
        IntegerType
IntegerTypeUint16 -> Int -> IntegerValue
IntegerValueUint16 Int
0
        IntegerType
IntegerTypeUint32 -> Int64 -> IntegerValue
IntegerValueUint32 Int64
0
        IntegerType
IntegerTypeUint64 -> Integer -> IntegerValue
IntegerValueUint64 Integer
0
      LiteralTypeFloat FloatType
ft -> FloatValue -> Literal
LiteralFloat (FloatValue -> Literal) -> FloatValue -> Literal
forall a b. (a -> b) -> a -> b
$ case FloatType
ft of
        FloatType
FloatTypeBigfloat -> Double -> FloatValue
FloatValueBigfloat Double
0
        FloatType
FloatTypeFloat32 -> Float -> FloatValue
FloatValueFloat32 Float
0
        FloatType
FloatTypeFloat64 -> Double -> FloatValue
FloatValueFloat64 Double
0
      LiteralType
LiteralTypeString -> String -> Literal
LiteralString String
""
    TypeMap (MapType Type
kt Type
vt) -> if Bool
minimal
      then Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Map Term Term -> Term
TermMap Map Term Term
forall k a. Map k a
M.empty
      else do
        Term
ke <- Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
kt
        Term
ve <- Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
vt
        Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Map Term Term -> Term
TermMap (Map Term Term -> Term) -> Map Term Term -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Term -> Map Term Term
forall k a. k -> a -> Map k a
M.singleton Term
ke Term
ve
    TypeOptional Type
ot -> if Bool
minimal
      then Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Maybe Term -> Term
TermOptional Maybe Term
forall a. Maybe a
Nothing
      else do
        Term
e <- Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
ot
        Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Maybe Term -> Term
TermOptional (Maybe Term -> Term) -> Maybe Term -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Maybe Term
forall a. a -> Maybe a
Just Term
e
    TypeProduct [Type]
types -> do
      [Term]
es <- (Type -> Flow s Term) -> [Type] -> Flow s [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst [Type]
types
      Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Term
TermProduct [Term]
es
    TypeRecord (RowType Name
tname Maybe Name
_ [FieldType]
fields) -> do
      [Field]
dfields <- (FieldType -> Flow s Field) -> [FieldType] -> Flow s [Field]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FieldType -> Flow s Field
forall {s}. FieldType -> Flow s Field
toField [FieldType]
fields
      Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Record -> Term
TermRecord (Record -> Term) -> Record -> Term
forall a b. (a -> b) -> a -> b
$ Name -> [Field] -> Record
Record Name
tname [Field]
dfields
      where
        toField :: FieldType -> Flow s Field
toField FieldType
ft = do
          Term
e <- Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst (Type -> Flow s Term) -> Type -> Flow s Term
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
ft
          Field -> Flow s Field
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Field -> Flow s Field) -> Field -> Flow s Field
forall a b. (a -> b) -> a -> b
$ Name -> Term -> Field
Field (FieldType -> Name
fieldTypeName FieldType
ft) Term
e
    TypeSet Type
et -> if Bool
minimal
        then Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Set Term -> Term
TermSet Set Term
forall a. Set a
S.empty
        else do
          Term
e <- Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
et
          Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Set Term -> Term
TermSet (Set Term -> Term) -> Set Term -> Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Set Term
forall a. Ord a => [a] -> Set a
S.fromList [Term
e]
--     TypeStream et -> ...
--     TypeSum types -> ...
--     TypeUnion (RowType tname _ fields) -> ...
    TypeVariable Name
tname -> case Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
tname Map Name Type
schema of
      Just Type
t' -> Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
t'
      Maybe Type
Nothing -> String -> Flow s Term
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s Term) -> String -> Flow s Term
forall a b. (a -> b) -> a -> b
$ String
"Type variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
tname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found in schema"
    TypeWrap (WrappedType Name
tname Type
t') -> do
      Term
e <- Type -> Flow s Term
forall {s}. Type -> Flow s Term
inst Type
t'
      Term -> Flow s Term
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ WrappedTerm -> Term
TermWrap (WrappedTerm -> Term) -> WrappedTerm -> Term
forall a b. (a -> b) -> a -> b
$ Name -> Term -> WrappedTerm
WrappedTerm Name
tname Term
e
  where
    inst :: Type -> Flow s Term
inst = Bool -> Map Name Type -> Type -> Flow s Term
forall s. Bool -> Map Name Type -> Type -> Flow s Term
insantiateTemplate Bool
minimal Map Name Type
schema
    noPoly :: Flow s a
noPoly = String -> Flow s a
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Polymorphic and function types are not currently supported"


{-

-- Example of type-to-term instantiation which creates a YAML-based template out of the OpenCypher feature model.

import Hydra.Langs.Yaml.Model as Yaml
import Hydra.Flows
import Data.Map as M
import Data.Maybe as Y

ff = fromFlowIo bootstrapGraph

schema <- ff $ graphToSchema $ modulesToGraph [openCypherFeaturesModule]

typ <- ff $ inlineType schema $ Y.fromJust $ M.lookup _CypherFeatures schema
term <- ff $ insantiateTemplate False schema typ

encoder <- ff (coderEncode <$> yamlCoder typ)
yaml <- ff $ encoder term
putStrLn $ hydraYamlToString yaml

-}