module Hydra.Langs.Pegasus.Coder (moduleToPdl) where

import Hydra.Kernel
import Hydra.TermAdapters
import Hydra.Adapters
import Hydra.Langs.Pegasus.Language
import Hydra.Tools.Serialization
import Hydra.Langs.Pegasus.Serde
import qualified Hydra.Langs.Pegasus.Pdl as PDL
import qualified Hydra.Dsl.Types as Types

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


moduleToPdl :: Module -> Flow (Graph) (M.Map FilePath String)
moduleToPdl :: Module -> Flow Graph (Map FilePath FilePath)
moduleToPdl Module
mod = do
    Map FilePath SchemaFile
files <- Module -> Flow Graph (Map FilePath SchemaFile)
moduleToPegasusSchemas Module
mod
    Map FilePath FilePath -> Flow Graph (Map FilePath FilePath)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath FilePath -> Flow Graph (Map FilePath FilePath))
-> Map FilePath FilePath -> Flow Graph (Map FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((FilePath, SchemaFile) -> (FilePath, FilePath)
forall {a}. (a, SchemaFile) -> (a, FilePath)
mapPair ((FilePath, SchemaFile) -> (FilePath, FilePath))
-> [(FilePath, SchemaFile)] -> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map FilePath SchemaFile -> [(FilePath, SchemaFile)]
forall k a. Map k a -> [(k, a)]
M.toList Map FilePath SchemaFile
files)
  where
    mapPair :: (a, SchemaFile) -> (a, FilePath)
mapPair (a
path, SchemaFile
sf) = (a
path, Expr -> FilePath
printExpr (Expr -> FilePath) -> Expr -> FilePath
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
parenthesize (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ SchemaFile -> Expr
exprSchemaFile SchemaFile
sf)

constructModule ::
  M.Map Namespace String
  -> Module
  -> M.Map (Type) (Coder (Graph) (Graph) (Term) ())
  -> [(Element, TypedTerm)]
  -> Flow (Graph) (M.Map FilePath PDL.SchemaFile)
constructModule :: Map Namespace FilePath
-> Module
-> Map Type (Coder Graph Graph Term ())
-> [(Element, TypedTerm)]
-> Flow Graph (Map FilePath SchemaFile)
constructModule Map Namespace FilePath
aliases Module
mod Map Type (Coder Graph Graph Term ())
coders [(Element, TypedTerm)]
pairs = do
    [(Element, TypedTerm)]
sortedPairs <- case ([Element] -> Either [[Name]] [Name]
topologicalSortElements ([Element] -> Either [[Name]] [Name])
-> [Element] -> Either [[Name]] [Name]
forall a b. (a -> b) -> a -> b
$ (Element, TypedTerm) -> Element
forall a b. (a, b) -> a
fst ((Element, TypedTerm) -> Element)
-> [(Element, TypedTerm)] -> [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Element, TypedTerm)]
pairs) of
      Left [[Name]]
comps -> FilePath -> Flow Graph [(Element, TypedTerm)]
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph [(Element, TypedTerm)])
-> FilePath -> Flow Graph [(Element, TypedTerm)]
forall a b. (a -> b) -> a -> b
$ FilePath
"types form a cycle (unsupported in PDL): " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Name] -> FilePath
forall a. Show a => a -> FilePath
show ([[Name]] -> [Name]
forall a. HasCallStack => [a] -> a
L.head [[Name]]
comps)
      Right [Name]
sorted -> [(Element, TypedTerm)] -> Flow Graph [(Element, TypedTerm)]
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Element, TypedTerm)] -> Flow Graph [(Element, TypedTerm)])
-> [(Element, TypedTerm)] -> Flow Graph [(Element, TypedTerm)]
forall a b. (a -> b) -> a -> b
$ [Maybe (Element, TypedTerm)] -> [(Element, TypedTerm)]
forall a. [Maybe a] -> [a]
Y.catMaybes ([Maybe (Element, TypedTerm)] -> [(Element, TypedTerm)])
-> [Maybe (Element, TypedTerm)] -> [(Element, TypedTerm)]
forall a b. (a -> b) -> a -> b
$ (Name -> Maybe (Element, TypedTerm))
-> [Name] -> [Maybe (Element, TypedTerm)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
n -> Name -> Map Name (Element, TypedTerm) -> Maybe (Element, TypedTerm)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name (Element, TypedTerm)
pairByName) [Name]
sorted
    [(NamedSchema, [QualifiedName])]
