Coder.hs

-- Note: this is an automatically generated file. Do not edit.
-- | Pegasus PDL code generator: converts Hydra modules to PDL schema files

module Hydra.Pegasus.Coder where
import qualified Hydra.Analysis as Analysis
import qualified Hydra.Annotations as Annotations
import qualified Hydra.Ast as Ast
import qualified Hydra.Coders as Coders
import qualified Hydra.Core as Core
import qualified Hydra.File as File
import qualified Hydra.Dependencies as Dependencies
import qualified Hydra.Environment as Environment
import qualified Hydra.Error.Checking as Checking
import qualified Hydra.Error.Core as ErrorCore
import qualified Hydra.Error.Packaging as ErrorPackaging
import qualified Hydra.Errors as Errors
import qualified Hydra.Formatting as Formatting
import qualified Hydra.Graph as Graph
import qualified Hydra.Json.Model as Model
import qualified Hydra.Overlay.Haskell.Lib.Eithers as Eithers
import qualified Hydra.Overlay.Haskell.Lib.Equality as Equality
import qualified Hydra.Overlay.Haskell.Lib.Lists as Lists
import qualified Hydra.Overlay.Haskell.Lib.Logic as Logic
import qualified Hydra.Overlay.Haskell.Lib.Maps as Maps
import qualified Hydra.Overlay.Haskell.Lib.Optionals as Optionals
import qualified Hydra.Overlay.Haskell.Lib.Pairs as Pairs
import qualified Hydra.Overlay.Haskell.Lib.Sets as Sets
import qualified Hydra.Overlay.Haskell.Lib.Strings as Strings
import qualified Hydra.Names as Names
import qualified Hydra.Packaging as Packaging
import qualified Hydra.Parsing as Parsing
import qualified Hydra.Paths as Paths
import qualified Hydra.Pegasus.Language as Language
import qualified Hydra.Pegasus.Pdl as Pdl
import qualified Hydra.Pegasus.Serde as Serde
import qualified Hydra.Query as Query
import qualified Hydra.Relational as Relational
import qualified Hydra.Serialization as Serialization
import qualified Hydra.Show.Core as ShowCore
import qualified Hydra.Sorting as Sorting
import qualified Hydra.Strip as Strip
import qualified Hydra.Tabular as Tabular
import qualified Hydra.Testing as Testing
import qualified Hydra.Topology as Topology
import qualified Hydra.Typed as Typed
import qualified Hydra.Typing as Typing
import qualified Hydra.Util as Util
import qualified Hydra.Validation as Validation
import qualified Hydra.Variants as Variants
import Prelude hiding  (Enum, Ordering, decodeFloat, encodeFloat, fail, map, pure, sum)
import qualified Data.Scientific as Sci
import qualified Data.Map as M
-- | Construct PDL schema files from type definitions, with topological sorting and cycle detection
constructModule :: t0 -> Graph.Graph -> M.Map Packaging.ModuleName String -> Packaging.Module -> [Packaging.TypeDefinition] -> Either Errors.Error (M.Map String Pdl.SchemaFile)
constructModule cx g aliases mod typeDefs =

      let groups = Dependencies.topologicalSortTypeDefinitions typeDefs
      in (Optionals.cases (Lists.find (\grp -> Equality.gt (Lists.length grp) 1) groups) (
        let sortedDefs = Lists.concat groups
        in (Eithers.bind (Eithers.mapList (\typeDef -> typeToSchema cx g aliases mod typeDef) sortedDefs) (\schemas -> Right (Maps.fromList (Lists.map (toPair mod aliases) schemas))))) (\cycle -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "types form a cycle (unsupported in PDL): [" (Strings.cat2 (Strings.intercalate ", " (Lists.map (\td -> Core.unName (Packaging.typeDefinitionName td)) cycle)) "]"))))))
-- | Create PDL annotations from an optional doc string
doc :: Maybe String -> Pdl.Annotations
doc s =
    Pdl.Annotations {
      Pdl.annotationsDoc = s,
      Pdl.annotationsDeprecated = False}
