Coder.hs

-- Note: this is an automatically generated file. Do not edit.
-- | SHACL coder: converts Hydra types and terms to SHACL shapes and RDF descriptions

module Hydra.Shacl.Coder where
import qualified Hydra.Annotations as Annotations
import qualified Hydra.Ast as Ast
import qualified Hydra.Coders as Coders
import qualified Hydra.Constants as Constants
import qualified Hydra.Core as Core
import qualified Hydra.Decode.Core as DecodeCore
import qualified Hydra.Encode.Core as EncodeCore
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.Extract.Core as ExtractCore
import qualified Hydra.Formatting as Formatting
import qualified Hydra.Graph as Graph
import qualified Hydra.Json.Model as JsonModel
import qualified Hydra.Lexical as Lexical
import qualified Hydra.Overlay.Haskell.Lib.Eithers as Eithers
import qualified Hydra.Overlay.Haskell.Lib.Lists as Lists
import qualified Hydra.Overlay.Haskell.Lib.Literals as Literals
import qualified Hydra.Overlay.Haskell.Lib.Logic as Logic
import qualified Hydra.Overlay.Haskell.Lib.Maps as Maps
import qualified Hydra.Overlay.Haskell.Lib.Math as Math
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.Query as Query
import qualified Hydra.Rdf.Syntax as Syntax
import qualified Hydra.Rdf.Utils as Utils
import qualified Hydra.Relational as Relational
import qualified Hydra.Shacl.Model as ShaclModel
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
-- | Construct CommonProperties from a list of constraints, using defaults for other fields
common :: [ShaclModel.CommonConstraint] -> ShaclModel.CommonProperties
common constraints =
    ShaclModel.CommonProperties {
      ShaclModel.commonPropertiesConstraints = (Sets.fromList constraints),
      ShaclModel.commonPropertiesDeactivated = Nothing,
      ShaclModel.commonPropertiesMessage = (Syntax.LangStrings Maps.empty),
      ShaclModel.commonPropertiesSeverity = ShaclModel.SeverityInfo,
      ShaclModel.commonPropertiesTargetClass = Sets.empty,
      ShaclModel.commonPropertiesTargetNode = Sets.empty,
      ShaclModel.commonPropertiesTargetObjectsOf = Sets.empty,
      ShaclModel.commonPropertiesTargetSubjectsOf = Sets.empty}
-- | Default CommonProperties with empty constraints and default severity
defaultCommonProperties :: ShaclModel.CommonProperties
defaultCommonProperties = common []
-- | Convert a binding's name to an RDF IRI
elementIri :: Core.Binding -> Syntax.Iri
elementIri el = Utils.nameToIri (Core.bindingName el)
-- | Encode a record field as RDF triples with a given subject
encodeField :: Core.Name -> Syntax.Resource -> Core.Field -> Int -> Graph.Graph -> Either Errors.Error ([Syntax.Triple], Int)
encodeField rname subject field cx g =

      let pair1 = Utils.nextBlankNode cx
          node = Pairs.first pair1
          cx1 = Pairs.second pair1
      in (Eithers.bind (encodeTerm node (Core.fieldTerm field) cx1 g) (\_r1 ->
        let descs = Pairs.first _r1
            cx2 = Pairs.second _r1
        in (Right (
          Lists.concat2 (Utils.triplesOf descs) (Utils.forObjects subject (Utils.propertyIri rname (Core.fieldName field)) (Utils.subjectsOf descs)),
          cx2))))
