hydra-haskell 0.17.2 → 0.17.3
raw patch · 5 files changed
+80/−79 lines, 5 filesdep ~hydra-kernelPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hydra-kernel
API changes (from Hackage documentation)
Files
- hydra-haskell.cabal +2/−2
- src/main/haskell/Hydra/Haskell/Coder.hs +17/−18
- src/main/haskell/Hydra/Haskell/Serde.hs +16/−15
- src/main/haskell/Hydra/Haskell/Testing.hs +24/−24
- src/main/haskell/Hydra/Haskell/Utils.hs +21/−20
hydra-haskell.cabal view
@@ -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
src/main/haskell/Hydra/Haskell/Coder.hs view
@@ -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
src/main/haskell/Hydra/Haskell/Serde.hs view
@@ -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)
src/main/haskell/Hydra/Haskell/Testing.hs view
@@ -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_)))
src/main/haskell/Hydra/Haskell/Utils.hs view
@@ -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,