encode :: t0 -> Graph.Graph -> M.Map Packaging.ModuleName String -> Core.Type -> Either Errors.Error Pdl.Schema
encode cx g aliases t =
    case (Strip.deannotateType t) of
      Core.TypeRecord v0 -> Logic.ifElse (Lists.null v0) (encode cx g aliases (Core.TypeLiteral (Core.LiteralTypeInteger Core.IntegerTypeInt32))) (Eithers.bind (encodeType cx g aliases t) (\res -> Eithers.either (\schema -> Right schema) (\_ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "type resolved to an unsupported nested named schema: " (ShowCore.type_ t))))) res))
      _ -> Eithers.bind (encodeType cx g aliases t) (\res -> Eithers.either (\schema -> Right schema) (\_ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "type resolved to an unsupported nested named schema: " (ShowCore.type_ t))))) res)
encodeEnumField :: t0 -> Graph.Graph -> Core.FieldType -> Either Errors.Error Pdl.EnumField
encodeEnumField cx g ft =

      let name = Core.fieldTypeName ft
          typ = Core.fieldTypeType ft
      in (Eithers.bind (getAnns cx g typ) (\anns -> Right (Pdl.EnumField {
        Pdl.enumFieldName = (Pdl.EnumFieldName (Formatting.convertCase Util.CaseConventionCamel Util.CaseConventionUpperSnake (Core.unName name))),
        Pdl.enumFieldAnnotations = anns})))
encodePossiblyOptionalType :: t0 -> Graph.Graph -> M.Map Packaging.ModuleName String -> Core.Type -> Either Errors.Error (Pdl.Schema, Bool)
encodePossiblyOptionalType cx g aliases typ =
    case (Strip.deannotateType typ) of
      Core.TypeOptional v0 -> Eithers.bind (encode cx g aliases v0) (\t -> Right (t, True))
      Core.TypeRecord _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeUnion _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeLiteral _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeList _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeMap _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeSet _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeVariable _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeWrap _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeEither _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypePair _ -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeVoid -> Eithers.bind (encode cx g aliases typ) (\t -> Right (t, False))
      Core.TypeAnnotated v0 -> encodePossiblyOptionalType cx g aliases (Core.annotatedTypeBody v0)
encodeRecordField :: t0 -> Graph.Graph -> M.Map Packaging.ModuleName String -> Core.FieldType -> Either Errors.Error Pdl.RecordField
encodeRecordField cx g aliases ft =

      let name = Core.fieldTypeName ft
          typ = Core.fieldTypeType ft
      in (Eithers.bind (getAnns cx g typ) (\anns -> Eithers.bind (encodePossiblyOptionalType cx g aliases typ) (\optResult ->
        let schema = Pairs.first optResult
            optional = Pairs.second optResult
        in (Right (Pdl.RecordField {
          Pdl.recordFieldName = (Pdl.FieldName (Core.unName name)),
          Pdl.recordFieldValue = schema,
          Pdl.recordFieldOptional = optional,
          Pdl.recordFieldDefault = Nothing,
          Pdl.recordFieldAnnotations = anns})))))
