diff --git a/hydra-pg.cabal b/hydra-pg.cabal --- a/hydra-pg.cabal +++ b/hydra-pg.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hydra-pg -version: 0.17.2 +version: 0.17.3 synopsis: Hydra's property-graph (TinkerPop/Gremlin) model and coder support description: Hydra is an implementation of the LambdaGraph data model, which takes advantage of an isomorphism between labeled hypergraphs and typed lambda calculus: in Hydra, "graphs are programs, and programs are graphs". Property graph support for Hydra category: Data @@ -77,7 +77,7 @@ base >=4.19.0 && <4.22 , bytestring >=0.11.5 && <0.13 , containers >=0.6.7 && <0.8 - , hydra-kernel ==0.17.2 - , hydra-rdf ==0.17.2 + , hydra-kernel ==0.17.3 + , hydra-rdf ==0.17.3 , scientific >=0.3.7 && <0.4 default-language: Haskell2010 diff --git a/src/main/haskell/Hydra/Cypher/OpenCypher.hs b/src/main/haskell/Hydra/Cypher/OpenCypher.hs --- a/src/main/haskell/Hydra/Cypher/OpenCypher.hs +++ b/src/main/haskell/Hydra/Cypher/OpenCypher.hs @@ -461,7 +461,7 @@ _MultiPartQuery_body = Core.Name "body" --- | A multiplicative expression: a power expression with zero or more */รท/% terms +-- | A multiplicative expression: a power expression with zero or more multiply, divide, or modulo terms data MultiplyDivideModuloExpression = MultiplyDivideModuloExpression { multiplyDivideModuloExpressionLeft :: PowerOfExpression, diff --git a/src/main/haskell/Hydra/Decode/Neo4j/Model.hs b/src/main/haskell/Hydra/Decode/Neo4j/Model.hs --- a/src/main/haskell/Hydra/Decode/Neo4j/Model.hs +++ b/src/main/haskell/Hydra/Decode/Neo4j/Model.hs @@ -40,7 +40,7 @@ ( Core.Name "propertyUniqueness", (\input -> Eithers.map (\t -> Model.ConstraintPropertyUniqueness t) (propertyUniquenessConstraint cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -73,7 +73,7 @@ Maps.fromList [ (Core.Name "node", (\input -> Eithers.map (\t -> Model.ElementNode t) (node cx input))), (Core.Name "relationship", (\input -> Eithers.map (\t -> Model.ElementRelationship t) (relationship cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -480,7 +480,7 @@ _ -> Left (Errors.DecodingError "expected string literal") _ -> Left (Errors.DecodingError "expected literal")) (ExtractCore.stripWithDecodingError cx input)))), (Core.Name "time", (\input -> Eithers.map (\t -> Model.ValueTime t) (offsetTime cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -514,7 +514,7 @@ (Core.Name "list", (\input -> Eithers.map (\t -> Model.ValueTypeList t) (valueType cx input))), (Core.Name "vector", (\input -> Eithers.map (\t -> Model.ValueTypeVector t) (vectorType cx input))), (Core.Name "union", (\input -> Eithers.map (\t -> Model.ValueTypeUnion t) (ExtractCore.decodeList valueType cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) diff --git a/src/main/haskell/Hydra/Decode/Pg/Mapping.hs b/src/main/haskell/Hydra/Decode/Pg/Mapping.hs --- a/src/main/haskell/Hydra/Decode/Pg/Mapping.hs +++ b/src/main/haskell/Hydra/Decode/Pg/Mapping.hs @@ -132,7 +132,7 @@ Maps.fromList [ (Core.Name "vertex", (\input -> Eithers.map (\t -> Mapping.ElementSpecVertex t) (vertexSpec cx input))), (Core.Name "edge", (\input -> Eithers.map (\t -> Mapping.ElementSpecEdge t) (edgeSpec cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -167,7 +167,7 @@ Core.LiteralString v2 -> Right v2 _ -> Left (Errors.DecodingError "expected string literal") _ -> Left (Errors.DecodingError "expected literal")) (ExtractCore.stripWithDecodingError cx input))))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) diff --git a/src/main/haskell/Hydra/Decode/Pg/Model.hs b/src/main/haskell/Hydra/Decode/Pg/Model.hs --- a/src/main/haskell/Hydra/Decode/Pg/Model.hs +++ b/src/main/haskell/Hydra/Decode/Pg/Model.hs @@ -47,7 +47,7 @@ (Core.Name "in", (\input -> Eithers.map (\t -> Model.DirectionIn) (ExtractCore.decodeUnit cx input))), (Core.Name "both", (\input -> Eithers.map (\t -> Model.DirectionBoth) (ExtractCore.decodeUnit cx input))), (Core.Name "undirected", (\input -> Eithers.map (\t -> Model.DirectionUndirected) (ExtractCore.decodeUnit cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -104,7 +104,7 @@ Maps.fromList [ (Core.Name "vertex", (\input -> Eithers.map (\t -> Model.ElementVertex t) (vertex v cx input))), (Core.Name "edge", (\input -> Eithers.map (\t -> Model.ElementEdge t) (edge v cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -122,7 +122,7 @@ Maps.fromList [ (Core.Name "vertex", (\input -> Eithers.map (\t -> Model.ElementKindVertex) (ExtractCore.decodeUnit cx input))), (Core.Name "edge", (\input -> Eithers.map (\t -> Model.ElementKindEdge) (ExtractCore.decodeUnit cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -151,7 +151,7 @@ Maps.fromList [ (Core.Name "vertex", (\input -> Eithers.map (\t2 -> Model.ElementTypeVertex t2) (vertexType t cx input))), (Core.Name "edge", (\input -> Eithers.map (\t2 -> Model.ElementTypeEdge t2) (edgeType t cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) @@ -202,7 +202,7 @@ Maps.fromList [ (Core.Name "vertex", (\input -> Eithers.map (\t -> Model.LabelVertex t) (vertexLabel cx input))), (Core.Name "edge", (\input -> Eithers.map (\t -> Model.LabelEdge t) (edgeLabel cx input)))] - in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.cat [ + in (Optionals.cases (Maps.lookup fname variantMap) (Left (Errors.DecodingError (Strings.concat [ "no such field ", (Core.unName fname), " in union"]))) (\f -> f fterm)) diff --git a/src/main/haskell/Hydra/Demos/Genpg/Transform.hs b/src/main/haskell/Hydra/Demos/Genpg/Transform.hs --- a/src/main/haskell/Hydra/Demos/Genpg/Transform.hs +++ b/src/main/haskell/Hydra/Demos/Genpg/Transform.hs @@ -67,31 +67,31 @@ decodeValue = \value -> let parseError = - Strings.cat [ + Strings.concat [ "Invalid value for column ", cname, ": ", value] in case typ of Core.TypeLiteral v0 -> case v0 of - Core.LiteralTypeBoolean -> Optionals.cases (Literals.readBoolean value) (Left parseError) (\parsed -> Right (Just (Core.TermLiteral (Core.LiteralBoolean parsed)))) + Core.LiteralTypeBoolean -> Optionals.cases (Literals.parseBoolean value) (Left parseError) (\parsed -> Right (Just (Core.TermLiteral (Core.LiteralBoolean parsed)))) Core.LiteralTypeFloat v1 -> case v1 of Core.FloatTypeFloat32 -> Optionals.cases (Literals.readFloat32 value) (Left parseError) (\parsed -> Right (Just (Core.TermLiteral (Core.LiteralFloat (Core.FloatValueFloat32 parsed))))) Core.FloatTypeFloat64 -> Optionals.cases (Literals.readFloat64 value) (Left parseError) (\parsed -> Right (Just (Core.TermLiteral (Core.LiteralFloat (Core.FloatValueFloat64 parsed))))) - _ -> Left (Strings.cat [ + _ -> Left (Strings.concat [ "Unsupported float type for column ", cname]) Core.LiteralTypeInteger v1 -> case v1 of Core.IntegerTypeInt32 -> Optionals.cases (Literals.readInt32 value) (Left parseError) (\parsed -> Right (Just (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt32 parsed))))) Core.IntegerTypeInt64 -> Optionals.cases (Literals.readInt64 value) (Left parseError) (\parsed -> Right (Just (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt64 parsed))))) - _ -> Left (Strings.cat [ + _ -> Left (Strings.concat [ "Unsupported integer type for column ", cname]) Core.LiteralTypeString -> Right (Just (Core.TermLiteral (Core.LiteralString value))) - _ -> Left (Strings.cat [ + _ -> Left (Strings.concat [ "Unsupported literal type for column ", cname]) - _ -> Left (Strings.cat [ + _ -> Left (Strings.concat [ "Unsupported type for column ", cname]) in (Optionals.cases mvalue (Right Nothing) decodeValue) @@ -143,14 +143,14 @@ let table = Pairs.first p v = Pairs.second p existing = Maps.lookup table m - current = Optionals.fromOptional ([], []) existing + current = Optionals.withDefault ([], []) existing in (Maps.insert table (Lists.cons v (Pairs.first current), (Pairs.second current)) m) addEdge = \m -> \p -> let table = Pairs.first p e = Pairs.second p existing = Maps.lookup table m - current = Optionals.fromOptional ([], []) existing + current = Optionals.withDefault ([], []) existing in (Maps.insert table (Pairs.first current, (Lists.cons e (Pairs.second current))) m) vertexMap = Lists.foldl addVertex Maps.empty vertexPairs in (Right (Lists.foldl addEdge vertexMap edgePairs))))) @@ -184,7 +184,7 @@ let extractMaybe = \k -> \term -> case term of Core.TermOptional v0 -> Right (Optionals.map (\v -> (k, v)) v0) - in (Eithers.map (\pairs -> Maps.fromList (Optionals.cat pairs)) (Eithers.mapList (\pair -> + in (Eithers.map (\pairs -> Maps.fromList (Optionals.givens pairs)) (Eithers.mapList (\pair -> let k = Pairs.first pair spec = Pairs.second pair in (Eithers.bind (Reduction.reduceTerm cx g True (Core.TermApplication (Core.Application { @@ -238,7 +238,7 @@ let acc = Pairs.first (Pairs.first state) field = Pairs.second (Pairs.first state) inQuotes = Pairs.second state - in (Logic.ifElse (Equality.equal c 34) (Logic.ifElse inQuotes ((acc, field), False) (Logic.ifElse (Strings.null field) ((acc, field), True) ((acc, (Strings.cat2 field "\"")), inQuotes))) (Logic.ifElse (Logic.and (Equality.equal c 44) (Logic.not inQuotes)) ((Lists.cons (normalizeField field) acc, ""), False) ((acc, (Strings.cat2 field (Strings.fromList [ + in (Logic.ifElse (Equality.equal c 34) (Logic.ifElse inQuotes ((acc, field), False) (Logic.ifElse (Strings.null field) ((acc, field), True) ((acc, (Strings.concat2 field "\"")), inQuotes))) (Logic.ifElse (Logic.and (Equality.equal c 44) (Logic.not inQuotes)) ((Lists.cons (normalizeField field) acc, ""), False) ((acc, (Strings.concat2 field (Strings.fromList [ c]))), inQuotes))) -- | Parse a CSV line into fields. Empty fields become Nothing. @@ -264,12 +264,12 @@ parseTableLines :: Bool -> [String] -> Either String (Tabular.Table String) parseTableLines hasHeader rawLines = Eithers.bind (Eithers.mapList (\ln -> parseSingleLine ln) rawLines) (\parsedRows -> - let rows = Optionals.cat parsedRows + let rows = Optionals.givens parsedRows in (Logic.ifElse hasHeader (Optionals.cases (Lists.uncons rows) (Left "empty rows: cannot parse header") (\p -> let headerRow = Pairs.first p dataRows = Pairs.second p in (Logic.ifElse (listAny (\m -> Optionals.isNone m) headerRow) (Left "null header column(s)") (Right (Tabular.Table { - Tabular.tableHeader = (Just (Tabular.HeaderRow (Optionals.cat headerRow))), + Tabular.tableHeader = (Just (Tabular.HeaderRow (Optionals.givens headerRow))), Tabular.tableData = (Lists.map (\r -> Tabular.DataRow r) dataRows)}))))) (Right (Tabular.Table { Tabular.tableHeader = Nothing, Tabular.tableData = (Lists.map (\r -> Tabular.DataRow r) rows)})))) @@ -298,7 +298,7 @@ id, outId, inId] (Maps.elems props)) - in (Logic.ifElse (Equality.equal (Sets.size tables) 1) (Optionals.cases (Lists.maybeHead (Sets.toList tables)) (Left "unreachable: empty tables set") (\x -> Right x)) (Left (Strings.cat [ + in (Logic.ifElse (Equality.equal (Sets.size tables) 1) (Optionals.cases (Lists.head (Sets.toList tables)) (Left "unreachable: empty tables set") (\x -> Right x)) (Left (Strings.concat [ "Specification for ", (PgModel.unEdgeLabel label), " edges has wrong number of tables"]))) @@ -311,7 +311,7 @@ id = PgModel.vertexId vertex props = PgModel.vertexProperties vertex tables = findTablesInTerms (Lists.cons id (Maps.elems props)) - in (Logic.ifElse (Equality.equal (Sets.size tables) 1) (Optionals.cases (Lists.maybeHead (Sets.toList tables)) (Left "unreachable: empty tables set") (\x -> Right x)) (Left (Strings.cat [ + in (Logic.ifElse (Equality.equal (Sets.size tables) 1) (Optionals.cases (Lists.head (Sets.toList tables)) (Left "unreachable: empty tables set") (\x -> Right x)) (Left (Strings.concat [ "Specification for ", (PgModel.unVertexLabel label), " vertices has wrong number of tables"]))) @@ -338,7 +338,7 @@ -- | Transform a record through vertex and edge specifications to produce vertices and edges transformRecord :: t0 -> Graph.Graph -> [PgModel.Vertex Core.Term] -> [PgModel.Edge Core.Term] -> Core.Term -> Either Errors.Error ([PgModel.Vertex Core.Term], [PgModel.Edge Core.Term]) transformRecord cx g vspecs especs record = - Eithers.bind (Eithers.mapList (\spec -> evaluateVertex cx g spec record) vspecs) (\mVertices -> Eithers.bind (Eithers.mapList (\spec -> evaluateEdge cx g spec record) especs) (\mEdges -> Right (Optionals.cat mVertices, (Optionals.cat mEdges)))) + Eithers.bind (Eithers.mapList (\spec -> evaluateVertex cx g spec record) vspecs) (\mVertices -> Eithers.bind (Eithers.mapList (\spec -> evaluateEdge cx g spec record) especs) (\mEdges -> Right (Optionals.givens mVertices, (Optionals.givens mEdges)))) -- | Transform all rows from a table through vertex/edge specifications transformTableRows :: t0 -> Graph.Graph -> [PgModel.Vertex Core.Term] -> [PgModel.Edge Core.Term] -> Tabular.TableType -> [Tabular.DataRow Core.Term] -> Either Errors.Error ([PgModel.Vertex Core.Term], [PgModel.Edge Core.Term]) diff --git a/src/main/haskell/Hydra/Graphviz/Coder.hs b/src/main/haskell/Hydra/Graphviz/Coder.hs --- a/src/main/haskell/Hydra/Graphviz/Coder.hs +++ b/src/main/haskell/Hydra/Graphviz/Coder.hs @@ -118,6 +118,7 @@ (Packaging.ModuleName "hydra.lib.maps", "maps"), (Packaging.ModuleName "hydra.lib.math", "math"), (Packaging.ModuleName "hydra.lib.optionals", "optionals"), + (Packaging.ModuleName "hydra.lib.ordering", "ordering"), (Packaging.ModuleName "hydra.lib.pairs", "pairs"), (Packaging.ModuleName "hydra.lib.regex", "regex"), (Packaging.ModuleName "hydra.lib.sets", "sets"), @@ -134,24 +135,24 @@ Core.TermAnnotated _ -> simpleLabel "@{}" Core.TermApplication _ -> simpleLabel (Logic.ifElse compact "$" "apply") Core.TermLambda _ -> simpleLabel (Logic.ifElse compact "\955" "lambda") - Core.TermProject v0 -> simpleLabel (Strings.cat [ + Core.TermProject v0 -> simpleLabel (Strings.concat [ "{", (Names.compactName namespaces (Core.projectionTypeName v0)), "}.", (Core.unName (Core.projectionFieldName v0))]) - Core.TermCases v0 -> simpleLabel (Strings.cat [ + Core.TermCases v0 -> simpleLabel (Strings.concat [ "cases_{", (Names.compactName namespaces (Core.caseStatementTypeName v0)), "}"]) - Core.TermUnwrap v0 -> simpleLabel (Strings.cat [ + Core.TermUnwrap v0 -> simpleLabel (Strings.concat [ "unwrap_{", (Names.compactName namespaces v0), "}"]) Core.TermLet _ -> simpleLabel "let" Core.TermList _ -> simpleLabel (Logic.ifElse compact "[]" "list") Core.TermLiteral v0 -> simpleLabel (case v0 of - Core.LiteralBinary v1 -> Literals.binaryToString v1 - Core.LiteralBoolean v1 -> Literals.showBoolean v1 + Core.LiteralBinary v1 -> Literals.binaryToBase64 v1 + Core.LiteralBoolean v1 -> Literals.printBoolean v1 Core.LiteralInteger v1 -> case v1 of Core.IntegerValueBigint v2 -> Literals.showBigint v2 Core.IntegerValueInt8 v2 -> Literals.showInt8 v2 @@ -171,12 +172,12 @@ _ -> "?") Core.TermMap _ -> simpleLabel (Logic.ifElse compact "<,>" "map") Core.TermOptional _ -> simpleLabel (Logic.ifElse compact "opt" "optional") - Core.TermRecord v0 -> simpleLabel (Strings.cat2 "\8743" (Names.compactName namespaces (Core.recordTypeName v0))) + Core.TermRecord v0 -> simpleLabel (Strings.concat2 "\8743" (Names.compactName namespaces (Core.recordTypeName v0))) Core.TermTypeLambda _ -> simpleLabel "tyabs" Core.TermTypeApplication _ -> simpleLabel "tyapp" - Core.TermInject v0 -> simpleLabel (Strings.cat2 "\8891" (Names.compactName namespaces (Core.injectionTypeName v0))) + Core.TermInject v0 -> simpleLabel (Strings.concat2 "\8891" (Names.compactName namespaces (Core.injectionTypeName v0))) Core.TermVariable v0 -> simpleLabel (Names.compactName namespaces v0) - Core.TermWrap v0 -> simpleLabel (Strings.cat [ + Core.TermWrap v0 -> simpleLabel (Strings.concat [ "(", (Names.compactName namespaces (Core.wrappedTermTypeName v0)), ")"]) @@ -281,12 +282,12 @@ \stVis -> \binding -> let bname = Core.bindingName binding bterm = Core.bindingTerm binding - blab = Dot.unId (Optionals.fromOptional (Dot.Id "?") (Maps.lookup bname ids1)) + blab = Dot.unId (Optionals.withDefault (Dot.Id "?") (Maps.lookup bname ids1)) in (encode (Just (blab, nodeStyleElement)) True ids1 (Just selfId) stVis (Paths.SubtermStepLetBinding bname, bterm)) stmts1 = Lists.foldl addBindingTerm (selfStmts, selfVisited) bindings in (encode Nothing False ids1 (Just selfId) stmts1 (Paths.SubtermStepLetBody, env)) Core.TermVariable v0 -> Optionals.cases (Maps.lookup v0 ids) dflt (\i -> (Lists.concat2 stmts [ - toAccessorEdgeStmt accessor style (Optionals.fromOptional selfId mparent) i], visited)) + toAccessorEdgeStmt accessor style (Optionals.withDefault selfId mparent) i], visited)) _ -> dflt in (Pairs.first (encode Nothing False Maps.empty Nothing ([], Sets.empty) (Paths.SubtermStepAnnotatedBody, term))) @@ -317,7 +318,7 @@ let lab1 = Paths.subtermNodeId (Paths.subtermEdgeSource edge) lab2 = Paths.subtermNodeId (Paths.subtermEdgeTarget edge) pathAccessors = Paths.unSubtermPath (Paths.subtermEdgePath edge) - showPath = Strings.intercalate "/" (Optionals.cat (Lists.map PrintPaths.subtermStep pathAccessors)) + showPath = Strings.join "/" (Optionals.givens (Lists.map PrintPaths.subtermStep pathAccessors)) in (toEdgeStmt (Dot.Id lab1) (Dot.Id lab2) (Just (Dot.AttrList [ [ labelAttr showPath]]))) diff --git a/src/main/haskell/Hydra/Graphviz/Serde.hs b/src/main/haskell/Hydra/Graphviz/Serde.hs --- a/src/main/haskell/Hydra/Graphviz/Serde.hs +++ b/src/main/haskell/Hydra/Graphviz/Serde.hs @@ -132,7 +132,7 @@ -- | Convert an identifier to an expression idToExpr :: Dot.Id -> Ast.Expr idToExpr i = - Serialization.cst (Strings.cat [ + Serialization.cst (Strings.concat [ "\"", (Dot.unId i), "\""]) @@ -143,7 +143,7 @@ let i = Dot.nodeIdId nid mp = Dot.nodeIdPort nid - in (Serialization.noSep (Optionals.cat [ + in (Serialization.noSep (Optionals.givens [ Optionals.pure (idToExpr i), (Optionals.map portToExpr mp)])) @@ -160,7 +160,7 @@ let i = Dot.nodeStmtId ns attr = Dot.nodeStmtAttributes ns - in (Serialization.spaceSep (Optionals.cat [ + in (Serialization.spaceSep (Optionals.givens [ Optionals.pure (nodeIdToExpr i), (Optionals.map attrListToExpr attr)])) @@ -195,7 +195,7 @@ -- | Convert a subgraph identifier to an expression subgraphIdToExpr :: Dot.SubgraphId -> Ast.Expr subgraphIdToExpr sid = - Serialization.spaceSep (Optionals.cat [ + Serialization.spaceSep (Optionals.givens [ Optionals.pure (Serialization.cst "subgraph"), (Optionals.map idToExpr (Dot.unSubgraphId sid))]) @@ -207,6 +207,6 @@ stmts = Dot.subgraphStatements sg body = Serialization.brackets Serialization.curlyBraces Serialization.inlineStyle (Serialization.spaceSep (Lists.map (stmtToExpr directed) stmts)) - in (Serialization.spaceSep (Optionals.cat [ + in (Serialization.spaceSep (Optionals.givens [ Optionals.map subgraphIdToExpr mid, (Optionals.pure body)])) diff --git a/src/main/haskell/Hydra/Neo4j/Pg.hs b/src/main/haskell/Hydra/Neo4j/Pg.hs --- a/src/main/haskell/Hydra/Neo4j/Pg.hs +++ b/src/main/haskell/Hydra/Neo4j/Pg.hs @@ -12,6 +12,7 @@ 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.Ordering as Ordering 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 @@ -32,11 +33,11 @@ startStr = Neo4jModel.unNodeLabel startLabel endStr = Neo4jModel.unNodeLabel endLabel expanded = - Strings.cat [ + Strings.concat [ Formatting.decapitalize (Formatting.convertCase Util.CaseConventionPascal Util.CaseConventionCamel startStr), (Formatting.capitalize camelType), (Formatting.capitalize (Formatting.convertCase Util.CaseConventionPascal Util.CaseConventionCamel endStr))] - in (PgModel.EdgeLabel (Logic.ifElse (Equality.gt (Lists.length matching) 1) expanded camelType)) + in (PgModel.EdgeLabel (Logic.ifElse (Ordering.gt (Lists.length matching) 1) expanded camelType)) -- | Convert a property-graph edge to a Neo4j relationship (edge label -> UPPER_SNAKE type). edgeToRelationship :: Neo4jModel.Neo4jMapping t0 -> PgModel.Edge t0 -> Either String Neo4jModel.Relationship @@ -61,9 +62,9 @@ (\nodes2 -> \eid -> let m = Maps.fromList (Lists.map (\n -> (Neo4jModel.unElementId (Neo4jModel.nodeId n), (Sets.toList (Neo4jModel.nodeLabels n)))) nodes2) - in (Optionals.cases (Maps.lookup (Neo4jModel.unElementId eid) m) (Left (Strings.cat [ + in (Optionals.cases (Maps.lookup (Neo4jModel.unElementId eid) m) (Left (Strings.concat [ "no node with id ", - (Neo4jModel.unElementId eid)])) (\labels -> Logic.ifElse (Equality.equal (Lists.length labels) 1) (Right (Optionals.fromOptional (Neo4jModel.NodeLabel "") (Lists.maybeHead labels))) (Left (Strings.cat [ + (Neo4jModel.unElementId eid)])) (\labels -> Logic.ifElse (Equality.equal (Lists.length labels) 1) (Right (Optionals.withDefault (Neo4jModel.NodeLabel "") (Lists.head labels))) (Left (Strings.concat [ "endpoint node is not single-labeled: ", (Neo4jModel.unElementId eid)]))))) nodes in (Eithers.bind (Eithers.mapList (\n -> nodeToVertex mapping n) nodes) (\vertices -> Eithers.bind (Eithers.mapList (\r -> Eithers.bind (labelOf (Neo4jModel.relationshipStart r)) (\startLabel -> Eithers.bind (labelOf (Neo4jModel.relationshipEnd r)) (\endLabel -> relationshipToEdge mapping gt startLabel endLabel r))) rels) (\edges -> Right (vertices, edges)))) @@ -73,11 +74,11 @@ nodeToVertex mapping node = let labels = Sets.toList (Neo4jModel.nodeLabels node) - soleLabel = Optionals.fromOptional (Neo4jModel.NodeLabel "") (Lists.maybeHead labels) + soleLabel = Optionals.withDefault (Neo4jModel.NodeLabel "") (Lists.head labels) in (Logic.ifElse (Equality.equal (Lists.length labels) 1) (Eithers.bind (Neo4jModel.neo4jMappingDecodeId mapping (Neo4jModel.nodeId node)) (\vid -> Eithers.bind ((\mapping2 -> \props -> Eithers.map (\pairs -> Maps.fromList pairs) (Eithers.mapList (\entry -> Eithers.map (\decoded -> (PgModel.PropertyKey (Neo4jModel.unKey (Pairs.first entry)), decoded)) (Neo4jModel.neo4jMappingDecodeValue mapping2 (Pairs.second entry))) (Maps.toList props))) mapping (Neo4jModel.nodeProperties node)) (\props -> Right (PgModel.Vertex { PgModel.vertexLabel = (PgModel.VertexLabel (Neo4jModel.unNodeLabel soleLabel)), PgModel.vertexId = vid, - PgModel.vertexProperties = props})))) (Left (Strings.cat [ + PgModel.vertexProperties = props})))) (Left (Strings.concat [ "cannot map a multi-label Neo4j node to a single-label property-graph vertex: ", (Neo4jModel.unElementId (Neo4jModel.nodeId node))]))) diff --git a/src/main/haskell/Hydra/Pg/Coder.hs b/src/main/haskell/Hydra/Pg/Coder.hs --- a/src/main/haskell/Hydra/Pg/Coder.hs +++ b/src/main/haskell/Hydra/Pg/Coder.hs @@ -25,6 +25,7 @@ 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.Ordering as Ordering 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 @@ -60,7 +61,7 @@ -- | Check that a record name matches the expected name checkRecordName :: t0 -> Core.Name -> Core.Name -> Either Errors.Error () checkRecordName cx expected actual = - check cx (Logic.or (Equality.equal (Core.unName expected) "placeholder") (Equality.equal (Core.unName actual) (Core.unName expected))) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 (Strings.cat2 "Expected record of type " (Core.unName expected)) ", found record of type ") (Core.unName actual))))) + check cx (Logic.or (Equality.equal (Core.unName expected) "placeholder") (Equality.equal (Core.unName actual) (Core.unName expected))) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 (Strings.concat2 "Expected record of type " (Core.unName expected)) ", found record of type ") (Core.unName actual))))) -- | Construct an edge coder from components constructEdgeCoder :: t0 -> Graph.Graph -> PgModel.VertexLabel -> Mapping.Schema t1 t2 t3 Errors.Error -> Core.Type -> t2 -> t2 -> PgModel.Direction -> Core.Name -> [Core.FieldType] -> [Coders.Adapter Core.FieldType (PgModel.PropertyType t2) Core.Field (PgModel.Property t3) Errors.Error] -> Maybe (Core.FieldType, (Mapping.ValueSpec, (Maybe String))) -> Maybe (Core.FieldType, (Mapping.ValueSpec, (Maybe String))) -> Either Errors.Error (Coders.Adapter Core.Type (PgModel.ElementTypeTree t2) Core.Term (PgModel.ElementTree t3) Errors.Error) @@ -70,7 +71,7 @@ vertexIdsSchema = Mapping.schemaVertexIds schema in (Eithers.bind (edgeIdAdapter cx g schema eidType name (Core.Name (Mapping.annotationSchemaEdgeId (Mapping.schemaAnnotations schema))) fields) (\idAdapter -> Eithers.bind (Optionals.cases mOutSpec (Right Nothing) (\s -> Eithers.map (\x -> Just x) (projectionAdapter cx g vidType vertexIdsSchema s "out"))) (\outIdAdapter -> Eithers.bind (Optionals.cases mInSpec (Right Nothing) (\s -> Eithers.map (\x -> Just x) (projectionAdapter cx g vidType vertexIdsSchema s "in"))) (\inIdAdapter -> Eithers.bind (Optionals.cases mOutSpec (Right Nothing) (\s -> Eithers.map (\x -> Just x) (findIncidentVertexAdapter cx g schema vidType eidType s))) (\outVertexAdapter -> Eithers.bind (Optionals.cases mInSpec (Right Nothing) (\s -> Eithers.map (\x -> Just x) (findIncidentVertexAdapter cx g schema vidType eidType s))) (\inVertexAdapter -> let vertexAdapters = - Optionals.cat [ + Optionals.givens [ outVertexAdapter, inVertexAdapter] in (Eithers.bind (Optionals.cases mOutSpec (Right parentLabel) (\spec -> Optionals.cases (Pairs.second (Pairs.second spec)) (Left (Errors.ErrorOther (Errors.OtherError "no out-vertex label"))) (\a -> Right (PgModel.VertexLabel a)))) (\outLabel -> Eithers.bind (Optionals.cases mInSpec (Right parentLabel) (\spec -> Optionals.cases (Pairs.second (Pairs.second spec)) (Left (Errors.ErrorOther (Errors.OtherError "no in-vertex label"))) (\a -> Right (PgModel.VertexLabel a)))) (\inLabel -> Right (edgeCoder cx g dir schema source eidType name label outLabel inLabel idAdapter outIdAdapter inIdAdapter propAdapters vertexAdapters))))))))))) @@ -102,7 +103,7 @@ let deannot = Strip.deannotateTerm term unwrapped = case deannot of - Core.TermOptional v0 -> Optionals.fromOptional deannot v0 + Core.TermOptional v0 -> Optionals.withDefault deannot v0 _ -> deannot rec = case unwrapped of @@ -112,7 +113,7 @@ in (Eithers.bind (Optionals.cases mIdAdapter (Right (Mapping.schemaDefaultEdgeId schema)) (selectEdgeId cx fieldsm)) (\edgeId -> Eithers.bind (encodeProperties cx fieldsm propAdapters) (\props -> let getVertexId = \dirCheck -> \adapter -> Optionals.cases (Logic.ifElse (Equality.equal dir dirCheck) Nothing adapter) (Right (Mapping.schemaDefaultVertexId schema)) (selectVertexId cx fieldsm) - in (Eithers.bind (getVertexId PgModel.DirectionOut outAdapter) (\outId -> Eithers.bind (getVertexId PgModel.DirectionIn inAdapter) (\inId -> Eithers.bind (Eithers.map (\xs -> Optionals.cat xs) (Eithers.mapList (\va -> + in (Eithers.bind (getVertexId PgModel.DirectionOut outAdapter) (\outId -> Eithers.bind (getVertexId PgModel.DirectionIn inAdapter) (\inId -> Eithers.bind (Eithers.map (\xs -> Optionals.givens xs) (Eithers.mapList (\va -> let fname = Pairs.first va ad = Pairs.second va in (Optionals.cases (Maps.lookup fname fieldsm) (Right Nothing) (\fterm -> Eithers.map (\x -> Just x) (Coders.coderEncode (Coders.adapterCoder ad) fterm)))) vertexAdapters)) (\deps -> Right (elementTreeEdge (PgModel.Edge { @@ -147,7 +148,7 @@ in (Eithers.bind (findPropertySpecs cx g schema kind v0) (\propSpecs -> Eithers.bind (Eithers.mapList (propertyAdapter cx g schema) propSpecs) (\propAdapters -> case kind of PgModel.ElementKindVertex -> constructVertexCoder cx g schema source vidType eidType name v0 propAdapters PgModel.ElementKindEdge -> constructEdgeCoder cx g parentLabel schema source vidType eidType dir name v0 propAdapters mOutSpec mInSpec)))))) - _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 (Strings.cat2 "Expected " "record type") ", found: ") "other type"))) + _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 (Strings.concat2 "Expected " "record type") ", found: ") "other type"))) -- | Create an element tree for an edge elementTreeEdge :: PgModel.Edge t0 -> [PgModel.ElementTree t0] -> PgModel.ElementTree t0 @@ -180,7 +181,7 @@ -- | Encode all properties from a field map using property adapters encodeProperties :: t0 -> M.Map Core.Name Core.Term -> [Coders.Adapter Core.FieldType t1 Core.Field (PgModel.Property t2) Errors.Error] -> Either Errors.Error (M.Map PgModel.PropertyKey t2) encodeProperties cx fields adapters = - Eithers.map (\props -> Maps.fromList (Lists.map (\prop -> (PgModel.propertyKey prop, (PgModel.propertyValue prop))) props)) (Eithers.map (\xs -> Optionals.cat xs) (Eithers.mapList (encodeProperty cx fields) adapters)) + Eithers.map (\props -> Maps.fromList (Lists.map (\prop -> (PgModel.propertyKey prop, (PgModel.propertyValue prop))) props)) (Eithers.map (\xs -> Optionals.givens xs) (Eithers.mapList (encodeProperty cx fields) adapters)) -- | Encode a single property from a field map using a property adapter encodeProperty :: t0 -> M.Map Core.Name Core.Term -> Coders.Adapter Core.FieldType t1 Core.Field t2 Errors.Error -> Either Errors.Error (Maybe t2) @@ -196,7 +197,7 @@ \v -> Eithers.map (\x -> Just x) (Coders.coderEncode (Coders.adapterCoder adapter) (Core.Field { Core.fieldName = fname, Core.fieldTerm = v})) - in (Optionals.cases (Maps.lookup fname fields) (Logic.ifElse isMaybe (Right Nothing) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "expected field not found in record: " (Core.unName fname)))))) (\value -> Logic.ifElse isMaybe (case (Strip.deannotateTerm value) of + in (Optionals.cases (Maps.lookup fname fields) (Logic.ifElse isMaybe (Right Nothing) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 "expected field not found in record: " (Core.unName fname)))))) (\value -> Logic.ifElse isMaybe (case (Strip.deannotateTerm value) of Core.TermOptional v0 -> Optionals.cases v0 (Right Nothing) encodeValue _ -> encodeValue value) (encodeValue value))) @@ -211,7 +212,7 @@ Core.FieldType, (PgModel.EdgeLabel, (Coders.Adapter Core.Type (PgModel.ElementTypeTree t2) Core.Term (PgModel.ElementTree t3) Errors.Error))))] findAdjacenEdgeAdapters cx g schema vidType eidType parentLabel dir fields = - Eithers.map (\xs -> Optionals.cat xs) (Eithers.mapList (\field -> + Eithers.map (\xs -> Optionals.givens xs) (Eithers.mapList (\field -> let key = Core.Name (case dir of PgModel.DirectionOut -> Mapping.annotationSchemaOutEdgeLabel (Mapping.schemaAnnotations schema) @@ -221,7 +222,7 @@ -- | Find an id projection spec for a field findIdProjectionSpec :: t0 -> Bool -> Core.Name -> Core.Name -> [Core.FieldType] -> Either Errors.Error (Maybe (Core.FieldType, (Mapping.ValueSpec, (Maybe String)))) findIdProjectionSpec cx required tname idKey fields = - Eithers.bind (findSingleFieldWithAnnotationKey cx tname idKey fields) (\mid -> Optionals.cases mid (Logic.ifElse required (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 "no " (Core.unName idKey)) " field")))) (Right Nothing)) (\mi -> Eithers.map (\spec -> Just (mi, (spec, (Optionals.map (\s -> Strings.toUpper s) Nothing)))) (Optionals.cases (Annotations.getTypeAnnotation idKey (Core.fieldTypeType mi)) (Right Mapping.ValueSpecValue) (TermsToElements.decodeValueSpec cx (Graph.Graph { + Eithers.bind (findSingleFieldWithAnnotationKey cx tname idKey fields) (\mid -> Optionals.cases mid (Logic.ifElse required (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 "no " (Core.unName idKey)) " field")))) (Right Nothing)) (\mi -> Eithers.map (\spec -> Just (mi, (spec, (Optionals.map (\s -> Strings.toUpper s) Nothing)))) (Optionals.cases (Annotations.getTypeAnnotation idKey (Core.fieldTypeType mi)) (Right Mapping.ValueSpecValue) (TermsToElements.decodeValueSpec cx (Graph.Graph { Graph.graphBoundTerms = Maps.empty, Graph.graphBoundTypes = Maps.empty, Graph.graphClassConstraints = Maps.empty, @@ -282,7 +283,7 @@ findSingleFieldWithAnnotationKey cx tname key fields = let matches = Lists.filter (\f -> Optionals.isGiven (Annotations.getTypeAnnotation key (Core.fieldTypeType f))) fields - in (Logic.ifElse (Equality.gt (Lists.length matches) 1) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 (Strings.cat2 "Multiple fields marked as '" (Core.unName key)) "' in record type ") (Core.unName tname))))) (Right (Lists.maybeHead matches))) + in (Logic.ifElse (Ordering.gt (Lists.length matches) 1) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 (Strings.concat2 "Multiple fields marked as '" (Core.unName key)) "' in record type ") (Core.unName tname))))) (Right (Lists.head matches))) -- | Determine whether the spec has vertex adapters based on direction and out/in specs hasVertexAdapters :: PgModel.Direction -> Maybe t0 -> Maybe t1 -> Bool @@ -305,8 +306,8 @@ Coders.adapterSource = (Core.fieldTypeType field), Coders.adapterTarget = idtype, Coders.adapterCoder = Coders.Coder { - Coders.coderEncode = (\typ -> Eithers.bind (traverseToSingleTerm cx (Strings.cat2 key "-projection") (traversal cx) typ) (\t -> Coders.coderEncode coder t)), - Coders.coderDecode = (\_ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 "edge '" key) "' decoding is not yet supported"))))}}))) + Coders.coderEncode = (\typ -> Eithers.bind (traverseToSingleTerm cx (Strings.concat2 key "-projection") (traversal cx) typ) (\t -> Coders.coderEncode coder t)), + Coders.coderDecode = (\_ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 "edge '" key) "' decoding is not yet supported"))))}}))) -- | Create a property adapter from a property spec propertyAdapter :: t0 -> t1 -> Mapping.Schema t2 t3 t4 Errors.Error -> (Core.FieldType, (Mapping.ValueSpec, (Maybe String))) -> Either Errors.Error (Coders.Adapter Core.FieldType (PgModel.PropertyType t3) Core.Field (PgModel.Property t4) Errors.Error) @@ -315,7 +316,7 @@ let tfield = Pairs.first spec values = Pairs.first (Pairs.second spec) alias = Pairs.second (Pairs.second spec) - key = PgModel.PropertyKey (Optionals.fromOptional (Core.unName (Core.fieldTypeName tfield)) alias) + key = PgModel.PropertyKey (Optionals.withDefault (Core.unName (Core.fieldTypeName tfield)) alias) in (Eithers.bind (Coders.coderEncode (Mapping.schemaPropertyTypes schema) (Core.fieldTypeType tfield)) (\pt -> Eithers.bind (TermsToElements.parseValueSpec cx g values) (\traversal -> Right (Coders.Adapter { Coders.adapterIsLossy = True, Coders.adapterSource = tfield, @@ -343,7 +344,7 @@ let fname = Pairs.first ad adapter = Pairs.second ad - in (Optionals.cases (Maps.lookup fname fields) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 "no " (Core.unName fname)) " in record")))) (\t -> Coders.coderEncode (Coders.adapterCoder adapter) t)) + in (Optionals.cases (Maps.lookup fname fields) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 "no " (Core.unName fname)) " in record")))) (\t -> Coders.coderEncode (Coders.adapterCoder adapter) t)) -- | Select a vertex id from record fields using an id adapter selectVertexId :: t0 -> M.Map Core.Name t1 -> (Core.Name, (Coders.Adapter t2 t3 t1 t4 Errors.Error)) -> Either Errors.Error t4 @@ -351,12 +352,12 @@ let fname = Pairs.first ad adapter = Pairs.second ad - in (Optionals.cases (Maps.lookup fname fields) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 "no " (Core.unName fname)) " in record")))) (\t -> Coders.coderEncode (Coders.adapterCoder adapter) t)) + in (Optionals.cases (Maps.lookup fname fields) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 "no " (Core.unName fname)) " in record")))) (\t -> Coders.coderEncode (Coders.adapterCoder adapter) t)) -- | Traverse to a single term, failing if zero or multiple terms are found traverseToSingleTerm :: t0 -> String -> (t1 -> Either Errors.Error [t2]) -> t1 -> Either Errors.Error t2 traverseToSingleTerm cx desc traversal term = - Eithers.bind (traversal term) (\terms -> Logic.ifElse (Lists.null terms) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 desc " did not resolve to a term")))) (Logic.ifElse (Equality.equal (Lists.length terms) 1) (Optionals.cases (Lists.maybeHead terms) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 desc " resolved to multiple terms")))) (\x -> Right x)) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 desc " resolved to multiple terms")))))) + Eithers.bind (traversal term) (\terms -> Logic.ifElse (Lists.null terms) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 desc " did not resolve to a term")))) (Logic.ifElse (Equality.equal (Lists.length terms) 1) (Optionals.cases (Lists.head terms) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 desc " resolved to multiple terms")))) (\x -> Right x)) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 desc " resolved to multiple terms")))))) -- | Create a vertex coder given all components vertexCoder :: t0 -> t1 -> Mapping.Schema t2 t3 t4 t5 -> t6 -> t7 -> t8 -> PgModel.VertexLabel -> (Core.Name, (Coders.Adapter t9 t10 Core.Term t4 Errors.Error)) -> [Coders.Adapter Core.FieldType (PgModel.PropertyType t7) Core.Field (PgModel.Property t4) Errors.Error] -> [( @@ -382,7 +383,7 @@ let deannot = Strip.deannotateTerm term unwrapped = case deannot of - Core.TermOptional v0 -> Optionals.fromOptional deannot v0 + Core.TermOptional v0 -> Optionals.withDefault deannot v0 _ -> deannot rec = case unwrapped of diff --git a/src/main/haskell/Hydra/Pg/Graphson/Coder.hs b/src/main/haskell/Hydra/Pg/Graphson/Coder.hs --- a/src/main/haskell/Hydra/Pg/Graphson/Coder.hs +++ b/src/main/haskell/Hydra/Pg/Graphson/Coder.hs @@ -92,7 +92,7 @@ -- | Create a JSON object from a list of key-value pairs, filtering out Nothing values toJsonObject :: [(String, (Maybe Model.Value))] -> Model.Value toJsonObject pairs = - Model.ValueObject (Optionals.cat (Lists.map (\p -> Optionals.map (\v -> (Pairs.first p, v)) (Pairs.second p)) pairs)) + Model.ValueObject (Optionals.givens (Lists.map (\p -> Optionals.map (\v -> (Pairs.first p, v)) (Pairs.second p)) pairs)) -- | Create a typed JSON object with @type and @value fields typedValueToJson :: String -> Model.Value -> Model.Value diff --git a/src/main/haskell/Hydra/Pg/Graphson/Utils.hs b/src/main/haskell/Hydra/Pg/Graphson/Utils.hs --- a/src/main/haskell/Hydra/Pg/Graphson/Utils.hs +++ b/src/main/haskell/Hydra/Pg/Graphson/Utils.hs @@ -102,7 +102,7 @@ encodeTermValue term = case (Strip.deannotateTerm term) of Core.TermLiteral v0 -> case v0 of - Core.LiteralBinary v1 -> Right (Syntax.ValueBinary (Literals.binaryToString v1)) + Core.LiteralBinary v1 -> Right (Syntax.ValueBinary (Literals.binaryToBase64 v1)) Core.LiteralBoolean v1 -> Right (Syntax.ValueBoolean v1) Core.LiteralFloat v1 -> case v1 of Core.FloatValueFloat32 v2 -> Right (Syntax.ValueFloat (Syntax.FloatValueFinite v2)) diff --git a/src/main/haskell/Hydra/Pg/Printing.hs b/src/main/haskell/Hydra/Pg/Printing.hs --- a/src/main/haskell/Hydra/Pg/Printing.hs +++ b/src/main/haskell/Hydra/Pg/Printing.hs @@ -50,8 +50,8 @@ outId = printValue (PgModel.edgeOut edge) inId = printValue (PgModel.edgeIn edge) props = - Strings.intercalate ", " (Lists.map (\p -> printProperty printValue (Pairs.first p) (Pairs.second p)) (Maps.toList (PgModel.edgeProperties edge))) - in (Strings.cat [ + Strings.join ", " (Lists.map (\p -> printProperty printValue (Pairs.first p) (Pairs.second p)) (Maps.toList (PgModel.edgeProperties edge))) + in (Strings.concat [ id, ": ", "(", @@ -77,20 +77,20 @@ let vertices = PgModel.lazyGraphVertices lg edges = PgModel.lazyGraphEdges lg - in (Strings.cat [ + in (Strings.concat [ "vertices:", - (Strings.cat (Lists.map (\v -> Strings.cat [ + (Strings.concat (Lists.map (\v -> Strings.concat [ "\n\t", (printVertex printValue v)]) vertices)), "\nedges:", - (Strings.cat (Lists.map (\e -> Strings.cat [ + (Strings.concat (Lists.map (\e -> Strings.concat [ "\n\t", (printEdge printValue e)]) edges))]) -- | Print a property using the provided value printer printProperty :: (t0 -> String) -> PgModel.PropertyKey -> t0 -> String printProperty printValue key value = - Strings.cat [ + Strings.concat [ PgModel.unPropertyKey key, ": ", (printValue value)] @@ -102,8 +102,8 @@ let label = PgModel.unVertexLabel (PgModel.vertexLabel vertex) id = printValue (PgModel.vertexId vertex) props = - Strings.intercalate ", " (Lists.map (\p -> printProperty printValue (Pairs.first p) (Pairs.second p)) (Maps.toList (PgModel.vertexProperties vertex))) - in (Strings.cat [ + Strings.join ", " (Lists.map (\p -> printProperty printValue (Pairs.first p) (Pairs.second p)) (Maps.toList (PgModel.vertexProperties vertex))) + in (Strings.concat [ id, ": (", label, diff --git a/src/main/haskell/Hydra/Pg/TermsToElements.hs b/src/main/haskell/Hydra/Pg/TermsToElements.hs --- a/src/main/haskell/Hydra/Pg/TermsToElements.hs +++ b/src/main/haskell/Hydra/Pg/TermsToElements.hs @@ -60,7 +60,7 @@ Core.TermLiteral (Core.LiteralString firstLit)]) (Eithers.bind (Eithers.mapList (\pp -> Eithers.map (\terms -> (Lists.map (\t -> termToString t) terms, (Pairs.second pp))) (evalPath cx (Pairs.first pp) term)) pairs) (\evaluated -> Right (Lists.map (\s -> Core.TermLiteral (Core.LiteralString s)) (Lists.foldl (\accum -> \ep -> let pStrs = Pairs.first ep litP = Pairs.second ep - in (Lists.concat (Lists.map (\pStr -> Lists.map (\a -> Strings.cat2 (Strings.cat2 a pStr) litP) accum) pStrs))) [ + in (Lists.concat (Lists.map (\pStr -> Lists.map (\a -> Strings.concat2 (Strings.concat2 a pStr) litP) accum) pStrs))) [ firstLit] evaluated)))) -- | Decode an edge label from a term @@ -133,11 +133,11 @@ term]) (case (Strip.deannotateTerm term) of Core.TermList v0 -> Eithers.map (\xs -> Lists.concat xs) (Eithers.mapList (evalStep cx step) v0) Core.TermOptional v0 -> Optionals.cases v0 (Right []) (\t -> evalStep cx step t) - Core.TermRecord v0 -> Optionals.cases (Maps.lookup (Core.Name step) (Resolution.fieldMap (Core.recordFields v0))) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 (Strings.cat2 "No such field " step) " in record")))) (\t -> Right [ + Core.TermRecord v0 -> Optionals.cases (Maps.lookup (Core.Name step) (Resolution.fieldMap (Core.recordFields v0))) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 (Strings.concat2 "No such field " step) " in record")))) (\t -> Right [ t]) Core.TermInject v0 -> Logic.ifElse (Equality.equal (Core.unName (Core.fieldName (Core.injectionField v0))) step) (evalStep cx step (Core.fieldTerm (Core.injectionField v0))) (Right []) Core.TermWrap v0 -> evalStep cx step (Core.wrappedTermBody v0) - _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "Can't traverse through term for step " step)))) + _ -> Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 "Can't traverse through term for step " step)))) -- | Extract a list from a term and apply a decoder to each element expectList :: t0 -> Graph.Graph -> (t0 -> Graph.Graph -> Core.Term -> Either Errors.Error t1) -> Core.Term -> Either Errors.Error [t1] @@ -179,13 +179,13 @@ parsePattern cx _g pat = let segments = Strings.splitOn "${" pat - firstLit = Optionals.fromOptional pat (Lists.maybeHead segments) + firstLit = Optionals.withDefault pat (Lists.head segments) rest = Lists.drop 1 segments parsed = Lists.map (\seg -> let parts = Strings.splitOn "}" seg - pathStr = Optionals.fromOptional "" (Lists.maybeHead parts) - litPart = Strings.intercalate "}" (Lists.drop 1 parts) + pathStr = Optionals.withDefault "" (Lists.head parts) + litPart = Strings.join "}" (Lists.drop 1 parts) pathSteps = Strings.splitOn "/" pathStr in (pathSteps, litPart)) rest in (Right (\cx_ -> \term -> applyPattern cx_ firstLit parsed term)) @@ -229,18 +229,18 @@ -- | Read a field from a map of fields by name readField :: t0 -> M.Map Core.Name t1 -> Core.Name -> (t1 -> Either Errors.Error t2) -> Either Errors.Error t2 readField cx fields fname fun = - Optionals.cases (Maps.lookup fname fields) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "no such field: " (Core.unName fname))))) fun + Optionals.cases (Maps.lookup fname fields) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 "no such field: " (Core.unName fname))))) fun -- | Read an injection (union value) from a term readInjection :: t0 -> Graph.Graph -> [(Core.Name, (Core.Term -> Either Errors.Error t1))] -> Core.Term -> Either Errors.Error t1 readInjection cx g cases encoded = Eithers.bind (ExtractCore.map (\k -> Eithers.map (\_n -> Core.Name _n) (ExtractCore.string g k)) (\_v -> Right _v) g encoded) (\mp -> let entries = Maps.toList mp - in (Optionals.cases (Lists.maybeHead entries) (Left (Errors.ErrorOther (Errors.OtherError "empty injection"))) (\f -> + in (Optionals.cases (Lists.head entries) (Left (Errors.ErrorOther (Errors.OtherError "empty injection"))) (\f -> let key = Pairs.first f val = Pairs.second f matching = Lists.filter (\c -> Equality.equal (Pairs.first c) key) cases - in (Optionals.cases (Lists.maybeHead matching) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "unexpected field: " (Core.unName key))))) (\m -> + in (Optionals.cases (Lists.head matching) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 "unexpected field: " (Core.unName key))))) (\m -> let handler = Pairs.second m in (handler val)))))) @@ -252,7 +252,7 @@ -- | Require exactly one result from a list-producing function requireUnique :: t0 -> String -> (t1 -> Either Errors.Error [t2]) -> t1 -> Either Errors.Error t2 requireUnique cx context fun term = - Eithers.bind (fun term) (\results -> Logic.ifElse (Lists.null results) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "No value found: " context)))) (Logic.ifElse (Equality.equal (Lists.length results) 1) (Optionals.cases (Lists.maybeHead results) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "Multiple values found: " context)))) (\x -> Right x)) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "Multiple values found: " context)))))) + Eithers.bind (fun term) (\results -> Logic.ifElse (Lists.null results) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 "No value found: " context)))) (Logic.ifElse (Equality.equal (Lists.length results) 1) (Optionals.cases (Lists.head results) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 "Multiple values found: " context)))) (\x -> Right x)) (Left (Errors.ErrorOther (Errors.OtherError (Strings.concat2 "Multiple values found: " context)))))) -- | Create an adapter that maps terms to property graph elements using a mapping specification termToElementsAdapter :: t0 -> Graph.Graph -> Mapping.Schema t1 t2 t3 Errors.Error -> Core.Type -> Either Errors.Error (Coders.Adapter Core.Type [PgModel.Label] Core.Term [PgModel.Element t3] Errors.Error) @@ -266,7 +266,7 @@ Coders.adapterCoder = Coders.Coder { Coders.coderEncode = (\_t -> Right []), Coders.coderDecode = (\_els -> Left (Errors.ErrorOther (Errors.OtherError "no corresponding element type")))}})) (\term -> Eithers.bind (expectList cx g decodeElementSpec term) (\specTerms -> Eithers.bind (Eithers.mapList (parseElementSpec cx g schema) specTerms) (\specs -> - let labels = Lists.nub (Lists.map (\_p -> Pairs.first _p) specs) + let labels = Lists.distinct (Lists.map (\_p -> Pairs.first _p) specs) encoders = Lists.map (\_p -> Pairs.second _p) specs in (Right (Coders.Adapter { Coders.adapterIsLossy = False, diff --git a/src/main/haskell/Hydra/Pg/Utils.hs b/src/main/haskell/Hydra/Pg/Utils.hs --- a/src/main/haskell/Hydra/Pg/Utils.hs +++ b/src/main/haskell/Hydra/Pg/Utils.hs @@ -118,7 +118,7 @@ (\x -> case x of PgModel.ElementVertex v0 -> Eithers.bind (Coders.coderDecode (Mapping.schemaVertexIds schema) (PgModel.vertexId v0)) (\term -> let labelJson = JsonModel.ValueString (PgModel.unVertexLabel (PgModel.vertexLabel v0)) - in (Eithers.map (\propsJson -> JsonModel.ValueObject (Optionals.cat [ + in (Eithers.map (\propsJson -> JsonModel.ValueObject (Optionals.givens [ Just ("label", labelJson), (Just ("id", (JsonModel.ValueString (PrintCore.term term)))), propsJson])) ((\pairs -> Logic.ifElse (Maps.null pairs) (Right Nothing) (Eithers.map (\p -> Just ("properties", (JsonModel.ValueObject p))) (Eithers.mapList (\pair -> @@ -127,7 +127,7 @@ in (Eithers.bind (Coders.coderDecode (Mapping.schemaPropertyValues schema) v) (\term2 -> Right (PgModel.unPropertyKey key, (JsonModel.ValueString (PrintCore.term term2)))))) (Maps.toList pairs)))) (PgModel.vertexProperties v0)))) PgModel.ElementEdge v0 -> Eithers.bind (Coders.coderDecode (Mapping.schemaEdgeIds schema) (PgModel.edgeId v0)) (\term -> Eithers.bind (Coders.coderDecode (Mapping.schemaVertexIds schema) (PgModel.edgeOut v0)) (\termOut -> Eithers.bind (Coders.coderDecode (Mapping.schemaVertexIds schema) (PgModel.edgeIn v0)) (\termIn -> let labelJson = JsonModel.ValueString (PgModel.unEdgeLabel (PgModel.edgeLabel v0)) - in (Eithers.map (\propsJson -> JsonModel.ValueObject (Optionals.cat [ + in (Eithers.map (\propsJson -> JsonModel.ValueObject (Optionals.givens [ Just ("label", labelJson), (Just ("id", (JsonModel.ValueString (PrintCore.term term)))), (Just ("out", (JsonModel.ValueString (PrintCore.term termOut)))), diff --git a/src/main/haskell/Hydra/Print/Error/Pg.hs b/src/main/haskell/Hydra/Print/Error/Pg.hs --- a/src/main/haskell/Hydra/Print/Error/Pg.hs +++ b/src/main/haskell/Hydra/Print/Error/Pg.hs @@ -43,18 +43,18 @@ invalidEdgeError :: Pg.InvalidEdgeError -> String invalidEdgeError e = case e of - Pg.InvalidEdgeErrorId v0 -> Strings.cat2 "invalid id: " (invalidValueError v0) - Pg.InvalidEdgeErrorInVertexLabel v0 -> Strings.cat2 "wrong in-vertex label: " (wrongVertexLabelError v0) + Pg.InvalidEdgeErrorId v0 -> Strings.concat2 "invalid id: " (invalidValueError v0) + Pg.InvalidEdgeErrorInVertexLabel v0 -> Strings.concat2 "wrong in-vertex label: " (wrongVertexLabelError v0) Pg.InvalidEdgeErrorInVertexNotFound -> "in-vertex not found" Pg.InvalidEdgeErrorLabel v0 -> noSuchEdgeLabelError v0 - Pg.InvalidEdgeErrorOutVertexLabel v0 -> Strings.cat2 "wrong out-vertex label: " (wrongVertexLabelError v0) + Pg.InvalidEdgeErrorOutVertexLabel v0 -> Strings.concat2 "wrong out-vertex label: " (wrongVertexLabelError v0) Pg.InvalidEdgeErrorOutVertexNotFound -> "out-vertex not found" Pg.InvalidEdgeErrorProperty v0 -> invalidElementPropertyError v0 -- | Show an invalid element property error as a string invalidElementPropertyError :: Pg.InvalidElementPropertyError -> String invalidElementPropertyError e = - Strings.cat [ + Strings.concat [ "property ", (PgModel.unPropertyKey (Pg.invalidElementPropertyErrorKey e)), ": ", @@ -63,7 +63,7 @@ -- | Show an invalid graph edge error as a string, given a value printer invalidGraphEdgeError :: (t0 -> String) -> Pg.InvalidGraphEdgeError t0 -> String invalidGraphEdgeError printValue e = - Strings.cat [ + Strings.concat [ "edge ", (printValue (Pg.invalidGraphEdgeErrorId e)), ": ", @@ -79,7 +79,7 @@ -- | Show an invalid graph vertex error as a string, given a value printer invalidGraphVertexError :: (t0 -> String) -> Pg.InvalidGraphVertexError t0 -> String invalidGraphVertexError printValue e = - Strings.cat [ + Strings.concat [ "vertex ", (printValue (Pg.invalidGraphVertexErrorId e)), ": ", @@ -89,14 +89,14 @@ invalidPropertyError :: Pg.InvalidPropertyError -> String invalidPropertyError e = case e of - Pg.InvalidPropertyErrorInvalidValue v0 -> Strings.cat2 "invalid value: " (invalidValueError v0) - Pg.InvalidPropertyErrorMissingRequired v0 -> Strings.cat2 "missing required property: " (PgModel.unPropertyKey v0) - Pg.InvalidPropertyErrorUnexpectedKey v0 -> Strings.cat2 "unexpected property key: " (PgModel.unPropertyKey v0) + Pg.InvalidPropertyErrorInvalidValue v0 -> Strings.concat2 "invalid value: " (invalidValueError v0) + Pg.InvalidPropertyErrorMissingRequired v0 -> Strings.concat2 "missing required property: " (PgModel.unPropertyKey v0) + Pg.InvalidPropertyErrorUnexpectedKey v0 -> Strings.concat2 "unexpected property key: " (PgModel.unPropertyKey v0) -- | Show an invalid value error as a string invalidValueError :: Pg.InvalidValueError -> String invalidValueError e = - Strings.cat [ + Strings.concat [ "expected ", (Pg.invalidValueErrorExpectedType e), ", got ", @@ -106,28 +106,28 @@ invalidVertexError :: Pg.InvalidVertexError -> String invalidVertexError e = case e of - Pg.InvalidVertexErrorId v0 -> Strings.cat2 "invalid id: " (invalidValueError v0) + Pg.InvalidVertexErrorId v0 -> Strings.concat2 "invalid id: " (invalidValueError v0) Pg.InvalidVertexErrorLabel v0 -> noSuchVertexLabelError v0 Pg.InvalidVertexErrorProperty v0 -> invalidElementPropertyError v0 -- | Show a no-such-edge-label error as a string noSuchEdgeLabelError :: Pg.NoSuchEdgeLabelError -> String noSuchEdgeLabelError e = - Strings.cat [ + Strings.concat [ "no such edge label: ", (PgModel.unEdgeLabel (Pg.noSuchEdgeLabelErrorLabel e))] -- | Show a no-such-vertex-label error as a string noSuchVertexLabelError :: Pg.NoSuchVertexLabelError -> String noSuchVertexLabelError e = - Strings.cat [ + Strings.concat [ "no such vertex label: ", (PgModel.unVertexLabel (Pg.noSuchVertexLabelErrorLabel e))] -- | Show a wrong-vertex-label error as a string wrongVertexLabelError :: Pg.WrongVertexLabelError -> String wrongVertexLabelError e = - Strings.cat [ + Strings.concat [ "expected vertex label ", (PgModel.unVertexLabel (Pg.wrongVertexLabelErrorExpected e)), ", got ", diff --git a/src/main/haskell/Hydra/Tinkerpop/Language.hs b/src/main/haskell/Hydra/Tinkerpop/Language.hs --- a/src/main/haskell/Hydra/Tinkerpop/Language.hs +++ b/src/main/haskell/Hydra/Tinkerpop/Language.hs @@ -53,28 +53,28 @@ supportsLiterals = True supportsMaps = Features.dataTypeFeaturesSupportsMapValues vpFeatures literalVariants = - Sets.fromList (Optionals.cat [ + Sets.fromList (Optionals.givens [ cond Variants.LiteralVariantBinary (Features.dataTypeFeaturesSupportsByteArrayValues vpFeatures), (cond Variants.LiteralVariantBoolean (Features.dataTypeFeaturesSupportsBooleanValues vpFeatures)), (cond Variants.LiteralVariantFloat (Logic.or (Features.dataTypeFeaturesSupportsFloatValues vpFeatures) (Features.dataTypeFeaturesSupportsDoubleValues vpFeatures))), (cond Variants.LiteralVariantInteger (Logic.or (Features.dataTypeFeaturesSupportsIntegerValues vpFeatures) (Features.dataTypeFeaturesSupportsLongValues vpFeatures))), (cond Variants.LiteralVariantString (Features.dataTypeFeaturesSupportsStringValues vpFeatures))]) floatTypes = - Sets.fromList (Optionals.cat [ + Sets.fromList (Optionals.givens [ cond Core.FloatTypeFloat32 (Features.dataTypeFeaturesSupportsFloatValues vpFeatures), (cond Core.FloatTypeFloat64 (Features.dataTypeFeaturesSupportsDoubleValues vpFeatures))]) integerTypes = - Sets.fromList (Optionals.cat [ + Sets.fromList (Optionals.givens [ cond Core.IntegerTypeInt32 (Features.dataTypeFeaturesSupportsIntegerValues vpFeatures), (cond Core.IntegerTypeInt64 (Features.dataTypeFeaturesSupportsLongValues vpFeatures))]) termVariants = - Sets.fromList (Optionals.cat [ + Sets.fromList (Optionals.givens [ cond Variants.TermVariantList supportsLists, (cond Variants.TermVariantLiteral supportsLiterals), (cond Variants.TermVariantMap supportsMaps), (Optionals.pure Variants.TermVariantOptional)]) typeVariants = - Sets.fromList (Optionals.cat [ + Sets.fromList (Optionals.givens [ cond Variants.TypeVariantList supportsLists, (cond Variants.TypeVariantLiteral supportsLiterals), (cond Variants.TypeVariantMap supportsMaps), diff --git a/src/main/haskell/Hydra/Validate/Neo4j.hs b/src/main/haskell/Hydra/Validate/Neo4j.hs --- a/src/main/haskell/Hydra/Validate/Neo4j.hs +++ b/src/main/haskell/Hydra/Validate/Neo4j.hs @@ -11,6 +11,7 @@ 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.Ordering as Ordering import qualified Hydra.Overlay.Haskell.Lib.Pairs as Pairs import qualified Hydra.Overlay.Haskell.Lib.Sets as Sets import qualified Hydra.Neo4j.Model as Model @@ -46,9 +47,9 @@ payload = Pairs.second rp errs = Validation.validationResultErrors acc wrns = Validation.validationResultWarnings acc - in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Equality.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { + in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Ordering.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { Validation.validationResultErrors = (Lists.concat2 errs (Lists.singleton payload)), - Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Equality.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { + Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Ordering.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { Validation.validationResultErrors = errs, Validation.validationResultWarnings = (Lists.concat2 wrns (Lists.singleton payload))}) acc) acc))) @@ -60,9 +61,9 @@ payload = Pairs.second rp errs = Validation.validationResultErrors acc wrns = Validation.validationResultWarnings acc - in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Equality.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { + in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Ordering.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { Validation.validationResultErrors = (Lists.concat2 errs (Lists.singleton payload)), - Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Equality.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { + Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Ordering.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { Validation.validationResultErrors = errs, Validation.validationResultWarnings = (Lists.concat2 wrns (Lists.singleton payload))}) acc) acc))) @@ -210,7 +211,7 @@ Neo4j.propertyTypeErrorExpectedType = (Model.propertyTypeConstraintType v0), Neo4j.propertyTypeErrorValue = val})))))) Nothing] Model.ConstraintPropertyUniqueness _ -> []))) - in (Lists.foldl (\acc -> \guarded -> Logic.ifElse (Equality.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingNode p acc guarded)) (Validation.ValidationResult { + in (Lists.foldl (\acc -> \guarded -> Logic.ifElse (Ordering.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingNode p acc guarded)) (Validation.ValidationResult { Validation.validationResultErrors = [], Validation.validationResultWarnings = []}) (Lists.cons noMatchCheck matchChecks)) @@ -249,6 +250,6 @@ Neo4j.propertyTypeErrorExpectedType = (Model.propertyTypeConstraintType v0), Neo4j.propertyTypeErrorValue = val})))))) Nothing] Model.ConstraintPropertyUniqueness _ -> [])) - in (Lists.foldl (\acc -> \guarded -> Logic.ifElse (Equality.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingRelationship p acc guarded)) (Validation.ValidationResult { + in (Lists.foldl (\acc -> \guarded -> Logic.ifElse (Ordering.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingRelationship p acc guarded)) (Validation.ValidationResult { Validation.validationResultErrors = [], Validation.validationResultWarnings = []}) (Lists.cons noSuchTypeCheck (Lists.cons noPatternCheck propChecks))) diff --git a/src/main/haskell/Hydra/Validate/Pg.hs b/src/main/haskell/Hydra/Validate/Pg.hs --- a/src/main/haskell/Hydra/Validate/Pg.hs +++ b/src/main/haskell/Hydra/Validate/Pg.hs @@ -11,6 +11,7 @@ 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.Ordering as Ordering import qualified Hydra.Overlay.Haskell.Lib.Pairs as Pairs import qualified Hydra.Overlay.Haskell.Lib.Sets as Sets import qualified Hydra.Pg.Model as Model @@ -27,9 +28,9 @@ payload = Pairs.second rp errs = Validation.validationResultErrors acc wrns = Validation.validationResultWarnings acc - in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Equality.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { + in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Ordering.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { Validation.validationResultErrors = (Lists.concat2 errs (Lists.singleton payload)), - Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Equality.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { + Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Ordering.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { Validation.validationResultErrors = errs, Validation.validationResultWarnings = (Lists.concat2 wrns (Lists.singleton payload))}) acc) acc))) @@ -41,9 +42,9 @@ payload = Pairs.second rp errs = Validation.validationResultErrors acc wrns = Validation.validationResultWarnings acc - in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Equality.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { + in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Ordering.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { Validation.validationResultErrors = (Lists.concat2 errs (Lists.singleton payload)), - Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Equality.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { + Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Ordering.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { Validation.validationResultErrors = errs, Validation.validationResultWarnings = (Lists.concat2 wrns (Lists.singleton payload))}) acc) acc))) @@ -55,9 +56,9 @@ payload = Pairs.second rp errs = Validation.validationResultErrors acc wrns = Validation.validationResultWarnings acc - in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Equality.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { + in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Ordering.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { Validation.validationResultErrors = (Lists.concat2 errs (Lists.singleton payload)), - Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Equality.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { + Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Ordering.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { Validation.validationResultErrors = errs, Validation.validationResultWarnings = (Lists.concat2 wrns (Lists.singleton payload))}) acc) acc))) @@ -69,9 +70,9 @@ payload = Pairs.second rp errs = Validation.validationResultErrors acc wrns = Validation.validationResultWarnings acc - in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Equality.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { + in (Logic.ifElse (Sets.member ruleName (Validation.validationProfileErrorRules p)) (Logic.ifElse (Ordering.lt (Lists.length errs) (Validation.validationProfileMaxErrors p)) (Validation.ValidationResult { Validation.validationResultErrors = (Lists.concat2 errs (Lists.singleton payload)), - Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Equality.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { + Validation.validationResultWarnings = wrns}) acc) (Logic.ifElse (Sets.member ruleName (Validation.validationProfileWarningRules p)) (Logic.ifElse (Ordering.lt (Lists.length wrns) (Validation.validationProfileMaxWarnings p)) (Validation.ValidationResult { Validation.validationResultErrors = errs, Validation.validationResultWarnings = (Lists.concat2 wrns (Lists.singleton payload))}) acc) acc))) @@ -105,7 +106,7 @@ -- | Validate an edge against its EdgeType under the given ValidationProfile, returning a ValidationResult InvalidEdgeError. validateEdge :: Validation.ValidationProfile -> (t0 -> t1 -> Maybe Pg.InvalidValueError) -> Maybe (t1 -> Maybe Model.VertexLabel) -> Model.EdgeType t0 -> Model.Edge t1 -> Validation.ValidationResult Pg.InvalidEdgeError validateEdge p checkValue labelForVertexId typ el = - Lists.foldl (\acc -> \guarded -> Logic.ifElse (Equality.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingEdge p acc guarded)) (Validation.ValidationResult { + Lists.foldl (\acc -> \guarded -> Logic.ifElse (Ordering.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingEdge p acc guarded)) (Validation.ValidationResult { Validation.validationResultErrors = [], Validation.validationResultWarnings = []}) [ Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidEdgeError.label")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidEdgeError.label", f)) ( @@ -114,7 +115,7 @@ in (Logic.ifElse (Equality.equal (Model.unEdgeLabel actual) (Model.unEdgeLabel expected)) Nothing (Just (Pg.InvalidEdgeErrorLabel (Pg.NoSuchEdgeLabelError { Pg.noSuchEdgeLabelErrorLabel = actual})))))) Nothing, (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidEdgeError.id")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidEdgeError.id", f)) (Optionals.map (\err -> Pg.InvalidEdgeErrorId err) (checkValue (Model.edgeTypeId typ) (Model.edgeId el)))) Nothing), - (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidEdgeError.property")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidEdgeError.property", f)) (Optionals.map (\err -> Pg.InvalidEdgeErrorProperty err) (Lists.maybeHead (Validation.validationResultErrors (validateProperties p checkValue (Model.edgeTypeProperties typ) (Model.edgeProperties el)))))) Nothing), + (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidEdgeError.property")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidEdgeError.property", f)) (Optionals.map (\err -> Pg.InvalidEdgeErrorProperty err) (Lists.head (Validation.validationResultErrors (validateProperties p checkValue (Model.edgeTypeProperties typ) (Model.edgeProperties el)))))) Nothing), (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidEdgeError.outVertexNotFound")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidEdgeError.outVertexNotFound", f)) (Optionals.cases labelForVertexId Nothing (\f -> Optionals.cases (f (Model.edgeOut el)) (Just Pg.InvalidEdgeErrorOutVertexNotFound) (\_label -> Nothing)))) Nothing), (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidEdgeError.outVertexLabel")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidEdgeError.outVertexLabel", f)) (Optionals.cases labelForVertexId Nothing (\f -> Optionals.cases (f (Model.edgeOut el)) Nothing (\label -> Logic.ifElse (Equality.equal (Model.unVertexLabel label) (Model.unVertexLabel (Model.edgeTypeOut typ))) Nothing (Just (Pg.InvalidEdgeErrorOutVertexLabel (Pg.WrongVertexLabelError { Pg.wrongVertexLabelErrorExpected = (Model.edgeTypeOut typ), @@ -180,14 +181,14 @@ (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidPropertyError.invalidValue")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidPropertyError.invalidValue", f)) (Optionals.cases (Maps.lookup key m) Nothing (\typ -> Optionals.map (\err -> Pg.InvalidElementPropertyError { Pg.invalidElementPropertyErrorKey = key, Pg.invalidElementPropertyErrorError = (Pg.InvalidPropertyErrorInvalidValue err)}) (checkValue typ val)))) Nothing)]) - in (Lists.foldl (\acc -> \guarded -> Logic.ifElse (Equality.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingProperty p acc guarded)) (Validation.ValidationResult { + in (Lists.foldl (\acc -> \guarded -> Logic.ifElse (Ordering.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingProperty p acc guarded)) (Validation.ValidationResult { Validation.validationResultErrors = [], Validation.validationResultWarnings = []}) (Lists.concat2 missingChecks valueChecks)) -- | Validate a vertex against its VertexType under the given ValidationProfile, returning a ValidationResult InvalidVertexError. validateVertex :: Validation.ValidationProfile -> (t0 -> t1 -> Maybe Pg.InvalidValueError) -> Model.VertexType t0 -> Model.Vertex t1 -> Validation.ValidationResult Pg.InvalidVertexError validateVertex p checkValue typ el = - Lists.foldl (\acc -> \guarded -> Logic.ifElse (Equality.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingVertex p acc guarded)) (Validation.ValidationResult { + Lists.foldl (\acc -> \guarded -> Logic.ifElse (Ordering.gte (Lists.length (Validation.validationResultErrors acc)) (Validation.validationProfileMaxErrors p)) acc (appendFindingVertex p acc guarded)) (Validation.ValidationResult { Validation.validationResultErrors = [], Validation.validationResultWarnings = []}) [ Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidVertexError.label")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidVertexError.label", f)) ( @@ -196,4 +197,4 @@ in (Logic.ifElse (Equality.equal (Model.unVertexLabel actual) (Model.unVertexLabel expected)) Nothing (Just (Pg.InvalidVertexErrorLabel (Pg.NoSuchVertexLabelError { Pg.noSuchVertexLabelErrorLabel = actual})))))) Nothing, (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidVertexError.id")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidVertexError.id", f)) (Optionals.map (\err -> Pg.InvalidVertexErrorId err) (checkValue (Model.vertexTypeId typ) (Model.vertexId el)))) Nothing), - (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidVertexError.property")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidVertexError.property", f)) (Optionals.map (\err -> Pg.InvalidVertexErrorProperty err) (Lists.maybeHead (Validation.validationResultErrors (validateProperties p checkValue (Model.vertexTypeProperties typ) (Model.vertexProperties el)))))) Nothing)] + (Logic.ifElse (enabledPg p (Core.Name "hydra.error.pg.InvalidVertexError.property")) (Optionals.map (\f -> (Core.Name "hydra.error.pg.InvalidVertexError.property", f)) (Optionals.map (\err -> Pg.InvalidVertexErrorProperty err) (Lists.head (Validation.validationResultErrors (validateProperties p checkValue (Model.vertexTypeProperties typ) (Model.vertexProperties el)))))) Nothing)]