-- | Encode a FieldType as a SHACL property shape Definition
encodeFieldType :: Core.Name -> Maybe Integer -> Core.FieldType -> t0 -> Either Errors.Error (ShaclModel.Definition ShaclModel.PropertyShape)
encodeFieldType rname order ft cx =

      let fname = Core.fieldTypeName ft
          ftype = Core.fieldTypeType ft
          iri = Utils.propertyIri rname fname
          forType =
                  \mn -> \mx -> \t -> case (Strip.deannotateType t) of
                    Core.TypeOptional v0 -> forType (Just 0) mx v0
                    Core.TypeSet v0 -> forType mn Nothing v0
                    _ -> forTypeDefault mn mx t
          forTypeDefault =
                  \mn -> \mx -> \t -> Eithers.map (\_cp ->
                    let baseProp = property iri
                        minC = Optionals.map (\_n -> ShaclModel.PropertyShapeConstraintMinCount _n) mn
                        maxC = Optionals.map (\_n -> ShaclModel.PropertyShapeConstraintMaxCount _n) mx
                    in ShaclModel.Definition {
                      ShaclModel.definitionIri = iri,
                      ShaclModel.definitionTarget = ShaclModel.PropertyShape {
                        ShaclModel.propertyShapeCommon = _cp,
                        ShaclModel.propertyShapeConstraints = (Sets.fromList (Optionals.cat [
                          minC,
                          maxC])),
                        ShaclModel.propertyShapeDefaultValue = Nothing,
                        ShaclModel.propertyShapeDescription = (Syntax.LangStrings Maps.empty),
                        ShaclModel.propertyShapeName = (Syntax.LangStrings Maps.empty),
                        ShaclModel.propertyShapeOrder = order,
                        ShaclModel.propertyShapePath = iri}}) (encodeType rname t cx)
      in (forType (Just 1) (Just 1) ftype)
-- | Encode a list of terms as RDF list structure
encodeList :: Syntax.Resource -> [Core.Term] -> Int -> Graph.Graph -> Either Errors.Error ([Syntax.Description], Int)
encodeList subj terms cx0 g =
    Logic.ifElse (Lists.null terms) (Right (
      [
        Syntax.Description {
          Syntax.descriptionSubject = (Syntax.NodeIri (Syntax.Iri "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")),
          Syntax.descriptionGraph = (Syntax.Graph Sets.empty)}],
      cx0)) (Optionals.cases (Lists.uncons terms) (Right ([], cx0)) (\p ->
      let pair1 = Utils.nextBlankNode cx0
          node1 = Pairs.first pair1
          cx1 = Pairs.second pair1
      in (Eithers.bind (encodeTerm node1 (Pairs.first p) cx1 g) (\_r1 ->
        let fdescs = Pairs.first _r1
            cx2 = Pairs.second _r1
            firstTriples = Lists.concat2 (Utils.triplesOf fdescs) (Utils.forObjects subj (Utils.rdfIri "first") (Utils.subjectsOf fdescs))
            pair2 = Utils.nextBlankNode cx2
            next = Pairs.first pair2
            cx3 = Pairs.second pair2
        in (Eithers.map (\_r2 ->
          let rdescs = Pairs.first _r2
              cx4 = Pairs.second _r2
              restTriples = Lists.concat2 (Utils.triplesOf rdescs) (Utils.forObjects subj (Utils.rdfIri "rest") (Utils.subjectsOf rdescs))
          in (
            [
              Syntax.Description {
                Syntax.descriptionSubject = (Utils.resourceToNode subj),
                Syntax.descriptionGraph = (Syntax.Graph (Sets.fromList (Lists.concat2 firstTriples restTriples)))}],
            cx4)) (encodeList next (Pairs.second p) cx3 g))))))