schemas <- ((Element, TypedTerm) -> Flow Graph (NamedSchema, [QualifiedName]))
-> [(Element, TypedTerm)]
-> Flow Graph [(NamedSchema, [QualifiedName])]
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, TypedTerm) -> Flow Graph (NamedSchema, [QualifiedName])
forall {a}. (Element, TypedTerm) -> Flow Graph (NamedSchema, [a])
toSchema [(Element, TypedTerm)]
sortedPairs
    Map FilePath SchemaFile -> Flow Graph (Map FilePath SchemaFile)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath SchemaFile -> Flow Graph (Map FilePath SchemaFile))
-> Map FilePath SchemaFile -> Flow Graph (Map FilePath SchemaFile)
forall a b. (a -> b) -> a -> b
$ [(FilePath, SchemaFile)] -> Map FilePath SchemaFile
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((NamedSchema, [QualifiedName]) -> (FilePath, SchemaFile)
toPair ((NamedSchema, [QualifiedName]) -> (FilePath, SchemaFile))
-> [(NamedSchema, [QualifiedName])] -> [(FilePath, SchemaFile)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(NamedSchema, [QualifiedName])]
schemas)
  where
    ns :: Namespace
ns = Module -> Namespace
pdlNameForModule Module
mod
    pkg :: Maybe a
pkg = Maybe a
forall a. Maybe a
Nothing
    toPair :: (NamedSchema, [QualifiedName]) -> (FilePath, SchemaFile)
toPair (NamedSchema
schema, [QualifiedName]
imports) = (FilePath
path, Namespace
-> Maybe Package -> [QualifiedName] -> [NamedSchema] -> SchemaFile
PDL.SchemaFile Namespace
ns Maybe Package
forall a. Maybe a
pkg [QualifiedName]
imports [NamedSchema
schema])
      where
        path :: FilePath
path = Bool -> FileExtension -> Namespace -> FilePath
namespaceToFilePath Bool
False (FilePath -> FileExtension
FileExtension FilePath
"pdl") (FilePath -> Namespace
Namespace (FilePath -> Namespace) -> FilePath -> Namespace
forall a b. (a -> b) -> a -> b
$ (Namespace -> FilePath
unNamespace (Namespace -> FilePath) -> Namespace -> FilePath
forall a b. (a -> b) -> a -> b
$ Module -> Namespace
moduleNamespace Module
mod) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
local)
        local :: FilePath
local = Name -> FilePath
PDL.unName (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ QualifiedName -> Name
PDL.qualifiedNameName (QualifiedName -> Name) -> QualifiedName -> Name
forall a b. (a -> b) -> a -> b
$ NamedSchema -> QualifiedName
PDL.namedSchemaQualifiedName NamedSchema
schema

    pairByName :: Map Name (Element, TypedTerm)
pairByName = (Map Name (Element, TypedTerm)
 -> (Element, TypedTerm) -> Map Name (Element, TypedTerm))
-> Map Name (Element, TypedTerm)
-> [(Element, TypedTerm)]
-> Map Name (Element, TypedTerm)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Map Name (Element, TypedTerm)
m (Element, TypedTerm)
p -> Name
-> (Element, TypedTerm)
-> Map Name (Element, TypedTerm)
-> Map Name (Element, TypedTerm)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Element -> Name
elementName (Element -> Name) -> Element -> Name
forall a b. (a -> b) -> a -> b
$ (Element, TypedTerm) -> Element
forall a b. (a, b) -> a
fst (Element, TypedTerm)
p) (Element, TypedTerm)
p Map Name (Element, TypedTerm)
m) Map Name (Element, TypedTerm)
forall k a. Map k a
M.empty [(Element, TypedTerm)]
pairs
    toSchema :: (Element, TypedTerm) -> Flow Graph (NamedSchema, [a])
toSchema (Element
el, TypedTerm Term
term Type
typ) = do
      if Type -> Bool
isType Type
typ
        then Term -> Flow Graph Type
