-- | Various functions for dereferencing and decoding schema types

module Hydra.Schemas (
  elementAsTypedTerm,
  fieldTypes,
  isSerializable,
  moduleDependencyNamespaces,
  requireRecordType,
  requireType,
  requireUnionType,
  requireWrappedType,
  resolveType,
  typeDependencies,
  typeDependencyNames,
  ) where

import Hydra.Basics
import Hydra.Strip
import Hydra.Coders
import Hydra.Compute
import Hydra.Core
import Hydra.CoreDecoding
import Hydra.Graph
import Hydra.Mantle
import Hydra.Module
import Hydra.Lexical
import Hydra.Rewriting
import Hydra.Tier1
import Hydra.Tier2
import qualified Hydra.Dsl.Expect as Expect
import qualified Hydra.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
import qualified Data.Maybe as Y


dereferenceType :: Name -> Flow Graph (Maybe Type)
dereferenceType :: Name -> Flow Graph (Maybe Type)
dereferenceType Name
name = do
  Maybe Element
mel <- Name -> Flow Graph (Maybe Element)
dereferenceElement Name
name
  case Maybe Element
mel of
    Maybe Element
Nothing -> Maybe Type -> Flow Graph (Maybe Type)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
    Just Element
el -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Flow Graph Type -> Flow Graph (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Type
coreDecodeType (Element -> Term
elementData Element
el)

elementAsTypedTerm :: Element -> Flow Graph TypedTerm
elementAsTypedTerm :: Element -> Flow Graph TypedTerm
elementAsTypedTerm Element
el = do
  Type
typ <- Term -> Flow Graph Type
requireTermType (Term -> Flow Graph Type) -> Term -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ Element -> Term
elementData Element
el
  TypedTerm -> Flow Graph TypedTerm
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedTerm -> Flow Graph TypedTerm)
-> TypedTerm -> Flow Graph TypedTerm
forall a b. (a -> b) -> a -> b
$ Term -> Type -> TypedTerm
TypedTerm (Element -> Term
elementData Element
el) Type
typ

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

isSerializable :: Element -> Flow Graph Bool
isSerializable :: Element -> Flow Graph Bool
isSerializable Element
el = do
    Map Name Type
deps <- Name -> Flow Graph (Map Name Type)
typeDependencies (Element -> Name
elementName Element
el)
    let allVariants :: Set TypeVariant
allVariants = [TypeVariant] -> Set TypeVariant
forall a. Ord a => [a] -> Set a
S.fromList ([TypeVariant] -> Set TypeVariant)
-> [TypeVariant] -> Set TypeVariant
forall a b. (a -> b) -> a -> b
$ [[TypeVariant]] -> [TypeVariant]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat (Type -> [TypeVariant]
variants (Type -> [TypeVariant]) -> [Type] -> [[TypeVariant]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> [Type]
forall k a. Map k a -> [a]
M.elems Map Name Type
deps)
    Bool -> Flow Graph Bool
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Flow Graph Bool) -> Bool -> Flow Graph Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TypeVariant -> Set TypeVariant -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member TypeVariant
TypeVariantFunction Set TypeVariant
allVariants
  where
    variants :: Type -> [TypeVariant]
variants Type
typ = Type -> TypeVariant
typeVariant (Type -> TypeVariant) -> [Type] -> [TypeVariant]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraversalOrder
-> ([Type] -> Type -> [Type]) -> [Type] -> Type -> [Type]
forall x. TraversalOrder -> (x -> Type -> x) -> x -> Type -> x
foldOverType TraversalOrder
TraversalOrderPre (\[Type]
m Type
t -> Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
m) [] Type
typ

-- | Find dependency namespaces in various dimensions of a term: va
moduleDependencyNamespaces :: Bool -> Bool -> Bool -> Bool -> Module -> Flow Graph (S.Set Namespace)
moduleDependencyNamespaces :: Bool
-> Bool -> Bool -> Bool -> Module -> Flow Graph (Set Namespace)
moduleDependencyNamespaces Bool
withVars Bool
withPrims Bool
withNoms Bool
withSchema Module
mod = do
    Set Name
allNames <- [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Name] -> Set Name)
-> Flow Graph [Set Name] -> Flow Graph (Set Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Element -> Flow Graph (Set Name))
-> [Element] -> Flow Graph [Set Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM Element -> Flow Graph (Set Name)
elNames ([Element] -> Flow Graph [Set Name])
-> [Element] -> Flow Graph [Set Name]
forall a b. (a -> b) -> a -> b
$ Module -> [Element]
moduleElements Module
mod)
    let namespaces :: Set Namespace
namespaces = [Namespace] -> Set Namespace
forall a. Ord a => [a] -> Set a
S.fromList ([Namespace] -> Set Namespace) -> [Namespace] -> Set Namespace
forall a b. (a -> b) -> a -> b
$ [Maybe Namespace] -> [Namespace]
forall a. [Maybe a] -> [a]
Y.catMaybes (Name -> Maybe Namespace
namespaceOfEager (Name -> Maybe Namespace) -> [Name] -> [Maybe Namespace]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> [Name]
forall a. Set a -> [a]
S.toList Set Name
allNames)
    Set Namespace -> Flow Graph (Set Namespace)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Namespace -> Flow Graph (Set Namespace))
-> Set Namespace -> Flow Graph (Set Namespace)
forall a b. (a -> b) -> a -> b
$ Namespace -> Set Namespace -> Set Namespace
forall a. Ord a => a -> Set a -> Set a
S.delete (Module -> Namespace
moduleNamespace Module
mod) Set Namespace
namespaces
  where
    elNames :: Element -> Flow Graph (Set Name)