-- | Encode a LiteralType as SHACL CommonProperties with an XSD datatype constraint
encodeLiteralType :: Core.LiteralType -> ShaclModel.CommonProperties
encodeLiteralType lt =

      let xsd = \local -> common [
            ShaclModel.CommonConstraintDatatype (Utils.xmlSchemaDatatypeIri local)]
      in case lt of
        Core.LiteralTypeBinary -> xsd "base64Binary"
        Core.LiteralTypeBoolean -> xsd "boolean"
        Core.LiteralTypeFloat v0 -> case v0 of
          Core.FloatTypeFloat32 -> xsd "float"
          Core.FloatTypeFloat64 -> xsd "double"
        Core.LiteralTypeInteger v0 -> case v0 of
          Core.IntegerTypeBigint -> xsd "integer"
          Core.IntegerTypeInt8 -> xsd "byte"
          Core.IntegerTypeInt16 -> xsd "short"
          Core.IntegerTypeInt32 -> xsd "int"
          Core.IntegerTypeInt64 -> xsd "long"
          Core.IntegerTypeUint8 -> xsd "unsignedByte"
          Core.IntegerTypeUint16 -> xsd "unsignedShort"
          Core.IntegerTypeUint32 -> xsd "unsignedInt"
          Core.IntegerTypeUint64 -> xsd "unsignedLong"
        Core.LiteralTypeString -> xsd "string"
-- | Encode a Hydra term as a list of RDF Descriptions
encodeTerm :: Syntax.Resource -> Core.Term -> Int -> Graph.Graph -> Either Errors.Error ([Syntax.Description], Int)
encodeTerm subject term cx g =
    case term of
      Core.TermAnnotated v0 -> encodeTerm subject (Core.annotatedTermBody v0) cx g
      Core.TermList v0 -> encodeList subject v0 cx g
      Core.TermLiteral v0 -> Right (
        [
          Syntax.Description {
            Syntax.descriptionSubject = (Syntax.NodeLiteral (Utils.encodeLiteral v0)),
            Syntax.descriptionGraph = (Syntax.Graph Sets.empty)}],
        cx)
      Core.TermMap v0 -> Eithers.map (\_r -> (
        [
          Syntax.Description {
            Syntax.descriptionSubject = (Utils.resourceToNode subject),
            Syntax.descriptionGraph = (Syntax.Graph (Sets.fromList (Lists.concat (Pairs.first _r))))}],
        (Pairs.second _r))) (foldAccumResult (\_cx0 -> \kv -> Eithers.bind (ExtractCore.string g (Strip.deannotateTerm (Pairs.first kv))) (\_ks ->
        let pair2 = Utils.nextBlankNode _cx0
            node2 = Pairs.first pair2
            cx2 = Pairs.second pair2
        in (Eithers.map (\_dr -> (
          Lists.concat2 (Utils.forObjects subject (Utils.keyIri _ks) (Utils.subjectsOf (Pairs.first _dr))) (Utils.triplesOf (Pairs.first _dr)),
          (Pairs.second _dr))) (encodeTerm node2 (Pairs.second kv) cx2 g)))) cx (Maps.toList v0))
      Core.TermWrap v0 -> Eithers.map (\_dr ->
        let descs = Pairs.first _dr
            cx1 = Pairs.second _dr
        in (
          Optionals.fromOptional descs (Optionals.map (\p -> Lists.cons (withType (Core.wrappedTermTypeName v0) (Pairs.first p)) (Pairs.second p)) (Lists.uncons descs)),
          cx1)) (encodeTerm subject (Core.wrappedTermBody v0) cx g)
      Core.TermOptional v0 -> Optionals.cases v0 (Right ([], cx)) (\_inner -> encodeTerm subject _inner cx g)
      Core.TermRecord v0 ->
        let rname = Core.recordTypeName v0
            fields = Core.recordFields v0
        in (Eithers.map (\_r -> (
          [
            withType rname (Syntax.Description {
              Syntax.descriptionSubject = (Utils.resourceToNode subject),
              Syntax.descriptionGraph = (Syntax.Graph (Sets.fromList (Lists.concat (Pairs.first _r))))})],
          (Pairs.second _r))) (foldAccumResult (\_cx0 -> \field -> encodeField rname subject field _cx0 g) cx fields))
      Core.TermSet v0 -> Eithers.map (\_r -> (Lists.concat (Pairs.first _r), (Pairs.second _r))) (foldAccumResult (\_cx0 -> \t ->
        let pair3 = Utils.nextBlankNode _cx0
            node3 = Pairs.first pair3
            cx3 = Pairs.second pair3
        in (encodeTerm node3 t cx3 g)) cx (Sets.toList v0))
      Core.TermInject v0 ->
        let rname = Core.injectionTypeName v0
            field = Core.injectionField v0
        in (Eithers.map (\_r -> (
          [
            withType rname (Syntax.Description {
              Syntax.descriptionSubject = (Utils.resourceToNode subject),
              Syntax.descriptionGraph = (Syntax.Graph (Sets.fromList (Pairs.first _r)))})],
          (Pairs.second _r))) (encodeField rname subject field cx g))
      _ -> unexpectedE "RDF-compatible term" "unsupported term variant"