coreDecodeType Term
term Flow Graph Type
-> (Type -> Flow Graph (NamedSchema, [a]))
-> Flow Graph (NamedSchema, [a])
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
>>= Element -> Type -> Flow Graph (NamedSchema, [a])
forall {a}. Element -> Type -> Flow Graph (NamedSchema, [a])
typeToSchema Element
el
        else FilePath -> Flow Graph (NamedSchema, [a])
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph (NamedSchema, [a]))
-> FilePath -> Flow Graph (NamedSchema, [a])
forall a b. (a -> b) -> a -> b
$ FilePath
"mapping of non-type elements to PDL is not yet supported: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
unName (Element -> Name
elementName Element
el)
    typeToSchema :: Element -> Type -> Flow Graph (NamedSchema, [a])
typeToSchema Element
el Type
typ = do
        Either Schema NamedSchema_Type
res <- Map Namespace FilePath
-> Type -> Flow Graph (Either Schema NamedSchema_Type)
encodeAdaptedType Map Namespace FilePath
aliases Type
typ
        let ptype :: NamedSchema_Type
ptype = case Either Schema NamedSchema_Type
res of
              Left Schema
schema -> Schema -> NamedSchema_Type
PDL.NamedSchema_TypeTyperef Schema
schema
              Right NamedSchema_Type
t -> NamedSchema_Type
t
        Maybe FilePath
r <- Term -> Flow Graph (Maybe FilePath)
getTermDescription (Term -> Flow Graph (Maybe FilePath))
-> Term -> Flow Graph (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Element -> Term
elementData Element
el
        let anns :: Annotations
anns = Maybe FilePath -> Annotations
doc Maybe FilePath
r
        (NamedSchema, [a]) -> Flow Graph (NamedSchema, [a])
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedName -> NamedSchema_Type -> Annotations -> NamedSchema
PDL.NamedSchema QualifiedName
qname NamedSchema_Type
ptype Annotations
anns, [a]
forall {a}. [a]
imports)
      where
        qname :: QualifiedName
qname = Map Namespace FilePath -> Bool -> Name -> QualifiedName
pdlNameForElement Map Namespace FilePath
aliases Bool
False (Name -> QualifiedName) -> Name -> QualifiedName
forall a b. (a -> b) -> a -> b
$ Element -> Name
elementName Element
el
        imports :: [a]
imports = []
--        imports = L.filter isExternal (pdlNameForElement aliases True <$> deps)
--          where
--            deps = S.toList $ termDependencyNames False False False $ elementData el
--            isExternal qn = PDL.qualifiedNameNamespace qn /= PDL.qualifiedNameNamespace qname

moduleToPegasusSchemas :: Module -> Flow (Graph) (M.Map FilePath PDL.SchemaFile)
moduleToPegasusSchemas :: Module -> Flow Graph (Map FilePath SchemaFile)
moduleToPegasusSchemas Module
mod = do
  Map Namespace FilePath
aliases <- Module -> Flow Graph (Map Namespace FilePath)
importAliasesForModule Module
mod
  Language
-> (Term -> Flow Graph ())
-> (Module
    -> Map Type (Coder Graph Graph Term ())
    -> [(Element, TypedTerm)]
    -> Flow Graph (Map FilePath SchemaFile))
-> Module
-> Flow Graph (Map FilePath SchemaFile)
forall e d.
Language
-> (Term -> Flow Graph e)
-> (Module
    -> Map Type (Coder Graph Graph Term e)
    -> [(Element, TypedTerm)]
    -> Flow Graph d)
-> Module
-> Flow Graph d
transformModule Language
pdlLanguage (Map Namespace FilePath -> Term -> Flow Graph ()
encodeTerm Map Namespace FilePath
aliases) (Map Namespace FilePath
-> Module
-> Map Type (Coder Graph Graph Term ())
-> [(Element, TypedTerm)]
-> Flow Graph (Map FilePath SchemaFile)
constructModule Map Namespace FilePath
aliases) Module
mod

doc :: Y.Maybe String -> PDL.Annotations
doc :: Maybe FilePath -> Annotations
doc Maybe FilePath
s = Maybe FilePath -> Bool -> Annotations
PDL.Annotations Maybe FilePath
s Bool
False

encodeAdaptedType ::
  M.Map Namespace String -> Type
  -> Flow (Graph) (Either PDL.Schema PDL.NamedSchema_Type)
