module Hydra.Ext.Pegasus.Coder (printModule) where

import Hydra.All
import Hydra.CoreDecoding
import Hydra.Adapters.Term
import Hydra.Adapters.Coders
import Hydra.Ext.Pegasus.Language
import qualified Hydra.Ext.Pegasus.Pdl as PDL
import qualified Hydra.Impl.Haskell.Dsl.Types as Types
import Hydra.Util.Codetree.Script
import Hydra.Ext.Pegasus.Serde

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


printModule :: (Ord m, Read m, Show m) => Module m -> GraphFlow m (M.Map FilePath String)
printModule :: forall m.
(Ord m, Read m, Show m) =>
Module m -> GraphFlow m (Map FilePath FilePath)
printModule Module m
mod = do
    Map FilePath SchemaFile
files <- forall m.
(Ord m, Read m, Show m) =>
Module m -> GraphFlow m (Map FilePath SchemaFile)
moduleToPegasusSchemas Module m
mod
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall {a}. (a, SchemaFile) -> (a, FilePath)
mapPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a b. (a -> b) -> a -> b
$ Expr -> Expr
parenthesize forall a b. (a -> b) -> a -> b
$ SchemaFile -> Expr
exprSchemaFile SchemaFile
sf)

constructModule :: (Ord m, Read m, Show m)
  => Module m
  -> M.Map (Type m) (Coder (Context m) (Context m) (Term m) ())
  -> [(Element m, TypedTerm m)]
  -> GraphFlow m (M.Map FilePath PDL.SchemaFile)
constructModule :: forall m.
(Ord m, Read m, Show m) =>
Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) ())
-> [(Element m, TypedTerm m)]
-> GraphFlow m (Map FilePath SchemaFile)
constructModule Module m
mod Map (Type m) (Coder (Context m) (Context m) (Term m) ())
coders [(Element m, TypedTerm m)]
pairs = do
    [(Element m, TypedTerm m)]
sortedPairs <- case (forall m. [Element m] -> Maybe [Name]
topologicalSortElements forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Element m, TypedTerm m)]
pairs) of
      Maybe [Name]
Nothing -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"types form a cycle (unsupported in PDL)"
      Just [Name]
sorted -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Y.catMaybes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
n -> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name (Element m, TypedTerm m)
pairByName) [Name]
sorted
    [NamedSchema]
schemas <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM forall {m}.
(Show m, Ord m, Read m) =>
(Element m, TypedTerm m) -> Flow (Context m) NamedSchema
toSchema [(Element m, TypedTerm m)]
sortedPairs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (NamedSchema -> (FilePath, SchemaFile)
toPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedSchema]
schemas)
  where
    ns :: Namespace
ns = forall m. Module m -> Namespace
pdlNameForModule Module m
mod
    pkg :: Maybe a
pkg = forall a. Maybe a
Nothing
    imports :: [a]
imports = [] -- TODO
    toPair :: NamedSchema -> (FilePath, SchemaFile)
toPair NamedSchema
schema = (FilePath
path, Namespace
-> Maybe Package -> [QualifiedName] -> [NamedSchema] -> SchemaFile
PDL.SchemaFile Namespace
ns forall a. Maybe a
pkg forall a. [a]
imports [NamedSchema
schema])
      where
        path :: FilePath
path = Bool -> FileExtension -> Namespace -> FilePath
namespaceToFilePath Bool
False (FilePath -> FileExtension
FileExtension FilePath
"pdl") (FilePath -> Namespace
Namespace forall a b. (a -> b) -> a -> b
$ (Namespace -> FilePath
unNamespace forall a b. (a -> b) -> a -> b
$ forall m. Module m -> Namespace
moduleNamespace Module m
mod) forall a. [a] -> [a] -> [a]
++ FilePath
"/" forall a. [a] -> [a] -> [a]
++ FilePath
local)
        local :: FilePath
local = Name -> FilePath
PDL.unName forall a b. (a -> b) -> a -> b
$ QualifiedName -> Name
PDL.qualifiedNameName forall a b. (a -> b) -> a -> b
$ NamedSchema -> QualifiedName
PDL.namedSchemaQualifiedName NamedSchema
schema
    pairByName :: Map Name (Element m, TypedTerm m)
pairByName = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Map Name (Element m, TypedTerm m)
m (Element m, TypedTerm m)
p -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall m. Element m -> Name
elementName forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (Element m, TypedTerm m)
p) (Element m, TypedTerm m)
p Map Name (Element m, TypedTerm m)
m) forall k a. Map k a
M.empty [(Element m, TypedTerm m)]
pairs
    aliases :: Map k a
aliases = forall {p} {k} {a}. p -> Map k a
importAliasesForModule Module m
mod
    toSchema :: (Element m, TypedTerm m) -> Flow (Context m) NamedSchema
toSchema (Element m
el, TypedTerm Type m
typ Term m
term) = do
      Context m
cx <- forall s. Flow s s
getState
      if forall m. Eq m => Context m -> Type m -> Bool
isType Context m
cx Type m
typ
        then forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType Term m
term forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m}.
(Ord m, Read m, Show m) =>
Element m -> Type m -> Flow (Context m) NamedSchema
typeToSchema Element m
el
        else forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"mapping of non-type elements to PDL is not yet supported: " forall a. [a] -> [a] -> [a]