-- | Encode a Hydra type as SHACL CommonProperties
encodeType :: Core.Name -> Core.Type -> t0 -> Either Errors.Error ShaclModel.CommonProperties
encodeType tname typ cx =

      let any = Right (common [])
      in case (Strip.deannotateType typ) of
        Core.TypeEither _ -> any
        Core.TypeList _ -> any
        Core.TypeLiteral v0 -> Right (encodeLiteralType v0)
        Core.TypeMap _ -> any
        Core.TypePair _ -> any
        Core.TypeWrap _ -> any
        Core.TypeRecord v0 -> Eithers.map (\_props -> common [
          ShaclModel.CommonConstraintProperty (Sets.fromList (Lists.map (\_p -> ShaclModel.ReferenceDefinition _p) _props))]) (Eithers.mapList (\_pair -> encodeFieldType tname (Just (Pairs.first _pair)) (Pairs.second _pair) cx) (Lists.zip (Lists.map (\_i -> Literals.int32ToBigint _i) (Math.range 0 (Lists.length v0))) v0))
        Core.TypeSet _ -> any
        Core.TypeUnion v0 -> Eithers.map (\_props -> common [
          ShaclModel.CommonConstraintXone (Sets.fromList (Lists.map (\_p -> ShaclModel.ReferenceAnonymous (node [
            ShaclModel.CommonConstraintProperty (Sets.fromList [
              ShaclModel.ReferenceDefinition _p])])) _props))]) (Eithers.mapList (\_ft -> encodeFieldType tname Nothing _ft cx) v0)
        Core.TypeUnit -> any
        Core.TypeVariable v0 -> Right (common [
          ShaclModel.CommonConstraintNode (Sets.fromList [
            ShaclModel.ReferenceNamed (Utils.nameToIri v0)])])
        _ -> unexpectedE "type" "unsupported type variant"
-- | Construct an error result with the given message
err :: String -> Either Errors.Error t0
err msg = Left (Errors.ErrorOther (Errors.OtherError msg))
-- | Fold over a list, accumulating results and threading context through each step
foldAccumResult :: (t0 -> t1 -> Either t2 (t3, t0)) -> t0 -> [t1] -> Either t2 ([t3], t0)
foldAccumResult f cx xs =
    Optionals.cases (Lists.uncons xs) (Right ([], cx)) (\p -> Eithers.bind (f cx (Pairs.first p)) (\_r -> Eithers.map (\_rest -> (Lists.cons (Pairs.first _r) (Pairs.first _rest), (Pairs.second _rest))) (foldAccumResult f (Pairs.second _r) (Pairs.second p))))
-- | Construct a SHACL node shape from a list of common constraints
node :: [ShaclModel.CommonConstraint] -> ShaclModel.Shape
node constraints = ShaclModel.ShapeNode (ShaclModel.NodeShape {
  ShaclModel.nodeShapeCommon = (common constraints)})