encodeAdaptedType :: Map Namespace FilePath
-> Type -> Flow Graph (Either Schema NamedSchema_Type)
encodeAdaptedType Map Namespace FilePath
aliases Type
typ = do
  Graph
g <- Flow Graph Graph
forall s. Flow s s
getState
  let cx :: AdapterContext
cx = Graph
-> Language
-> Map
     Name (Adapter AdapterContext AdapterContext Type Type Term Term)
-> AdapterContext
AdapterContext Graph
g Language
pdlLanguage Map
  Name (Adapter AdapterContext AdapterContext Type Type Term Term)
forall k a. Map k a
M.empty
  Adapter AdapterContext AdapterContext Type Type Term Term
ad <- AdapterContext
-> Flow
     AdapterContext
     (Adapter AdapterContext AdapterContext Type Type Term Term)
-> Flow
     Graph (Adapter AdapterContext AdapterContext Type Type Term Term)
forall s1 a s2. s1 -> Flow s1 a -> Flow s2 a
withState AdapterContext
cx (Flow
   AdapterContext
   (Adapter AdapterContext AdapterContext Type Type Term Term)
 -> Flow
      Graph (Adapter AdapterContext AdapterContext Type Type Term Term))
-> Flow
     AdapterContext
     (Adapter AdapterContext AdapterContext Type Type Term Term)
-> Flow
     Graph (Adapter AdapterContext AdapterContext Type Type Term Term)
forall a b. (a -> b) -> a -> b
$ TypeAdapter
termAdapter Type
typ
  Map Namespace FilePath
-> Type -> Flow Graph (Either Schema NamedSchema_Type)
encodeType Map Namespace FilePath
aliases (Type -> Flow Graph (Either Schema NamedSchema_Type))
-> Type -> Flow Graph (Either Schema NamedSchema_Type)
forall a b. (a -> b) -> a -> b
$ Adapter AdapterContext AdapterContext Type Type Term Term -> Type
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget Adapter AdapterContext AdapterContext Type Type Term Term
ad

encodeTerm :: M.Map Namespace String -> Term -> Flow (Graph) ()
encodeTerm :: Map Namespace FilePath -> Term -> Flow Graph ()
encodeTerm Map Namespace FilePath
aliases Term
term = FilePath -> Flow Graph ()
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"not yet implemented"

encodeType :: M.Map Namespace String -> Type -> Flow (Graph) (Either PDL.Schema PDL.NamedSchema_Type)
encodeType :: Map Namespace FilePath
-> Type -> Flow Graph (Either Schema NamedSchema_Type)
encodeType Map Namespace FilePath
aliases Type
typ = case Type
typ of
    TypeAnnotated (AnnotatedType Type
typ' Map FilePath Term
_) -> Map Namespace FilePath
-> Type -> Flow Graph (Either Schema NamedSchema_Type)
encodeType Map Namespace FilePath
aliases Type
typ'
    TypeList Type