elNames Element
el = do
      let term :: Term
term = Element -> Term
elementData Element
el
      let dataNames :: Set Name
dataNames = Bool -> Bool -> Bool -> Term -> Set Name
termDependencyNames Bool
withVars Bool
withPrims Bool
withNoms Term
term

      Set Name
schemaNames <- if Bool
withSchema
        then Type -> Set Name
typeDependencyNames (Type -> Set Name) -> Flow Graph Type -> Flow Graph (Set Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Type
requireTermType Term
term
        else Set Name -> Flow Graph (Set Name)
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set Name
forall a. Set a
S.empty

      Set Name
typeNames <- if Term -> Bool
isEncodedType (Term -> Term
fullyStripTerm Term
term)
        then Type -> Set Name
typeDependencyNames (Type -> Set Name) -> Flow Graph Type -> Flow Graph (Set Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Type
coreDecodeType Term
term
        else Set Name -> Flow Graph (Set Name)
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set Name
forall a. Set a
S.empty

      Set Name -> Flow Graph (Set Name)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Name -> Flow Graph (Set Name))
-> Set Name -> Flow Graph (Set Name)
forall a b. (a -> b) -> a -> b
$ [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Name
dataNames, Set Name
schemaNames, Set Name
typeNames]

requireRecordType :: Name -> Flow Graph RowType
requireRecordType :: Name -> Flow Graph RowType
requireRecordType = String -> (Type -> Maybe RowType) -> Name -> Flow Graph RowType
requireRowType String
"record type" ((Type -> Maybe RowType) -> Name -> Flow Graph RowType)
-> (Type -> Maybe RowType) -> Name -> Flow Graph RowType
forall a b. (a -> b) -> a -> b
$ \Type
t -> case Type
t of
  TypeRecord RowType
rt -> RowType -> Maybe RowType
forall a. a -> Maybe a
Just RowType
rt
  Type
_ -> Maybe RowType
forall a. Maybe a
Nothing

requireRowType :: String -> (Type -> Maybe RowType) -> Name -> Flow Graph RowType
requireRowType :: String -> (Type -> Maybe RowType) -> Name -> Flow Graph RowType
requireRowType String
label Type -> Maybe RowType
getter Name
name = do
  Type
t <- Name -> Flow Graph Type
requireType Name
name
  case Type -> Maybe RowType
getter (Type -> Type
rawType Type
t) of
    Just RowType
rt -> RowType -> Flow Graph RowType
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return RowType
rt
    Maybe RowType
Nothing -> String -> Flow Graph RowType
forall a. String -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow Graph RowType) -> String -> Flow Graph RowType
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not resolve to a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
  where
    rawType :: Type -> Type
rawType Type
t = case Type
t of
      TypeAnnotated (AnnotatedType Type
t' Map Name Term
_) -> Type -> Type
rawType Type
t'
      TypeLambda (LambdaType Name
_ Type
body) -> Type -> Type
rawType Type
body -- Note: throwing away quantification here
      Type
_ -> Type
t

requireType :: Name -> Flow Graph Type
requireType :: Name -> Flow Graph Type
requireType Name
name = String -> Flow Graph Type -> Flow Graph Type
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"require type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name) (Flow Graph Type -> Flow Graph Type)
-> Flow Graph Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$
  (Flow Graph Element -> Flow Graph Element
forall x. Flow Graph x -> Flow Graph x
withSchemaContext (Flow Graph Element -> Flow Graph Element)
-> Flow Graph Element -> Flow Graph Element
forall a b. (a -> b) -> a -> b
$ Name -> Flow Graph Element
requireElement Name
name) Flow Graph Element
-> (Element -> Flow Graph Type) -> Flow Graph Type
forall a b. Flow Graph a -> (a -> Flow Graph b) -> Flow Graph b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Term -> Flow Graph Type
coreDecodeType (Term -> Flow Graph Type)
-> (Element -> Term) -> Element -> Flow Graph Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Term
elementData)

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

requireWrappedType :: Name -> Flow Graph Type
requireWrappedType :: Name -> Flow Graph Type
requireWrappedType Name
name = do
  Type
typ <- Name -> Flow Graph Type
requireType Name
name
  case Type -> Type
stripType Type
typ of
    TypeWrap (WrappedType Name
name Type
t) -> Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
    Type
_ -> Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ -- TODO: stop allowing this "slop" once typedefs are clearly separated from newtypes
--     _ -> fail $ "expected wrapped type for " ++ unName name ++ " but got " ++ show typ

resolveType :: Type -> Flow Graph (Maybe Type)
resolveType :: Type -> Flow Graph (Maybe Type)
resolveType Type
typ = case Type -> Type
stripType Type
typ of
    TypeVariable Name
name -> Flow Graph (Maybe Type) -> Flow Graph (Maybe Type)
forall x. Flow Graph x -> Flow Graph x
withSchemaContext (Flow Graph (Maybe Type) -> Flow Graph (Maybe Type))
-> Flow Graph (Maybe Type) -> Flow Graph (Maybe Type)
forall a b. (a -> b) -> a -> b
$ do
      Maybe Term
mterm <- Name -> Flow Graph (Maybe Term)
resolveTerm Name
name
      case Maybe Term
mterm of
        Maybe Term
Nothing -> Maybe Type -> Flow Graph (Maybe Type)
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Type
forall a. Maybe a
Nothing
        Just Term
t -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Flow Graph Type -> Flow Graph (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Type
coreDecodeType Term
t
    Type
_ -> Maybe Type -> Flow Graph (Maybe Type)
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Type -> Flow Graph (Maybe Type))
-> Maybe Type -> Flow Graph (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
typ

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

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