-- | Construct a default property shape with the given IRI as its path
property :: Syntax.Iri -> ShaclModel.PropertyShape
property iri =
    ShaclModel.PropertyShape {
      ShaclModel.propertyShapeCommon = defaultCommonProperties,
      ShaclModel.propertyShapeConstraints = Sets.empty,
      ShaclModel.propertyShapeDefaultValue = Nothing,
      ShaclModel.propertyShapeDescription = (Syntax.LangStrings Maps.empty),
      ShaclModel.propertyShapeName = (Syntax.LangStrings Maps.empty),
      ShaclModel.propertyShapeOrder = Nothing,
      ShaclModel.propertyShapePath = iri}
-- | Encode a module's type elements as a SHACL ShapesGraph
shaclCoder :: Packaging.Module -> t0 -> Graph.Graph -> Either Errors.Error (ShaclModel.ShapesGraph, t0)
shaclCoder mod cx g =

      let typeEls =
              Optionals.cat (Lists.map (\d -> case d of
                Packaging.DefinitionType v0 -> Just ((\name -> \typ ->
                  let schemaTerm = Core.TermVariable (Core.Name "hydra.core.Type")
                      dataTerm =
                              Annotations.normalizeTermAnnotations (Core.TermAnnotated (Core.AnnotatedTerm {
                                Core.annotatedTermBody = (EncodeCore.type_ typ),
                                Core.annotatedTermAnnotation = (Annotations.wrapAnnotationMap (Maps.fromList [
                                  (Constants.keyType, schemaTerm)]))}))
                  in Core.Binding {
                    Core.bindingName = name,
                    Core.bindingTerm = dataTerm,
                    Core.bindingTypeScheme = (Just (Core.TypeScheme {
                      Core.typeSchemeVariables = [],
                      Core.typeSchemeBody = (Core.TypeVariable (Core.Name "hydra.core.Type")),
                      Core.typeSchemeConstraints = Nothing}))}) (Packaging.typeDefinitionName v0) (Core.typeSchemeBody (Packaging.typeDefinitionBody v0)))
                _ -> Nothing) (Packaging.moduleDefinitions mod))
          toShape =
                  \el -> Eithers.bind (Eithers.bimap (\_de -> Errors.ErrorOther (Errors.OtherError (Errors.unDecodingError _de))) (\_t -> _t) (DecodeCore.type_ g (Core.bindingTerm el))) (\_typ -> Eithers.map (\_cp -> ShaclModel.Definition {
                    ShaclModel.definitionIri = (elementIri el),
                    ShaclModel.definitionTarget = (ShaclModel.ShapeNode (ShaclModel.NodeShape {
                      ShaclModel.nodeShapeCommon = _cp}))}) (encodeType (Core.bindingName el) _typ cx))
      in (Eithers.map (\_shapes -> (ShaclModel.ShapesGraph (Sets.fromList _shapes), cx)) (Eithers.mapList toShape typeEls))
-- | Construct an error for unexpected input, given expected and found descriptions
unexpectedE :: String -> String -> Either Errors.Error t0
unexpectedE expected found =
    err (Strings.cat [
      "Expected ",
      expected,
      ", found: ",
      found])
-- | Add an rdf:type triple to an RDF Description
withType :: Core.Name -> Syntax.Description -> Syntax.Description
withType name desc =

      let subj = Syntax.descriptionSubject desc
          triples = Syntax.unGraph (Syntax.descriptionGraph desc)
          subjRes =
                  case subj of
                    Syntax.NodeIri v0 -> Syntax.ResourceIri v0
                    Syntax.NodeBnode v0 -> Syntax.ResourceBnode v0
          triple =
                  Syntax.Triple {
                    Syntax.tripleSubject = subjRes,
                    Syntax.triplePredicate = (Utils.rdfIri "type"),
                    Syntax.tripleObject = (Syntax.NodeIri (Utils.nameToIri name))}
      in Syntax.Description {
        Syntax.descriptionSubject = subj,
        Syntax.descriptionGraph = (Syntax.Graph (Sets.insert triple triples))}