-- | Encode a Hydra type as either a PDL Schema (Left) or a PDL NamedSchemaType (Right)
encodeType :: t0 -> Graph.Graph -> M.Map Packaging.ModuleName String -> Core.Type -> Either Errors.Error (Either Pdl.Schema Pdl.NamedSchemaType)
encodeType cx g aliases typ =
    case typ of
      Core.TypeAnnotated v0 -> encodeType cx g aliases (Core.annotatedTypeBody v0)
      Core.TypeEither v0 -> Eithers.bind (encode cx g aliases (Core.eitherTypeLeft v0)) (\leftSchema -> Eithers.bind (encode cx g aliases (Core.eitherTypeRight v0)) (\rightSchema ->
        let leftMember =
                Pdl.UnionMember {
                  Pdl.unionMemberAlias = (Just (Pdl.FieldName "left")),
                  Pdl.unionMemberValue = leftSchema,
                  Pdl.unionMemberAnnotations = noAnnotations}
            rightMember =
                    Pdl.UnionMember {
                      Pdl.unionMemberAlias = (Just (Pdl.FieldName "right")),
                      Pdl.unionMemberValue = rightSchema,
                      Pdl.unionMemberAnnotations = noAnnotations}
        in (Right (Left (Pdl.SchemaUnion (Pdl.UnionSchema [
          leftMember,
          rightMember]))))))
      Core.TypeList v0 -> Eithers.bind (encode cx g aliases v0) (\inner -> Right (Left (Pdl.SchemaArray inner)))
      Core.TypeLiteral v0 -> case v0 of
        Core.LiteralTypeBinary -> Right (Left (Pdl.SchemaPrimitive Pdl.PrimitiveTypeBytes))
        Core.LiteralTypeBoolean -> Right (Left (Pdl.SchemaPrimitive Pdl.PrimitiveTypeBoolean))
        Core.LiteralTypeFloat v1 -> case v1 of
          Core.FloatTypeFloat32 -> Right (Left (Pdl.SchemaPrimitive Pdl.PrimitiveTypeFloat))
          Core.FloatTypeFloat64 -> Right (Left (Pdl.SchemaPrimitive Pdl.PrimitiveTypeDouble))
          _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "Expected " (Strings.cat2 "float32 or float64" (Strings.cat2 ", found: " (ShowCore.type_ typ))))))
        Core.LiteralTypeInteger v1 -> case v1 of
          Core.IntegerTypeInt32 -> Right (Left (Pdl.SchemaPrimitive Pdl.PrimitiveTypeInt))
          Core.IntegerTypeInt64 -> Right (Left (Pdl.SchemaPrimitive Pdl.PrimitiveTypeLong))
          _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "Expected " (Strings.cat2 "int32 or int64" (Strings.cat2 ", found: " (ShowCore.type_ typ))))))
        Core.LiteralTypeString -> Right (Left (Pdl.SchemaPrimitive Pdl.PrimitiveTypeString))
        _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "Expected " (Strings.cat2 "PDL-supported literal type" (Strings.cat2 ", found: " (ShowCore.type_ typ))))))
      Core.TypeMap v0 -> Eithers.bind (encode cx g aliases (Core.mapTypeValues v0)) (\inner -> Right (Left (Pdl.SchemaMap inner)))
      Core.TypePair v0 -> Eithers.bind (encode cx g aliases (Core.pairTypeFirst v0)) (\firstSchema -> Eithers.bind (encode cx g aliases (Core.pairTypeSecond v0)) (\secondSchema ->
        let firstField =
                Pdl.RecordField {
                  Pdl.recordFieldName = (Pdl.FieldName "first"),
                  Pdl.recordFieldValue = firstSchema,
                  Pdl.recordFieldOptional = False,
                  Pdl.recordFieldDefault = Nothing,
                  Pdl.recordFieldAnnotations = noAnnotations}
            secondField =
                    Pdl.RecordField {
                      Pdl.recordFieldName = (Pdl.FieldName "second"),
                      Pdl.recordFieldValue = secondSchema,
                      Pdl.recordFieldOptional = False,
                      Pdl.recordFieldDefault = Nothing,
                      Pdl.recordFieldAnnotations = noAnnotations}
        in (Right (Right (Pdl.NamedSchemaTypeRecord (Pdl.RecordSchema {
          Pdl.recordSchemaFields = [
            firstField,
            secondField],
          Pdl.recordSchemaIncludes = []}))))))
      Core.TypeSet v0 -> Eithers.bind (encode cx g aliases v0) (\inner -> Right (Left (Pdl.SchemaArray inner)))
      Core.TypeVariable v0 -> Right (Left (Pdl.SchemaNamed (pdlNameForElement aliases True v0)))
      Core.TypeWrap v0 -> encodeType cx g aliases v0
      Core.TypeOptional _ -> Left (Errors.ErrorOther (Errors.OtherError "optionals unexpected at top level"))
      Core.TypeRecord v0 -> Eithers.bind (Eithers.mapList (encodeRecordField cx g aliases) v0) (\rfields -> Right (Right (Pdl.NamedSchemaTypeRecord (Pdl.RecordSchema {
        Pdl.recordSchemaFields = rfields,
        Pdl.recordSchemaIncludes = []}))))
      Core.TypeUnion v0 -> Logic.ifElse (Lists.foldl (\b -> \t -> Logic.and b (Equality.equal (Strip.deannotateType t) Core.TypeUnit)) True (Lists.map (\f -> Core.fieldTypeType f) v0)) (Eithers.bind (Eithers.mapList (encodeEnumField cx g) v0) (\fs -> Right (Right (Pdl.NamedSchemaTypeEnum (Pdl.EnumSchema {
        Pdl.enumSchemaFields = fs}))))) (Eithers.bind (Eithers.mapList (encodeUnionField cx g aliases) v0) (\members -> Right (Left (Pdl.SchemaUnion (Pdl.UnionSchema members)))))
      _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "Expected " (Strings.cat2 "PDL-supported type" (Strings.cat2 ", found: " (ShowCore.type_ typ))))))