lt -> Schema -> Either Schema NamedSchema_Type
forall a b. a -> Either a b
Left (Schema -> Either Schema NamedSchema_Type)
-> (Schema -> Schema) -> Schema -> Either Schema NamedSchema_Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Schema
PDL.SchemaArray (Schema -> Either Schema NamedSchema_Type)
-> Flow Graph Schema -> Flow Graph (Either Schema NamedSchema_Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Flow Graph Schema
encode Type
lt
    TypeLiteral LiteralType
lt -> Schema -> Either Schema NamedSchema_Type
forall a b. a -> Either a b
Left (Schema -> Either Schema NamedSchema_Type)
-> (PrimitiveType -> Schema)
-> PrimitiveType
-> Either Schema NamedSchema_Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimitiveType -> Schema
PDL.SchemaPrimitive (PrimitiveType -> Either Schema NamedSchema_Type)
-> Flow Graph PrimitiveType
-> Flow Graph (Either Schema NamedSchema_Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case LiteralType
lt of
      LiteralType
LiteralTypeBinary -> PrimitiveType -> Flow Graph PrimitiveType
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimitiveType
PDL.PrimitiveTypeBytes
      LiteralType
LiteralTypeBoolean -> PrimitiveType -> Flow Graph PrimitiveType
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimitiveType
PDL.PrimitiveTypeBoolean
      LiteralTypeFloat FloatType
ft -> case FloatType
ft of
        FloatType
FloatTypeFloat32 -> PrimitiveType -> Flow Graph PrimitiveType
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimitiveType
PDL.PrimitiveTypeFloat
        FloatType
FloatTypeFloat64 -> PrimitiveType -> Flow Graph PrimitiveType
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimitiveType
PDL.PrimitiveTypeDouble
        FloatType
_ -> FilePath -> FilePath -> Flow Graph PrimitiveType
forall s x. FilePath -> FilePath -> Flow s x
unexpected FilePath
"float32 or float64" (FilePath -> Flow Graph PrimitiveType)
-> FilePath -> Flow Graph PrimitiveType
forall a b. (a -> b) -> a -> b
$ FloatType -> FilePath
forall a. Show a => a -> FilePath
show FloatType
ft
      LiteralTypeInteger IntegerType
it -> case IntegerType
it of
        IntegerType
IntegerTypeInt32 -> PrimitiveType -> Flow Graph PrimitiveType
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimitiveType
PDL.PrimitiveTypeInt
        IntegerType
IntegerTypeInt64 -> PrimitiveType -> Flow Graph PrimitiveType
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimitiveType
PDL.PrimitiveTypeLong
        IntegerType
_ -> FilePath -> FilePath -> Flow Graph PrimitiveType
forall s x. FilePath -> FilePath -> Flow s x
unexpected FilePath
"int32 or int64" (FilePath -> Flow Graph PrimitiveType)
-> FilePath -> Flow Graph PrimitiveType
forall a b. (a -> b) -> a -> b
$ IntegerType -> FilePath
forall a. Show a => a -> FilePath
show IntegerType
it
      LiteralType
LiteralTypeString -> PrimitiveType -> Flow Graph PrimitiveType
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimitiveType
PDL.PrimitiveTypeString
    TypeMap (MapType Type
kt Type
vt) -> Schema -> Either Schema NamedSchema_Type
forall a b. a -> Either a b
Left (Schema -> Either Schema NamedSchema_Type)
-> (Schema -> Schema) -> Schema -> Either Schema NamedSchema_Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Schema
PDL.SchemaMap (Schema -> Either Schema NamedSchema_Type)
-> Flow Graph Schema -> Flow Graph (Either Schema NamedSchema_Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Flow Graph Schema
encode Type
vt -- note: we simply assume string as a key type
    TypeVariable Name
name -> Either Schema NamedSchema_Type
-> Flow Graph (Either Schema NamedSchema_Type)
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Schema NamedSchema_Type
 -> Flow Graph (Either Schema NamedSchema_Type))
-> Either Schema NamedSchema_Type
-> Flow Graph (Either Schema NamedSchema_Type)
forall a b. (a -> b) -> a -> b
$ Schema -> Either Schema NamedSchema_Type
forall a b. a -> Either a b
Left (Schema -> Either Schema NamedSchema_Type)
-> Schema -> Either Schema NamedSchema_Type
forall a b. (a -> b) -> a -> b
$ QualifiedName -> Schema
PDL.SchemaNamed (QualifiedName -> Schema) -> QualifiedName -> Schema
forall a b. (a -> b) -> a -> b
$ Map Namespace FilePath -> Bool -> Name -> QualifiedName
pdlNameForElement Map Namespace FilePath
aliases Bool
True Name
name
    TypeOptional Type
ot -> FilePath -> Flow Graph (Either Schema NamedSchema_Type)
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph (Either Schema NamedSchema_Type))
-> FilePath -> Flow Graph (Either Schema NamedSchema_Type)
forall a b. (a -> b) -> a -> b
$ FilePath
"optionals unexpected at top level"
    TypeRecord RowType
rt -> do
      let includes :: [a]
includes = []
      [RecordField]
rfields <- (FieldType -> Flow Graph RecordField)
-> [FieldType] -> Flow Graph [RecordField]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM FieldType -> Flow Graph RecordField
encodeRecordField ([FieldType] -> Flow Graph [RecordField])
-> [FieldType] -> Flow Graph [RecordField]
forall a b. (a -> b) -> a -> b
$ RowType -> [FieldType]
rowTypeFields RowType
rt
      Either Schema NamedSchema_Type
-> Flow Graph (Either Schema NamedSchema_Type)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Schema NamedSchema_Type
 -> Flow Graph (Either Schema NamedSchema_Type))
