diff --git a/hydra-haskell.cabal b/hydra-haskell.cabal --- a/hydra-haskell.cabal +++ b/hydra-haskell.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hydra-haskell -version: 0.17.2 +version: 0.17.3 synopsis: Hydra's Haskell coder: emit Haskell source from Hydra modules 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". This package is Hydra's Haskell coder: it translates Hydra modules into Haskell source. The top-level entry point is moduleToHaskell (and moduleToHaskellModule for the structured AST). It builds on hydra-kernel. category: Data @@ -44,6 +44,6 @@ build-depends: base >=4.19.0 && <4.22 , containers >=0.6.7 && <0.8 - , hydra-kernel ==0.17.2 + , hydra-kernel ==0.17.3 , scientific >=0.3.7 && <0.4 default-language: Haskell2010 diff --git a/src/main/haskell/Hydra/Haskell/Coder.hs b/src/main/haskell/Hydra/Haskell/Coder.hs --- a/src/main/haskell/Hydra/Haskell/Coder.hs +++ b/src/main/haskell/Hydra/Haskell/Coder.hs @@ -84,7 +84,7 @@ -- | Generate a constant name for a field (e.g., '_TypeName_fieldName') constantForFieldName :: Core.Name -> Core.Name -> String constantForFieldName tname fname = - Strings.cat [ + Strings.concat [ "_", (Names.localNameOf tname), "_", @@ -92,7 +92,7 @@ -- | Generate a constant name for a type (e.g., '_TypeName') constantForTypeName :: Core.Name -> String -constantForTypeName tname = Strings.cat2 "_" (Names.localNameOf tname) +constantForTypeName tname = Strings.concat2 "_" (Names.localNameOf tname) -- | Construct a Haskell module from a Hydra module and its definitions constructModule :: Util.ModuleNames Syntax.ModuleName -> Packaging.Module -> [Packaging.Definition] -> t0 -> Graph.Graph -> Either Errors.Error Syntax.Module @@ -103,9 +103,9 @@ \namespace -> let raw = Packaging.unModuleName namespace parts = Strings.splitOn "." raw - in (Logic.ifElse (Logic.and (Logic.and (Equality.equal (Lists.length parts) 3) (Equality.equal (Lists.take 2 parts) [ + in (Logic.ifElse (Logic.and (Equality.equal (Lists.length parts) 3) (Equality.equal (Lists.take 2 parts) [ "hydra", - "lib"])) (Logic.not (Equality.equal raw "hydra.lib.defaults"))) (Strings.cat2 "hydra.overlay.haskell.lib." (Strings.intercalate "." (Lists.drop 2 parts))) raw) + "lib"])) (Strings.concat2 "hydra.overlay.haskell.lib." (Strings.join "." (Lists.drop 2 parts))) raw) createDeclarations = \def -> case def of Packaging.DefinitionType v0 -> @@ -114,8 +114,7 @@ in (toTypeDeclarationsFrom namespaces name typ cx g) Packaging.DefinitionTerm v0 -> Eithers.bind (toDataDeclaration namespaces v0 cx g) (\d -> Right [ d]) - importName = - \name -> Syntax.ModuleName (Strings.intercalate "." (Lists.map Formatting.capitalize (Strings.splitOn "." name))) + importName = \name -> Syntax.ModuleName (Strings.join "." (Lists.map Formatting.capitalize (Strings.splitOn "." name))) imports = Lists.concat2 domainImports standardImports domainImports = @@ -202,7 +201,7 @@ \fieldMap -> \field -> let fn = Core.caseAlternativeName field fun_ = Core.caseAlternativeHandler field - v0 = Strings.cat2 "v" (Literals.showInt32 depth) + v0 = Strings.concat2 "v" (Literals.showInt32 depth) raw = Core.TermApplication (Core.Application { Core.applicationFunction = fun_, @@ -252,7 +251,7 @@ encodeLiteral :: Core.Literal -> t0 -> Either Errors.Error Syntax.Expression encodeLiteral l cx = case l of - Core.LiteralBinary v0 -> Right (Utils.hsapp (Utils.hsvar "Literals.stringToBinary") (Utils.hslit (Syntax.LiteralString (Literals.binaryToString v0)))) + Core.LiteralBinary v0 -> Right (Utils.hsapp (Utils.hsvar "Literals.base64ToBinary") (Utils.hslit (Syntax.LiteralString (Literals.binaryToBase64 v0)))) Core.LiteralBoolean v0 -> Right (Utils.hsvar (Logic.ifElse v0 "True" "False")) Core.LiteralDecimal v0 -> Right (Utils.hsapp (Utils.hsvar "Literals.stringToDecimal") (Utils.hslit (Syntax.LiteralString (Literals.showDecimal v0)))) Core.LiteralFloat v0 -> case v0 of @@ -501,7 +500,7 @@ in (Eithers.bind (adaptTypeToHaskellAndEncode namespaces typ cx g) (\htyp -> Logic.ifElse (Lists.null assertPairs) (Right htyp) ( let encoded = Lists.map encodeAssertion assertPairs hassert = - Logic.ifElse (Equality.equal (Lists.length encoded) 1) (Optionals.fromOptional (Syntax.ConstraintTuple encoded) (Lists.maybeHead encoded)) (Syntax.ConstraintTuple encoded) + Logic.ifElse (Equality.equal (Lists.length encoded) 1) (Optionals.withDefault (Syntax.ConstraintTuple encoded) (Lists.head encoded)) (Syntax.ConstraintTuple encoded) in (Right (Syntax.TypeCtx (Syntax.ConstrainedType { Syntax.constrainedTypeCtx = hassert, Syntax.constrainedTypeType = htyp})))))) @@ -509,7 +508,7 @@ -- | Encode an unwrap term as a Haskell expression encodeUnwrap :: Util.ModuleNames Syntax.ModuleName -> Core.Name -> Either t0 Syntax.Expression encodeUnwrap namespaces name = - Right (Syntax.ExpressionVariable (Utils.elementReference namespaces (Names.qname (Optionals.fromOptional (Packaging.ModuleName "") (Names.moduleNameOf name)) (Utils.newtypeAccessorName name)))) + Right (Syntax.ExpressionVariable (Utils.elementReference namespaces (Names.qname (Optionals.withDefault (Packaging.ModuleName "") (Names.moduleNameOf name)) (Utils.newtypeAccessorName name)))) -- | Extend metadata by analyzing a term for standard import usage (bottom-up step function) extendMetaForTerm :: Environment.HaskellModuleMetadata -> Core.Term -> Environment.HaskellModuleMetadata @@ -727,7 +726,7 @@ let lname = Names.localNameOf elementName hname = Utils.simpleName lname declHead = - \name -> \vars_ -> Optionals.fromOptional (Syntax.DeclarationHeadSimple name) (Optionals.map (\p -> + \name -> \vars_ -> Optionals.withDefault (Syntax.DeclarationHeadSimple name) (Optionals.map (\p -> let h = Pairs.first p rest = Pairs.second p hvar = Syntax.Variable (Utils.simpleName (Core.unName h)) @@ -755,7 +754,7 @@ \fieldType -> let fname = Core.fieldTypeName fieldType ftype = Core.fieldTypeType fieldType - hname_ = Utils.simpleName (Strings.cat2 (Formatting.decapitalize lname_) (Formatting.capitalize (Core.unName fname))) + hname_ = Utils.simpleName (Strings.concat2 (Formatting.decapitalize lname_) (Formatting.capitalize (Core.unName fname))) in (Eithers.bind (adaptTypeToHaskellAndEncode namespaces ftype cx g) (\htype -> Eithers.bind (Annotations.getTypeDescription cx g ftype) (\comments -> Right (Syntax.Field { Syntax.fieldName = hname_, Syntax.fieldType = htype, @@ -774,9 +773,9 @@ Names.unqualifyName (Util.QualifiedName { Util.qualifiedNameModuleName = (Just (Pairs.first (Util.moduleNamesFocus namespaces))), Util.qualifiedNameLocal = name}) - in (Logic.ifElse (Sets.member tname boundNames_) (deconflict (Strings.cat2 name "_")) name) + in (Logic.ifElse (Sets.member tname boundNames_) (deconflict (Strings.concat2 name "_")) name) in (Eithers.bind (Annotations.getTypeDescription cx g ftype) (\comments -> - let nm = deconflict (Strings.cat2 (Formatting.capitalize lname_) (Formatting.capitalize (Core.unName fname))) + let nm = deconflict (Strings.concat2 (Formatting.capitalize lname_) (Formatting.capitalize (Core.unName fname))) in (Eithers.bind (Logic.ifElse (Equality.equal (Strip.deannotateType ftype) Core.TypeUnit) (Right []) (Eithers.bind (adaptTypeToHaskellAndEncode namespaces ftype cx g) (\htype -> Right [ htype]))) (\typeList -> Right (Syntax.ConstructorOrdinary (Syntax.PositionalConstructor { Syntax.positionalConstructorName = (Utils.simpleName nm), @@ -838,7 +837,7 @@ let typeName = \ns -> \name_ -> Names.qname ns (typeNameLocal name_) typeNameLocal = - \name_ -> Strings.cat [ + \name_ -> Strings.concat [ "_", (Names.localNameOf name_), "_type_"] @@ -869,11 +868,11 @@ let qname = Names.qualifyName vname mns = Util.qualifiedNameModuleName qname local = Util.qualifiedNameLocal qname - in (Optionals.map (\ns -> Core.TermVariable (Names.qname ns (Strings.cat [ + in (Optionals.map (\ns -> Core.TermVariable (Names.qname ns (Strings.concat [ "_", local, "_type_"]))) mns) - in (Optionals.fromOptional (recurse term) (Optionals.bind variantResult forType)) + in (Optionals.withDefault (recurse term) (Optionals.bind variantResult forType)) finalTerm = Rewriting.rewriteTerm rewrite rawTerm in (Eithers.bind (encodeTerm 0 namespaces finalTerm cx g) (\expr -> let rhs = Syntax.RightHandSide expr @@ -894,7 +893,7 @@ let constraintToName = \tcc -> case tcc of Core.TypeClassConstraintSimple v0 -> Just v0 - in (Optionals.cases maybeConstraints Maps.empty (\constraints -> Maps.map (\meta -> Sets.fromList (Optionals.cat (Lists.map constraintToName (Core.typeVariableConstraintsClasses meta)))) constraints)) + in (Optionals.cases maybeConstraints Maps.empty (\constraints -> Maps.map (\meta -> Sets.fromList (Optionals.givens (Lists.map constraintToName (Core.typeVariableConstraintsClasses meta)))) constraints)) -- | Whether to use the Hydra core import in generated modules useCoreImport :: Bool diff --git a/src/main/haskell/Hydra/Haskell/Serde.hs b/src/main/haskell/Hydra/Haskell/Serde.hs --- a/src/main/haskell/Hydra/Haskell/Serde.hs +++ b/src/main/haskell/Hydra/Haskell/Serde.hs @@ -29,6 +29,7 @@ import qualified Hydra.Overlay.Haskell.Lib.Literals as Literals import qualified Hydra.Overlay.Haskell.Lib.Logic as Logic import qualified Hydra.Overlay.Haskell.Lib.Optionals as Optionals +import qualified Hydra.Overlay.Haskell.Lib.Ordering as Ordering import qualified Hydra.Overlay.Haskell.Lib.Strings as Strings import qualified Hydra.Names as Names import qualified Hydra.Packaging as Packaging @@ -243,14 +244,14 @@ haddockEntityRef :: Packaging.EntityReference -> String haddockEntityRef x = case x of - Packaging.EntityReferenceDefinition v0 -> Strings.cat2 "'" (Strings.cat2 (case v0 of + Packaging.EntityReferenceDefinition v0 -> Strings.concat2 "'" (Strings.concat2 (case v0 of Packaging.DefinitionReferencePrimitive v1 -> Names.localNameOf v1 Packaging.DefinitionReferenceTerm v1 -> Names.localNameOf v1 Packaging.DefinitionReferenceType v1 -> Names.localNameOf v1) "'") Packaging.EntityReferenceModule v0 -> Packaging.unModuleName v0 Packaging.EntityReferencePackage v0 -> Packaging.unPackageName v0 - Packaging.EntityReferenceTermExpr v0 -> Strings.cat2 "@" (Strings.cat2 v0 "@") - Packaging.EntityReferenceTypeExpr v0 -> Strings.cat2 "@" (Strings.cat2 v0 "@") + Packaging.EntityReferenceTermExpr v0 -> Strings.concat2 "@" (Strings.concat2 v0 "@") + Packaging.EntityReferenceTypeExpr v0 -> Strings.concat2 "@" (Strings.concat2 v0 "@") -- | Convert an if-then-else expression to an AST expression ifExpressionToExpr :: Syntax.IfExpression -> Ast.Expr @@ -289,11 +290,11 @@ Syntax.ImportSpecHiding v0 -> Serialization.spaceSep (Lists.cons (Serialization.cst "hiding ") [ Serialization.parens (Serialization.commaSep Serialization.inlineStyle (Lists.map namedImportExportToExpr v0))]) parts = - Optionals.cat [ + Optionals.givens [ Just (Serialization.cst "import"), (Logic.ifElse qual (Just (Serialization.cst "qualified")) Nothing), (Just (Serialization.cst name)), - (Optionals.map (\m -> Serialization.cst (Strings.cat2 "as " (Syntax.unModuleName m))) mod), + (Optionals.map (\m -> Serialization.cst (Strings.concat2 "as " (Syntax.unModuleName m))) mod), (Optionals.map hidingSec mspec)] in (Serialization.spaceSep parts) @@ -312,21 +313,21 @@ literalToExpr lit = let parensIfNeg = - \b -> \e -> Logic.ifElse b (Strings.cat [ + \b -> \e -> Logic.ifElse b (Strings.concat [ "(", e, ")"]) e showFloat = \showFn -> \v -> let raw = showFn v - in (Logic.ifElse (Equality.equal raw "NaN") "(0/0)" (Logic.ifElse (Equality.equal raw "Infinity") "(1/0)" (Logic.ifElse (Equality.equal raw "-Infinity") "(-(1/0))" (parensIfNeg (Equality.equal (Optionals.fromOptional 0 (Strings.maybeCharAt 0 raw)) 45) raw)))) + in (Logic.ifElse (Equality.equal raw "NaN") "(0/0)" (Logic.ifElse (Equality.equal raw "Infinity") "(1/0)" (Logic.ifElse (Equality.equal raw "-Infinity") "(-(1/0))" (parensIfNeg (Equality.equal (Optionals.withDefault 0 (Strings.charAt 0 raw)) 45) raw)))) in (Serialization.cst (case lit of - Syntax.LiteralChar v0 -> Literals.showString (Literals.showUint16 v0) + Syntax.LiteralChar v0 -> Literals.printString (Literals.showUint16 v0) Syntax.LiteralDouble v0 -> showFloat (\v -> Literals.showFloat64 v) v0 Syntax.LiteralFloat v0 -> showFloat (\v -> Literals.showFloat32 v) v0 - Syntax.LiteralInt v0 -> parensIfNeg (Equality.lt v0 0) (Literals.showInt32 v0) - Syntax.LiteralInteger v0 -> parensIfNeg (Equality.lt v0 0) (Literals.showBigint v0) - Syntax.LiteralString v0 -> Literals.showString v0)) + Syntax.LiteralInt v0 -> parensIfNeg (Ordering.lt v0 0) (Literals.showInt32 v0) + Syntax.LiteralInteger v0 -> parensIfNeg (Ordering.lt v0 0) (Literals.showBigint v0) + Syntax.LiteralString v0 -> Literals.printString v0)) -- | Convert a local binding to an AST expression localBindingToExpr :: Syntax.LocalBinding -> Ast.Expr @@ -372,7 +373,7 @@ nameToExpr :: Syntax.Name -> Ast.Expr nameToExpr name = Serialization.cst (case name of - Syntax.NameImplicit v0 -> Strings.cat2 "?" (writeQualifiedName v0) + Syntax.NameImplicit v0 -> Strings.concat2 "?" (writeQualifiedName v0) Syntax.NameNormal v0 -> writeQualifiedName v0) -- | Convert an import/export specification to an AST expression @@ -416,12 +417,12 @@ -- | Convert a string to Haddock documentation comments. Empty source lines emit `-- |` (no trailing space) so blank doc lines don't carry trailing whitespace into the generated file. Doc-escape tags are rendered as Haddock links via haddockEntityRef. toHaskellComments :: String -> String toHaskellComments c = - Strings.intercalate "\n" (Lists.map (\s -> Logic.ifElse (Equality.equal s "") "-- |" (Strings.cat2 "-- | " s)) (Strings.lines (PrintDocs.renderDocStringWith haddockEntityRef c))) + Strings.join "\n" (Lists.map (\s -> Logic.ifElse (Equality.equal s "") "-- |" (Strings.concat2 "-- | " s)) (Strings.lines (PrintDocs.renderDocStringWith haddockEntityRef c))) -- | Convert a string to simple line comments. Empty source lines emit `--` (no trailing space) for the same reason as toHaskellComments. toSimpleComments :: String -> String toSimpleComments c = - Strings.intercalate "\n" (Lists.map (\s -> Logic.ifElse (Equality.equal s "") "--" (Strings.cat2 "-- " s)) (Strings.lines c)) + Strings.join "\n" (Lists.map (\s -> Logic.ifElse (Equality.equal s "") "--" (Strings.concat2 "-- " s)) (Strings.lines c)) -- | Convert a type signature to an AST expression typeSignatureToExpr :: Syntax.TypeSignature -> Ast.Expr @@ -502,4 +503,4 @@ h = \namePart -> Syntax.unNamePart namePart allParts = Lists.concat2 (Lists.map h qualifiers) [ h unqual] - in (Strings.intercalate "." allParts) + in (Strings.join "." allParts) diff --git a/src/main/haskell/Hydra/Haskell/Testing.hs b/src/main/haskell/Hydra/Haskell/Testing.hs --- a/src/main/haskell/Hydra/Haskell/Testing.hs +++ b/src/main/haskell/Hydra/Haskell/Testing.hs @@ -65,9 +65,9 @@ addNamespacesToNamespaces :: Util.ModuleNames Syntax.ModuleName -> S.Set Core.Name -> Util.ModuleNames Syntax.ModuleName addNamespacesToNamespaces ns0 names = - let newNamespaces = Sets.fromList (Optionals.cat (Lists.map Names.moduleNameOf (Sets.toList names))) + let newNamespaces = Sets.fromList (Optionals.givens (Lists.map Names.moduleNameOf (Sets.toList names))) toModuleName = - \namespace -> Syntax.ModuleName (Formatting.capitalize (Optionals.fromOptional (Packaging.unModuleName namespace) (Lists.maybeLast (Strings.splitOn "." (Packaging.unModuleName namespace))))) + \namespace -> Syntax.ModuleName (Formatting.capitalize (Optionals.withDefault (Packaging.unModuleName namespace) (Lists.last (Strings.splitOn "." (Packaging.unModuleName namespace))))) newMappings = Maps.fromList (Lists.map (\ns_ -> (ns_, (toModuleName ns_))) (Sets.toList newNamespaces)) in Util.ModuleNames { Util.moduleNamesFocus = (Util.moduleNamesFocus ns0), @@ -103,7 +103,7 @@ buildTestModule testModule testGroup testBody namespaces = let ns_ = Packaging.moduleName testModule - specNs = Packaging.ModuleName (Strings.cat2 (Packaging.unModuleName ns_) "Spec") + specNs = Packaging.ModuleName (Strings.concat2 (Packaging.unModuleName ns_) "Spec") moduleNameString = namespaceToModuleName specNs groupName_ = Testing.testGroupName testGroup domainImports = findHaskellImports namespaces Sets.empty @@ -117,13 +117,13 @@ "import qualified Data.Maybe as Y"] allImports = Lists.concat2 standardImports domainImports header = - Strings.intercalate "\n" (Lists.concat [ + Strings.join "\n" (Lists.concat [ [ - Strings.cat2 "-- " Constants.warningAutoGeneratedFile, + Strings.concat2 "-- " Constants.warningAutoGeneratedFile, ""], [ "", - (Strings.cat [ + (Strings.concat [ "module ", moduleNameString, " where"]), @@ -132,11 +132,11 @@ [ "", "spec :: H.Spec", - (Strings.cat [ + (Strings.concat [ "spec = H.describe ", - (Literals.showString groupName_), + (Literals.printString groupName_), " $ do"])]]) - in (Strings.cat [ + in (Strings.concat [ header, "\n", testBody, @@ -167,10 +167,10 @@ let mapping_ = Util.moduleNamesMapping namespaces filtered = - Maps.filterWithKey (\ns_ -> \_v -> Logic.not (Equality.equal (Optionals.fromOptional "" (Lists.maybeHead (Strings.splitOn "hydra.test." (Packaging.unModuleName ns_)))) "")) mapping_ - in (Lists.map (\entry -> Strings.cat [ + Maps.filterWithKey (\ns_ -> \_v -> Logic.not (Equality.equal (Optionals.withDefault "" (Lists.head (Strings.splitOn "hydra.test." (Packaging.unModuleName ns_)))) "")) mapping_ + in (Lists.map (\entry -> Strings.concat [ "import qualified ", - (Strings.intercalate "." (Lists.map Formatting.capitalize (Strings.splitOn "." (Packaging.unModuleName (Pairs.first entry))))), + (Strings.join "." (Lists.map Formatting.capitalize (Strings.splitOn "." (Packaging.unModuleName (Pairs.first entry))))), " as ", (Syntax.unModuleName (Pairs.second entry))]) (Maps.toList filtered)) @@ -191,15 +191,15 @@ actual_ = Testing.universalTestCaseActual universal () expected_ = Testing.universalTestCaseExpected universal () in (Right [ - Strings.cat [ + Strings.concat [ "H.it ", - (Literals.showString name_), + (Literals.printString name_), " $ H.shouldBe"], - (Strings.cat [ + (Strings.concat [ " (", actual_, ")"]), - (Strings.cat [ + (Strings.concat [ " (", expected_, ")"])]) @@ -210,7 +210,7 @@ Eithers.map (\testBody -> let testModuleContent = buildTestModule testModule testGroup testBody namespaces ns_ = Packaging.moduleName testModule - specNs = Packaging.ModuleName (Strings.cat2 (Packaging.unModuleName ns_) "Spec") + specNs = Packaging.ModuleName (Strings.concat2 (Packaging.unModuleName ns_) "Spec") filePath = Names.moduleNameToFilePath Util.CaseConventionPascal (File.FileExtension "hs") specNs in (filePath, testModuleContent)) (generateTestGroupHierarchy 1 testGroup) @@ -222,21 +222,21 @@ subgroups = Testing.testGroupSubgroups testGroup indent = Strings.fromList (Lists.replicate (Math.mul depth 2) 32) in (Eithers.bind (Eithers.mapList (\tc -> generateTestCase depth tc) cases_) (\testCaseLinesRaw -> - let testCaseLines = Lists.map (\lines_ -> Lists.map (\line -> Strings.cat2 indent line) lines_) testCaseLinesRaw - testCasesStr = Strings.intercalate "\n" (Lists.concat testCaseLines) - in (Eithers.map (\subgroupsStr -> Strings.cat [ + let testCaseLines = Lists.map (\lines_ -> Lists.map (\line -> Strings.concat2 indent line) lines_) testCaseLinesRaw + testCasesStr = Strings.join "\n" (Lists.concat testCaseLines) + in (Eithers.map (\subgroupsStr -> Strings.concat [ testCasesStr, (Logic.ifElse (Logic.or (Equality.equal testCasesStr "") (Equality.equal subgroupsStr "")) "" "\n"), - subgroupsStr]) (Eithers.map (\blocks -> Strings.intercalate "\n" blocks) (Eithers.mapList (\subgroup -> + subgroupsStr]) (Eithers.map (\blocks -> Strings.join "\n" blocks) (Eithers.mapList (\subgroup -> let groupName_ = Testing.testGroupName subgroup - in (Eithers.map (\content -> Strings.cat [ + in (Eithers.map (\content -> Strings.concat [ indent, "H.describe ", - (Literals.showString groupName_), + (Literals.printString groupName_), " $ do\n", content]) (generateTestGroupHierarchy (Math.add depth 1) subgroup))) subgroups))))) -- | Convert namespace to Haskell module name namespaceToModuleName :: Packaging.ModuleName -> String namespaceToModuleName ns_ = - Strings.intercalate "." (Lists.map Formatting.capitalize (Strings.splitOn "." (Packaging.unModuleName ns_))) + Strings.join "." (Lists.map Formatting.capitalize (Strings.splitOn "." (Packaging.unModuleName ns_))) diff --git a/src/main/haskell/Hydra/Haskell/Utils.hs b/src/main/haskell/Hydra/Haskell/Utils.hs --- a/src/main/haskell/Hydra/Haskell/Utils.hs +++ b/src/main/haskell/Hydra/Haskell/Utils.hs @@ -28,6 +28,7 @@ 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.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 @@ -74,7 +75,7 @@ mns = Util.qualifiedNameModuleName qname in (Optionals.cases (Util.qualifiedNameModuleName qname) (simpleName local) (\ns -> Optionals.cases (Maps.lookup ns namespacesMap) (simpleName local) (\mn -> let aliasStr = Syntax.unModuleName mn - in (Logic.ifElse (Equality.equal ns gname) (simpleName escLocal) (rawName (Strings.cat [ + in (Logic.ifElse (Equality.equal ns gname) (simpleName escLocal) (rawName (Strings.concat [ aliasStr, ".", (sanitizeHaskellName local)])))))) @@ -107,7 +108,7 @@ namespacesForModule mod cx g = Eithers.bind (Analysis.moduleDependencyModuleNames cx g True True True True mod) (\termNss -> let knownNss = - Sets.fromList (Optionals.cat (Lists.map Names.moduleNameOf (Lists.concat2 (Maps.keys (Graph.graphSchemaTypes g)) (Maps.keys (Graph.graphBoundTerms g))))) + Sets.fromList (Optionals.givens (Lists.map Names.moduleNameOf (Lists.concat2 (Maps.keys (Graph.graphSchemaTypes g)) (Maps.keys (Graph.graphBoundTerms g))))) rawDeclaredNss = Sets.fromList (Lists.map (\dep -> Packaging.moduleDependencyModule dep) (Packaging.moduleDependencies mod)) declaredNss = Sets.fromList (Lists.filter (\ns -> Sets.member ns knownNss) (Sets.toList rawDeclaredNss)) ownNs = Packaging.moduleName mod @@ -119,16 +120,16 @@ let dropCount = Math.sub (Lists.length segs) n suffix = Lists.drop dropCount segs capitalizedSuffix = Lists.map Formatting.capitalize suffix - in (Syntax.ModuleName (Strings.cat capitalizedSuffix)) + in (Syntax.ModuleName (Strings.concat capitalizedSuffix)) toModuleName = \namespace -> aliasFromSuffix (segmentsOf namespace) 1 focusPair = (ns, (toModuleName ns)) nssAsList = Sets.toList nss segsMap = Maps.fromList (Lists.map (\nm -> (nm, (segmentsOf nm))) nssAsList) maxSegs = - Lists.foldl (\a -> \b -> Logic.ifElse (Equality.gt a b) a b) 1 (Lists.map (\nm -> Lists.length (segmentsOf nm)) nssAsList) + Lists.foldl (\a -> \b -> Logic.ifElse (Ordering.gt a b) a b) 1 (Lists.map (\nm -> Lists.length (segmentsOf nm)) nssAsList) initialState = Maps.fromList (Lists.map (\nm -> (nm, 1)) nssAsList) - segsFor = \nm -> Optionals.fromOptional [] (Maps.lookup nm segsMap) - takenFor = \state -> \nm -> Optionals.fromOptional 1 (Maps.lookup nm state) + segsFor = \nm -> Optionals.withDefault [] (Maps.lookup nm segsMap) + takenFor = \state -> \nm -> Optionals.withDefault 1 (Maps.lookup nm state) growStep = \state -> \_ign -> let aliasEntries = @@ -141,29 +142,29 @@ aliasCounts = Lists.foldl (\m -> \e -> let k = Pairs.second (Pairs.second (Pairs.second e)) - in (Maps.insert k (Math.add 1 (Optionals.fromOptional 0 (Maps.lookup k m))) m)) Maps.empty aliasEntries + in (Maps.insert k (Math.add 1 (Optionals.withDefault 0 (Maps.lookup k m))) m)) Maps.empty aliasEntries aliasMinSegs = Lists.foldl (\m -> \e -> let segCount = Pairs.first (Pairs.second (Pairs.second e)) k = Pairs.second (Pairs.second (Pairs.second e)) existing = Maps.lookup k m - in (Maps.insert k (Optionals.cases existing segCount (\prev -> Logic.ifElse (Equality.lt segCount prev) segCount prev)) m)) Maps.empty aliasEntries + in (Maps.insert k (Optionals.cases existing segCount (\prev -> Logic.ifElse (Ordering.lt segCount prev) segCount prev)) m)) Maps.empty aliasEntries aliasMinSegsCount = Lists.foldl (\m -> \e -> let segCount = Pairs.first (Pairs.second (Pairs.second e)) k = Pairs.second (Pairs.second (Pairs.second e)) - minSegs = Optionals.fromOptional segCount (Maps.lookup k aliasMinSegs) - in (Logic.ifElse (Equality.equal segCount minSegs) (Maps.insert k (Math.add 1 (Optionals.fromOptional 0 (Maps.lookup k m))) m) m)) Maps.empty aliasEntries + minSegs = Optionals.withDefault segCount (Maps.lookup k aliasMinSegs) + in (Logic.ifElse (Equality.equal segCount minSegs) (Maps.insert k (Math.add 1 (Optionals.withDefault 0 (Maps.lookup k m))) m) m)) Maps.empty aliasEntries in (Maps.fromList (Lists.map (\e -> let nm = Pairs.first e n = Pairs.first (Pairs.second e) segCount = Pairs.first (Pairs.second (Pairs.second e)) aliasStr = Pairs.second (Pairs.second (Pairs.second e)) - count = Optionals.fromOptional 0 (Maps.lookup aliasStr aliasCounts) - minSegs = Optionals.fromOptional segCount (Maps.lookup aliasStr aliasMinSegs) - minSegsCount = Optionals.fromOptional 0 (Maps.lookup aliasStr aliasMinSegsCount) + count = Optionals.withDefault 0 (Maps.lookup aliasStr aliasCounts) + minSegs = Optionals.withDefault segCount (Maps.lookup aliasStr aliasMinSegs) + minSegsCount = Optionals.withDefault 0 (Maps.lookup aliasStr aliasMinSegsCount) canGrow = - Logic.and (Equality.gt count 1) (Logic.and (Equality.gt segCount n) (Logic.or (Equality.gt segCount minSegs) (Equality.gt minSegsCount 1))) + Logic.and (Ordering.gt count 1) (Logic.and (Ordering.gt segCount n) (Logic.or (Ordering.gt segCount minSegs) (Ordering.gt minSegsCount 1))) newN = Logic.ifElse canGrow (Math.add n 1) n in (nm, newN)) aliasEntries)) finalState = Lists.foldl growStep initialState (Lists.replicate maxSegs ()) @@ -174,7 +175,7 @@ -- | Generate an accessor name for a newtype wrapper (e.g., 'unFoo' for Foo) newtypeAccessorName :: Core.Name -> String -newtypeAccessorName name = Strings.cat2 "un" (Names.localNameOf name) +newtypeAccessorName name = Strings.concat2 "un" (Names.localNameOf name) -- | Create a raw Haskell name from a string without sanitization rawName :: String -> Syntax.Name @@ -193,7 +194,7 @@ typeNameStr = typeNameForRecord sname decapitalized = Formatting.decapitalize typeNameStr capitalized = Formatting.capitalize fnameStr - nm = Strings.cat2 decapitalized capitalized + nm = Strings.concat2 decapitalized capitalized qualName = Util.QualifiedName { Util.qualifiedNameModuleName = ns, @@ -233,7 +234,7 @@ Syntax.qualifiedNameQualifiers = [], Syntax.qualifiedNameUnqualified = (Syntax.NamePart "")})) app = - \l -> Optionals.fromOptional dummyType (Optionals.map (\p -> Logic.ifElse (Lists.null (Pairs.second p)) (Pairs.first p) (Syntax.TypeApplication (Syntax.ApplicationType { + \l -> Optionals.withDefault dummyType (Optionals.map (\p -> Logic.ifElse (Lists.null (Pairs.second p)) (Pairs.first p) (Syntax.TypeApplication (Syntax.ApplicationType { Syntax.applicationTypeContext = (app (Pairs.second p)), Syntax.applicationTypeArgument = (Pairs.first p)}))) (Lists.uncons l)) in (app (Lists.reverse types)) @@ -244,7 +245,7 @@ let snameStr = Core.unName sname parts = Strings.splitOn "." snameStr - in (Optionals.fromOptional snameStr (Lists.maybeLast parts)) + in (Optionals.withDefault snameStr (Lists.last parts)) -- | Generate a Haskell name for a union variant constructor, with disambiguation unionFieldReference :: S.Set Core.Name -> Util.ModuleNames Syntax.ModuleName -> Core.Name -> Core.Name -> Syntax.Name @@ -262,8 +263,8 @@ Names.unqualifyName (Util.QualifiedName { Util.qualifiedNameModuleName = ns, Util.qualifiedNameLocal = name}) - in (Logic.ifElse (Sets.member tname boundNames) (deconflict (Strings.cat2 name "_")) name) - nm = deconflict (Strings.cat2 capitalizedTypeName capitalizedFieldName) + in (Logic.ifElse (Sets.member tname boundNames) (deconflict (Strings.concat2 name "_")) name) + nm = deconflict (Strings.concat2 capitalizedTypeName capitalizedFieldName) qualName = Util.QualifiedName { Util.qualifiedNameModuleName = ns,