encodeUnionField :: t0 -> Graph.Graph -> M.Map Packaging.ModuleName String -> Core.FieldType -> Either Errors.Error Pdl.UnionMember
encodeUnionField cx g aliases ft =

      let name = Core.fieldTypeName ft
          typ = Core.fieldTypeType ft
      in (Eithers.bind (getAnns cx g typ) (\anns -> Eithers.bind (encodePossiblyOptionalType cx g aliases typ) (\optResult ->
        let s = Pairs.first optResult
            optional = Pairs.second optResult
            schema =
                    Logic.ifElse optional (Pdl.SchemaUnion (Pdl.UnionSchema (Lists.map (\ms -> simpleUnionMember ms) [
                      Pdl.SchemaNull,
                      s]))) s
        in (Right (Pdl.UnionMember {
          Pdl.unionMemberAlias = (Just (Pdl.FieldName (Core.unName name))),
          Pdl.unionMemberValue = schema,
          Pdl.unionMemberAnnotations = anns})))))
getAnns :: t0 -> Graph.Graph -> Core.Type -> Either Errors.Error Pdl.Annotations
getAnns cx g typ = Eithers.bind (Annotations.getTypeDescription cx g typ) (\r -> Right (doc r))
-- | Compute import aliases for a module's dependencies
importAliasesForModule :: t0 -> Graph.Graph -> Packaging.Module -> Either Errors.Error (M.Map Packaging.ModuleName String)
importAliasesForModule cx g mod =
    Eithers.bind (Analysis.moduleDependencyModuleNames cx g False True True False mod) (\nss -> Right (Maps.fromList (Lists.map (\ns_ -> (ns_, (slashesToDots (Packaging.unModuleName ns_)))) (Sets.toList nss))))
-- | Convert a Hydra module to a map of file paths to PDL schema strings
moduleToPdl :: Packaging.Module -> [Packaging.Definition] -> t0 -> Graph.Graph -> Either Errors.Error (M.Map String String)
moduleToPdl mod defs cx g =
    Eithers.bind (moduleToPegasusSchemas cx g mod defs) (\files -> Right (Maps.fromList (Lists.map (\pair -> (Pairs.first pair, (Serialization.printExpr (Serialization.parenthesize (Serde.schemaFileToExpr (Pairs.second pair)))))) (Maps.toList files))))