-> Either Schema NamedSchema_Type
-> Flow Graph (Either Schema NamedSchema_Type)
forall a b. (a -> b) -> a -> b
$ NamedSchema_Type -> Either Schema NamedSchema_Type
forall a b. b -> Either a b
Right (NamedSchema_Type -> Either Schema NamedSchema_Type)
-> NamedSchema_Type -> Either Schema NamedSchema_Type
forall a b. (a -> b) -> a -> b
$ RecordSchema -> NamedSchema_Type
PDL.NamedSchema_TypeRecord (RecordSchema -> NamedSchema_Type)
-> RecordSchema -> NamedSchema_Type
forall a b. (a -> b) -> a -> b
$ [RecordField] -> [NamedSchema] -> RecordSchema
PDL.RecordSchema [RecordField]
rfields [NamedSchema]
forall {a}. [a]
includes
    TypeUnion RowType
rt -> if Bool
isEnum
        then do
          [EnumField]
fs <- (FieldType -> Flow Graph EnumField)
-> [FieldType] -> Flow Graph [EnumField]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM FieldType -> Flow Graph EnumField
encodeEnumField ([FieldType] -> Flow Graph [EnumField])
-> [FieldType] -> Flow Graph [EnumField]
forall a b. (a -> b) -> a -> b
$ RowType -> [FieldType]
rowTypeFields RowType
rt
          Either Schema NamedSchema_Type
-> Flow Graph (Either Schema NamedSchema_Type)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Schema NamedSchema_Type
 -> Flow Graph (Either Schema NamedSchema_Type))
-> Either Schema NamedSchema_Type
-> Flow Graph (Either Schema NamedSchema_Type)
forall a b. (a -> b) -> a -> b
$ NamedSchema_Type -> Either Schema NamedSchema_Type
forall a b. b -> Either a b
Right (NamedSchema_Type -> Either Schema NamedSchema_Type)
-> NamedSchema_Type -> Either Schema NamedSchema_Type
forall a b. (a -> b) -> a -> b
$ EnumSchema -> NamedSchema_Type
PDL.NamedSchema_TypeEnum (EnumSchema -> NamedSchema_Type) -> EnumSchema -> NamedSchema_Type
forall a b. (a -> b) -> a -> b
$ [EnumField] -> EnumSchema
PDL.EnumSchema [EnumField]
fs
        else Schema -> Either Schema NamedSchema_Type
forall a b. a -> Either a b
Left (Schema -> Either Schema NamedSchema_Type)
-> ([UnionMember] -> Schema)
-> [UnionMember]
-> Either Schema NamedSchema_Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionSchema -> Schema
PDL.SchemaUnion (UnionSchema -> Schema)
-> ([UnionMember] -> UnionSchema) -> [UnionMember] -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnionMember] -> UnionSchema
PDL.UnionSchema ([UnionMember] -> Either Schema NamedSchema_Type)
-> Flow Graph [UnionMember]
-> Flow Graph (Either Schema NamedSchema_Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldType -> Flow Graph UnionMember)
-> [FieldType] -> Flow Graph [UnionMember]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM FieldType -> Flow Graph UnionMember
encodeUnionField (RowType -> [FieldType]
rowTypeFields RowType
rt)
      where
        isEnum :: Bool
isEnum = (Bool -> Type -> Bool) -> Bool -> [Type] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
b Type
t -> Bool
b Bool -> Bool -> Bool
&& Type -> Type
stripType Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
Types.unit) Bool
True ([Type] -> Bool) -> [Type] -> Bool
forall a b. (a -> b) -> a -> b
$ (FieldType -> Type) -> [FieldType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldType -> Type
fieldTypeType (RowType -> [FieldType]
rowTypeFields RowType
rt)
    Type
_ -> FilePath -> FilePath -> Flow Graph (Either Schema NamedSchema_Type)
forall s x. FilePath -> FilePath -> Flow s x
unexpected FilePath
"PDL-supported type" (FilePath -> Flow Graph (Either Schema NamedSchema_Type))
-> FilePath -> Flow Graph (Either Schema NamedSchema_Type)
forall a b. (a -> b) -> a -> b
$ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
typ
  where
    encode :: Type -> Flow Graph Schema
encode Type
t = case Type -> Type
stripType Type
t of
      TypeRecord (RowType Name
_ Maybe Name
Nothing []) -> Type -> Flow Graph Schema
encode Type
Types.int32 -- special case for the unit type
      Type
_ -> do
        Either Schema NamedSchema_Type
res <- Map Namespace FilePath
-> Type -> Flow Graph (Either Schema NamedSchema_Type)
encodeType Map Namespace FilePath
aliases Type
t
        case Either Schema NamedSchema_Type
res of
          Left Schema
schema -> Schema -> Flow Graph Schema
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
schema
          Right NamedSchema_Type
_ -> FilePath -> Flow Graph Schema
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph Schema) -> FilePath -> Flow Graph Schema
forall a b. (a -> b) -> a -> b
$ FilePath
"type resolved to an unsupported nested named schema: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
t
    encodeRecordField :: FieldType -> Flow Graph RecordField