++ Name -> FilePath
unName (forall m. Element m -> Name
elementName Element m
el)
    typeToSchema :: Element m -> Type m -> Flow (Context m) NamedSchema
typeToSchema Element m
el Type m
typ = do
      let qname :: QualifiedName
qname = Map Namespace FilePath -> Bool -> Name -> QualifiedName
pdlNameForElement forall k a. Map k a
aliases Bool
False forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Name
elementName Element m
el
      Either Schema NamedSchema_Type
res <- forall m.
(Ord m, Read m, Show m) =>
Map Namespace FilePath
-> Type m -> GraphFlow m (Either Schema NamedSchema_Type)
encodeAdaptedType forall k a. Map k a
aliases Type m
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
      Context m
cx <- forall s. Flow s s
getState
      Maybe FilePath
r <- forall m.
AnnotationClass m -> Term m -> Flow (Context m) (Maybe FilePath)
annotationClassTermDescription (forall m. Context m -> AnnotationClass m
contextAnnotations Context m
cx) forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Term m
elementData Element m
el
      let anns :: Annotations
anns = Maybe FilePath -> Annotations
doc Maybe FilePath
r
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ QualifiedName -> NamedSchema_Type -> Annotations -> NamedSchema
PDL.NamedSchema QualifiedName
qname NamedSchema_Type
ptype Annotations
anns

moduleToPegasusSchemas :: (Ord m, Read m, Show m) => Module m -> GraphFlow m (M.Map FilePath PDL.SchemaFile)
moduleToPegasusSchemas :: forall m.
(Ord m, Read m, Show m) =>
Module m -> GraphFlow m (Map FilePath SchemaFile)
moduleToPegasusSchemas Module m
mod = forall m e d.
(Ord m, Read m, Show m) =>
Language m
-> (Term m -> GraphFlow m e)
-> (Module m
    -> Map (Type m) (Coder (Context m) (Context m) (Term m) e)
    -> [(Element m, TypedTerm m)]
    -> GraphFlow m d)
-> Module m
-> GraphFlow m d
transformModule forall m. Language m
pdlLanguage (forall m.
(Eq m, Ord m, Read m, Show m) =>
Map Namespace FilePath -> Term m -> GraphFlow m ()
encodeTerm forall k a. Map k a
aliases) forall m.
(Ord m, Read m, Show m) =>
Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) ())
-> [(Element m, TypedTerm m)]
-> GraphFlow m (Map FilePath SchemaFile)
constructModule Module m
mod
  where
    aliases :: Map k a
aliases = forall {p} {k} {a}. p -> Map k a
importAliasesForModule Module m
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 :: (Ord m, Read m, Show m)
  => M.Map Namespace String -> Type m
  -> GraphFlow m (Either PDL.Schema PDL.NamedSchema_Type)
encodeAdaptedType :: forall m.
(Ord m, Read m, Show m) =>
Map Namespace FilePath
-> Type m -> GraphFlow m (Either Schema NamedSchema_Type)
encodeAdaptedType Map Namespace FilePath
aliases Type m
typ = do
  Context m
cx <- forall s. Flow s s
getState
  let acx :: AdapterContext m
acx = forall m. Context m -> Language m -> Language m -> AdapterContext m
AdapterContext Context m
cx forall m. Language m
hydraCoreLanguage forall m. Language m
pdlLanguage
  SymmetricAdapter (Context m) (Type m) (Term m)
ad <- forall s1 a s2. s1 -> Flow s1 a -> Flow s2 a
withState AdapterContext m
acx forall a b. (a -> b) -> a -> b
$ forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
typ
  forall m.
(Eq m, Show m) =>
Map Namespace FilePath
-> Type m -> GraphFlow m (Either Schema NamedSchema_Type)
encodeType Map Namespace FilePath
aliases forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
ad

encodeTerm :: (Eq m, Ord m, Read m, Show m) => M.Map Namespace String -> Term m -> GraphFlow m ()
encodeTerm :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Map Namespace FilePath -> Term m -> GraphFlow m ()
encodeTerm Map Namespace FilePath
aliases Term m
term = forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"not yet implemented"

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

importAliasesForModule :: p -> Map k a
importAliasesForModule p
g = forall k a. Map k a
M.empty -- TODO

noAnnotations :: PDL.Annotations
noAnnotations :: Annotations
noAnnotations = Maybe FilePath -> Bool -> Annotations
PDL.Annotations 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)
    forall a b. (a -> b) -> a -> b
$ if Bool
withNs
      then FilePath -> Namespace
PDL.Namespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
slashesToDots forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
alias
      else forall a. Maybe a
Nothing
  where
    (Namespace
ns, FilePath
local) = Name -> (Namespace, FilePath)
toQnameEager Name
name
    alias :: Maybe FilePath
alias = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Namespace
ns Map Namespace FilePath
aliases

pdlNameForModule :: Module m -> PDL.Namespace
pdlNameForModule :: forall m. Module m -> Namespace
pdlNameForModule = FilePath -> Namespace
PDL.Namespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
slashesToDots forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> FilePath
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Module m -> 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 forall a. Maybe a
Nothing Schema
schema Annotations
noAnnotations

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