-- | Convert a Hydra module and its definitions to PDL schema files
moduleToPegasusSchemas :: t0 -> Graph.Graph -> Packaging.Module -> [Packaging.Definition] -> Either Errors.Error (M.Map String Pdl.SchemaFile)
moduleToPegasusSchemas cx g mod defs =

      let partitioned = Environment.partitionDefinitions defs
          typeDefs = Pairs.first partitioned
      in (Eithers.bind (importAliasesForModule cx g mod) (\aliases -> constructModule cx g aliases mod typeDefs))
-- | Empty PDL annotations
noAnnotations :: Pdl.Annotations
noAnnotations =
    Pdl.Annotations {
      Pdl.annotationsDoc = Nothing,
      Pdl.annotationsDeprecated = False}
-- | Convert a Hydra element name to a PDL qualified name
pdlNameForElement :: M.Map Packaging.ModuleName String -> Bool -> Core.Name -> Pdl.QualifiedName
pdlNameForElement aliases withNs name =

      let qn = Names.qualifyName name
          ns_ = Util.qualifiedNameModuleName qn
          local = Util.qualifiedNameLocal qn
          alias = Optionals.bind ns_ (\n -> Maps.lookup n aliases)
      in Pdl.QualifiedName {
        Pdl.qualifiedNameName = (Pdl.Name local),
        Pdl.qualifiedNameNamespace = (Logic.ifElse withNs (Optionals.map (\a -> Pdl.Namespace a) alias) Nothing)}
-- | Convert a module's namespace to a PDL namespace
pdlNameForModule :: Packaging.Module -> Pdl.Namespace
pdlNameForModule mod = Pdl.Namespace (slashesToDots (Packaging.unModuleName (Packaging.moduleName mod)))
-- | Create a simple union member without an alias
simpleUnionMember :: Pdl.Schema -> Pdl.UnionMember
simpleUnionMember schema =
    Pdl.UnionMember {
      Pdl.unionMemberAlias = Nothing,
      Pdl.unionMemberValue = schema,
      Pdl.unionMemberAnnotations = noAnnotations}
-- | Replace all forward slashes with dots in a string
slashesToDots :: String -> String
slashesToDots s = Strings.intercalate "." (Strings.splitOn "/" s)
toPair :: Packaging.Module -> t0 -> (Pdl.NamedSchema, [Pdl.QualifiedName]) -> (String, Pdl.SchemaFile)
toPair mod aliases schemaPair =

      let schema = Pairs.first schemaPair
          imports = Pairs.second schemaPair
          ns_ = pdlNameForModule mod
          local = Pdl.unName (Pdl.qualifiedNameName (Pdl.namedSchemaQualifiedName schema))
          path =
                  Names.moduleNameToFilePath Util.CaseConventionCamel (File.FileExtension "pdl") (Packaging.ModuleName (Strings.cat2 (Packaging.unModuleName (Packaging.moduleName mod)) (Strings.cat2 "/" local)))
      in (
        path,
        Pdl.SchemaFile {
          Pdl.schemaFileNamespace = ns_,
          Pdl.schemaFilePackage = Nothing,
          Pdl.schemaFileImports = imports,
          Pdl.schemaFileSchemas = [
            schema]})
typeToSchema :: t0 -> Graph.Graph -> M.Map Packaging.ModuleName String -> t1 -> Packaging.TypeDefinition -> Either Errors.Error (Pdl.NamedSchema, [t2])
typeToSchema cx g aliases mod typeDef =

      let typ = Core.typeSchemeBody (Packaging.typeDefinitionBody typeDef)
      in (Eithers.bind (encodeType cx g aliases typ) (\res ->
        let ptype = Eithers.either (\schema -> Pdl.NamedSchemaTypeTyperef schema) (\t -> t) res
        in (Eithers.bind (Annotations.getTypeDescription cx g typ) (\descr ->
          let anns = doc descr
              qname = pdlNameForElement aliases False (Packaging.typeDefinitionName typeDef)
          in (Right (
            Pdl.NamedSchema {
              Pdl.namedSchemaQualifiedName = qname,
              Pdl.namedSchemaType = ptype,
              Pdl.namedSchemaAnnotations = anns},
            []))))))