encodeRecordField (FieldType (Name FilePath
name) Type
typ) = do
      Annotations
anns <- Type -> Flow Graph Annotations
getAnns Type
typ
      (Schema
schema, Bool
optional) <- Type -> Flow Graph (Schema, Bool)
encodePossiblyOptionalType Type
typ
      RecordField -> Flow Graph RecordField
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return PDL.RecordField {
        recordFieldName :: FieldName
PDL.recordFieldName = FilePath -> FieldName
PDL.FieldName FilePath
name,
        recordFieldValue :: Schema
PDL.recordFieldValue = Schema
schema,
        recordFieldOptional :: Bool
PDL.recordFieldOptional = Bool
optional,
        recordFieldDefault :: Maybe Value
PDL.recordFieldDefault = Maybe Value
forall a. Maybe a
Nothing,
        recordFieldAnnotations :: Annotations
PDL.recordFieldAnnotations = Annotations
anns}
    encodeUnionField :: FieldType -> Flow Graph UnionMember
encodeUnionField (FieldType (Name FilePath
name) Type
typ) = do
      Annotations
anns <- Type -> Flow Graph Annotations
getAnns Type
typ
      (Schema
s, Bool
optional) <- Type -> Flow Graph (Schema, Bool)
encodePossiblyOptionalType Type
typ
      let schema :: Schema
schema = if Bool
optional
          then UnionSchema -> Schema
PDL.SchemaUnion (UnionSchema -> Schema) -> UnionSchema -> Schema
forall a b. (a -> b) -> a -> b
$ [UnionMember] -> UnionSchema
PDL.UnionSchema (Schema -> UnionMember
simpleUnionMember (Schema -> UnionMember) -> [Schema] -> [UnionMember]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Schema
PDL.SchemaNull, Schema
s])
          else Schema
s
      UnionMember -> Flow Graph UnionMember
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return PDL.UnionMember {
        unionMemberAlias :: Maybe FieldName
PDL.unionMemberAlias = FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just (FieldName -> Maybe FieldName) -> FieldName -> Maybe FieldName
forall a b. (a -> b) -> a -> b
$ FilePath -> FieldName
PDL.FieldName FilePath
name,
        unionMemberValue :: Schema
PDL.unionMemberValue = Schema
schema,
        unionMemberAnnotations :: Annotations
PDL.unionMemberAnnotations = Annotations
anns}
    encodeEnumField :: FieldType -> Flow Graph EnumField
encodeEnumField (FieldType (Name FilePath
name) Type
typ) = do
      Annotations
anns <- Type -> Flow Graph Annotations
getAnns Type
typ
      EnumField -> Flow Graph EnumField
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return PDL.EnumField {
        enumFieldName :: EnumFieldName
PDL.enumFieldName = FilePath -> EnumFieldName
PDL.EnumFieldName (FilePath -> EnumFieldName) -> FilePath -> EnumFieldName
forall a b. (a -> b) -> a -> b
$ CaseConvention -> CaseConvention -> FilePath -> FilePath
convertCase CaseConvention
CaseConventionCamel CaseConvention
CaseConventionUpperSnake FilePath
name,
        enumFieldAnnotations :: Annotations
PDL.enumFieldAnnotations = Annotations
anns}
    encodePossiblyOptionalType :: Type -> Flow Graph (Schema, Bool)
encodePossiblyOptionalType Type
typ = case Type -> Type
stripType Type
typ of
      TypeOptional Type
ot -> do
        Schema
t <- Type -> Flow Graph Schema
encode Type
ot
        (Schema, Bool) -> Flow Graph (Schema, Bool)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema
t, Bool
True)
      Type
_ -> do
        Schema
t <- Type -> Flow Graph Schema
encode Type
typ
        (Schema, Bool) -> Flow Graph (Schema, Bool)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema
t, Bool
False)
    getAnns :: Type -> Flow Graph Annotations
getAnns Type
typ = do
      Maybe FilePath
r <- Type -> Flow Graph (Maybe FilePath)
getTypeDescription Type
typ
      Annotations -> Flow Graph Annotations
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Annotations -> Flow Graph Annotations)
-> Annotations -> Flow Graph Annotations
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Annotations
doc Maybe FilePath
r

importAliasesForModule :: Module -> Flow Graph (Map Namespace FilePath)
importAliasesForModule Module
mod = do
    Set Namespace
nss <- Bool
-> Bool -> Bool -> Bool -> Module -> Flow Graph (Set Namespace)
moduleDependencyNamespaces Bool
False Bool
True Bool
True Bool
False Module
mod
    Map Namespace FilePath -> Flow Graph (Map Namespace FilePath)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Namespace FilePath -> Flow Graph (Map Namespace FilePath))
-> Map Namespace FilePath -> Flow Graph (Map Namespace FilePath)
forall a b. (a -> b) -> a -> b
$ [(Namespace, FilePath)] -> Map Namespace FilePath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (Namespace -> (Namespace, FilePath)
toPair (Namespace -> (Namespace, FilePath))
-> [Namespace] -> [(Namespace, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Namespace -> [Namespace]
forall a. Set a -> [a]
S.toList Set Namespace
nss)
  where
    toPair :: Namespace -> (Namespace, FilePath)
toPair Namespace
ns = (Namespace
ns, FilePath -> FilePath
slashesToDots (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Namespace -> FilePath
unNamespace Namespace
ns)

noAnnotations :: PDL.Annotations
noAnnotations :: Annotations
noAnnotations = Maybe FilePath -> Bool -> Annotations
PDL.Annotations Maybe FilePath
forall a. Maybe a
Nothing Bool
False

pdlNameForElement :: M.Map Namespace String -> Bool -> Name -> PDL.QualifiedName
pdlNameForElement :: Map Namespace FilePath -> Bool -> Name -> QualifiedName
pdlNameForElement Map Namespace FilePath
aliases Bool
withNs Name
name = Name -> Maybe Namespace -> QualifiedName
PDL.QualifiedName (FilePath -> Name
PDL.Name FilePath
local)
    (Maybe Namespace -> QualifiedName)
-> Maybe Namespace -> QualifiedName
forall a b. (a -> b) -> a -> b
$ if Bool
withNs
      then FilePath -> Namespace
PDL.Namespace (FilePath -> Namespace) -> Maybe FilePath -> Maybe Namespace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
alias
      else Maybe Namespace
forall a. Maybe a
Nothing
  where
    QualifiedName (Just Namespace
ns) FilePath
local = Name -> QualifiedName
qualifyNameEager Name
name
    alias :: Maybe FilePath
alias = Namespace -> Map Namespace FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Namespace
ns Map Namespace FilePath
aliases

pdlNameForModule :: Module -> PDL.Namespace
pdlNameForModule :: Module -> Namespace
pdlNameForModule = FilePath -> Namespace
PDL.Namespace (FilePath -> Namespace)
-> (Module -> FilePath) -> Module -> Namespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
slashesToDots (FilePath -> FilePath)
-> (Module -> FilePath) -> Module -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> FilePath
h (Namespace -> FilePath)
-> (Module -> Namespace) -> Module -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Namespace
moduleNamespace
  where
    h :: Namespace -> FilePath
h (Namespace FilePath
n) = FilePath
n

simpleUnionMember :: PDL.Schema -> PDL.UnionMember
simpleUnionMember :: Schema -> UnionMember
simpleUnionMember Schema
schema = Maybe FieldName -> Schema -> Annotations -> UnionMember
PDL.UnionMember Maybe FieldName
forall a. Maybe a
Nothing Schema
schema Annotations
noAnnotations

slashesToDots :: String -> String
slashesToDots :: FilePath -> FilePath
slashesToDots = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' then Char
'.' else Char
c)