From 0ce32ec40cc6357bb0892247d0e6936799dc39b5 Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Wed, 11 Dec 2024 18:45:16 +0000 Subject: [PATCH] Merge remote-tracking branch 'origin/master' into elm-serialize --- README.md | 36 +++ src/Builder/Build.elm | 172 ++++++------ src/Builder/Deps/Diff.elm | 48 ++-- src/Builder/Deps/Registry.elm | 22 +- src/Builder/Deps/Solver.elm | 99 ++++--- src/Builder/Elm/Details.elm | 214 ++++++++------- src/Builder/Elm/Outline.elm | 20 +- src/Builder/Generate.elm | 34 +-- src/Builder/Reporting/Exit.elm | 6 +- src/Compiler/AST/Canonical.elm | 26 +- src/Compiler/AST/Optimized.elm | 72 ++--- src/Compiler/AST/Utils/Shader.elm | 8 +- src/Compiler/AST/Utils/Type.elm | 8 +- src/Compiler/Canonicalize/Effects.elm | 19 +- src/Compiler/Canonicalize/Environment.elm | 33 +-- .../Canonicalize/Environment/Dups.elm | 22 +- .../Canonicalize/Environment/Foreign.elm | 82 +++--- .../Canonicalize/Environment/Local.elm | 48 ++-- src/Compiler/Canonicalize/Expression.elm | 51 ++-- src/Compiler/Canonicalize/Module.elm | 54 ++-- src/Compiler/Canonicalize/Pattern.elm | 2 +- src/Compiler/Canonicalize/Type.elm | 12 +- src/Compiler/Compile.elm | 10 +- src/Compiler/Data/Map/Utils.elm | 14 +- src/Compiler/Elm/Compiler/Type/Extract.elm | 44 +-- src/Compiler/Elm/Docs.elm | 78 +++--- src/Compiler/Elm/Interface.elm | 43 +-- src/Compiler/Elm/Kernel.elm | 38 +-- src/Compiler/Elm/Licenses.elm | 10 +- src/Compiler/Elm/ModuleName.elm | 6 + src/Compiler/Elm/Package.elm | 4 +- src/Compiler/Elm/Version.elm | 6 + src/Compiler/Generate/JavaScript.elm | 28 +- .../Generate/JavaScript/Expression.elm | 22 +- src/Compiler/Generate/JavaScript/Name.elm | 28 +- src/Compiler/Generate/Mode.elm | 12 +- src/Compiler/Json/Decode.elm | 18 +- src/Compiler/Json/Encode.elm | 17 +- src/Compiler/Nitpick/Debug.elm | 4 +- src/Compiler/Nitpick/PatternMatches.elm | 18 +- src/Compiler/Optimize/Case.elm | 20 +- src/Compiler/Optimize/DecisionTree.elm | 59 +--- src/Compiler/Optimize/Expression.elm | 10 +- src/Compiler/Optimize/Module.elm | 82 +++--- src/Compiler/Optimize/Names.elm | 36 +-- src/Compiler/Optimize/Port.elm | 6 +- src/Compiler/Parse/Shader.elm | 6 +- src/Compiler/Parse/Symbol.elm | 18 +- src/Compiler/Parse/Variable.elm | 8 +- src/Compiler/Reporting/Error/Canonicalize.elm | 22 +- src/Compiler/Reporting/Error/Import.elm | 10 +- src/Compiler/Reporting/Error/Type.elm | 10 +- src/Compiler/Reporting/Render/Code.elm | 4 +- .../Reporting/Render/Type/Localizer.elm | 20 +- src/Compiler/Reporting/Result.elm | 13 +- src/Compiler/Serialize.elm | 12 +- src/Compiler/Type/Constrain/Expression.elm | 60 ++--- src/Compiler/Type/Constrain/Module.elm | 26 +- src/Compiler/Type/Constrain/Pattern.elm | 18 +- src/Compiler/Type/Error.elm | 45 ++-- src/Compiler/Type/Instantiate.elm | 12 +- src/Compiler/Type/Occurs.elm | 2 +- src/Compiler/Type/Solve.elm | 52 ++-- src/Compiler/Type/Type.elm | 38 +-- src/Compiler/Type/Unify.elm | 32 +-- src/Control/Monad/State/TypeCheck/Strict.elm | 13 +- src/Data/Map.elm | 253 +++++++----------- src/Data/Set.elm | 82 +++--- src/System/IO.elm | 70 ++--- src/System/TypeCheck/IO.elm | 21 +- src/Terminal/Diff.elm | 22 +- src/Terminal/Init.elm | 16 +- src/Terminal/Install.elm | 74 ++--- src/Terminal/Repl.elm | 21 +- src/Terminal/Terminal/Helpers.elm | 4 +- src/Utils/Main.elm | 150 ++++++----- 76 files changed, 1385 insertions(+), 1450 deletions(-) diff --git a/README.md b/README.md index 8651fde61..9eb366fad 100644 --- a/README.md +++ b/README.md @@ -30,6 +30,16 @@ This phase will foster a unified ecosystem that adapts to the needs of its users Our ultimate goal is to create a language that inherits the best aspects of Elm while adapting and growing to meet the needs of its users. +# Install + +To install Guida as an npm package, run the following command: + +``` +npm install -g guida +``` + +You should now be able to run `guida --version`. + # Development Start by installing [Node Version Manager](https://github.com/nvm-sh/nvm). @@ -121,6 +131,32 @@ npm run test:elm-format-validate npm run elm-format ``` +# Publish new npm package version + +Before publishing a new npm package version, make sure you are on the correct +branch, ie. in case of wanting to publish a 0.x version, you should have the +`v0.x` branch checked out. + +To publish a new version, we should then run the following commands: + +``` +npm version +npm publish +git push origin +git push origin tag v +``` + +As an example, these should have been the commands ran for publishing `v0.2.0-alpha` + +``` +npm version 0.2.0-alpha +npm publish +git push origin v0.x +git push origin tag v0.2.0-alpha +``` + +The `` value relates to the `version` field value found on `package.json`. + # References - Initial transpilation from Haskell to Elm done based on [Elm compiler v0.19.1](https://github.com/elm/compiler/releases/tag/0.19.1) diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm index b8ab7657a..eb3be342e 100644 --- a/src/Builder/Build.elm +++ b/src/Builder/Build.elm @@ -60,7 +60,7 @@ import Utils.Main as Utils exposing (FilePath, MVar(..)) type Env - = Env Reporting.BKey String Parse.ProjectType (List AbsoluteSrcDir) Details.BuildID (Dict ModuleName.Raw Details.Local) (Dict ModuleName.Raw Details.Foreign) + = Env Reporting.BKey String Parse.ProjectType (List AbsoluteSrcDir) Details.BuildID (Dict String ModuleName.Raw Details.Local) (Dict String ModuleName.Raw Details.Foreign) makeEnv : Reporting.BKey -> FilePath -> Details.Details -> IO Env @@ -120,9 +120,9 @@ fork codec work = ) -forkWithKey : (k -> k -> Order) -> Codec e b -> (k -> a -> IO b) -> Dict k a -> IO (Dict k (MVar b)) -forkWithKey keyComparison codec func dict = - Utils.mapTraverseWithKey keyComparison (\k v -> fork codec (func k v)) dict +forkWithKey : (k -> comparable) -> (k -> k -> Order) -> Codec e b -> (k -> a -> IO b) -> Dict comparable k a -> IO (Dict comparable k (MVar b)) +forkWithKey toComparable keyComparison codec func dict = + Utils.mapTraverseWithKey toComparable keyComparison (\k v -> fork codec (func k v)) dict @@ -148,16 +148,16 @@ fromExposed docsCodec style root details docsGoal ((NE.Nonempty e es) as exposed docsNeed = toDocsNeed docsGoal in - Map.fromKeysA compare (fork statusCodec << crawlModule env mvar docsNeed) (e :: es) + Map.fromKeysA identity (fork statusCodec << crawlModule env mvar docsNeed) (e :: es) |> IO.bind (\roots -> Utils.putMVar statusDictCodec mvar roots |> IO.bind (\_ -> - Utils.dictMapM_ (Utils.readMVar statusCodec) roots + Utils.dictMapM_ compare (Utils.readMVar statusCodec) roots |> IO.bind (\_ -> - IO.bind (Utils.mapTraverse compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec mvar) + IO.bind (Utils.mapTraverse identity compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec mvar) |> IO.bind (\statuses -> -- compile @@ -172,13 +172,13 @@ fromExposed docsCodec style root details docsGoal ((NE.Nonempty e es) as exposed Utils.newEmptyMVar |> IO.bind (\rmvar -> - forkWithKey compare bResultCodec (checkModule env foreigns rmvar) statuses + forkWithKey identity compare bResultCodec (checkModule env foreigns rmvar) statuses |> IO.bind (\resultMVars -> Utils.putMVar dictRawMVarBResultCodec rmvar resultMVars |> IO.bind (\_ -> - Utils.mapTraverse compare (Utils.readMVar bResultCodec) resultMVars + Utils.mapTraverse identity compare (Utils.readMVar bResultCodec) resultMVars |> IO.bind (\results -> writeDetails root details results @@ -214,7 +214,7 @@ type Module type alias Dependencies = - Dict TypeCheck.Canonical I.DependencyInterface + Dict (List String) TypeCheck.Canonical I.DependencyInterface fromPaths : Reporting.Style -> FilePath -> Details.Details -> NE.Nonempty FilePath -> IO (Result Exit.BuildProblem Artifacts) @@ -245,7 +245,7 @@ fromPaths style root details paths = Utils.nonEmptyListTraverse (Utils.readMVar rootStatusCodec) srootMVars |> IO.bind (\sroots -> - IO.bind (Utils.mapTraverse compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec smvar) + IO.bind (Utils.mapTraverse identity compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec smvar) |> IO.bind (\statuses -> checkMidpointAndRoots dmvar statuses sroots @@ -260,7 +260,7 @@ fromPaths style root details paths = Utils.newEmptyMVar |> IO.bind (\rmvar -> - forkWithKey compare bResultCodec (checkModule env foreigns rmvar) statuses + forkWithKey identity compare bResultCodec (checkModule env foreigns rmvar) statuses |> IO.bind (\resultsMVars -> Utils.putMVar resultDictCodec rmvar resultsMVars @@ -269,7 +269,7 @@ fromPaths style root details paths = Utils.nonEmptyListTraverse (fork rootResultCodec << checkRoot env resultsMVars) sroots |> IO.bind (\rrootMVars -> - Utils.mapTraverse compare (Utils.readMVar bResultCodec) resultsMVars + Utils.mapTraverse identity compare (Utils.readMVar bResultCodec) resultsMVars |> IO.bind (\results -> writeDetails root details results @@ -316,7 +316,7 @@ getRootName root = type alias StatusDict = - Dict ModuleName.Raw (MVar Status) + Dict String ModuleName.Raw (MVar Status) type Status @@ -339,21 +339,21 @@ crawlDeps env mvar deps blockedValue = |> IO.bind (\statusDict -> let - depsDict : Dict ModuleName.Raw () + depsDict : Dict String ModuleName.Raw () depsDict = Map.fromKeys (\_ -> ()) deps - newsDict : Dict ModuleName.Raw () + newsDict : Dict String ModuleName.Raw () newsDict = Dict.diff depsDict statusDict in - Utils.mapTraverseWithKey compare crawlNew newsDict + Utils.mapTraverseWithKey identity compare crawlNew newsDict |> IO.bind (\statuses -> - Utils.putMVar statusDictCodec mvar (Dict.union compare statuses statusDict) + Utils.putMVar statusDictCodec mvar (Dict.union statuses statusDict) |> IO.bind (\_ -> - Utils.dictMapM_ (Utils.readMVar statusCodec) statuses + Utils.dictMapM_ compare (Utils.readMVar statusCodec) statuses |> IO.fmap (\_ -> blockedValue) ) ) @@ -372,7 +372,7 @@ crawlModule ((Env _ root projectType srcDirs buildID locals foreigns) as env) mv (\paths -> case paths of [ path ] -> - case Dict.get name foreigns of + case Dict.get identity name foreigns of Just (Details.Foreign dep deps) -> IO.pure <| SBadImport <| Import.Ambiguous path [] dep deps @@ -380,7 +380,7 @@ crawlModule ((Env _ root projectType srcDirs buildID locals foreigns) as env) mv File.getTime path |> IO.bind (\newTime -> - case Dict.get name locals of + case Dict.get identity name locals of Nothing -> crawlFile env mvar docsNeed name path newTime buildID @@ -396,7 +396,7 @@ crawlModule ((Env _ root projectType srcDirs buildID locals foreigns) as env) mv IO.pure <| SBadImport <| Import.AmbiguousLocal (Utils.fpMakeRelative root p1) (Utils.fpMakeRelative root p2) (List.map (Utils.fpMakeRelative root) ps) [] -> - case Dict.get name foreigns of + case Dict.get identity name foreigns of Just (Details.Foreign dep deps) -> case deps of [] -> @@ -464,7 +464,7 @@ isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) = type alias ResultDict = - Dict ModuleName.Raw (MVar BResult) + Dict String ModuleName.Raw (MVar BResult) type BResult @@ -580,7 +580,7 @@ checkModule ((Env _ root projectType _ _ _ _) as env) foreigns resultsMVar name Error.BadSyntax err SForeign home -> - case Utils.find (TypeCheck.Canonical home name) foreigns of + case Utils.find ModuleName.toComparableCanonical (TypeCheck.Canonical home name) foreigns of I.Public iface -> IO.pure (RForeign iface) @@ -596,7 +596,7 @@ checkModule ((Env _ root projectType _ _ _ _) as env) foreigns resultsMVar name type DepsStatus - = DepsChange (Dict ModuleName.Raw I.Interface) + = DepsChange (Dict String ModuleName.Raw I.Interface) | DepsSame (List Dep) (List CDep) | DepsBlock | DepsNotFound (NE.Nonempty ( ModuleName.Raw, Import.Problem )) @@ -619,7 +619,7 @@ checkDepsHelp : FilePath -> ResultDict -> List ModuleName.Raw -> List Dep -> Lis checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile = case deps of dep :: otherDeps -> - Utils.readMVar bResultCodec (Utils.find dep results) + Utils.readMVar bResultCodec (Utils.find identity dep results) |> IO.bind (\result -> case result of @@ -669,7 +669,7 @@ checkDepsHelp root results deps new same cached importProblems isBlocked lastDep IO.pure DepsBlock Just ifaces -> - IO.pure <| DepsChange <| Dict.union compare (Dict.fromList compare new) ifaces + IO.pure <| DepsChange <| Dict.union (Dict.fromList identity new) ifaces ) @@ -680,27 +680,27 @@ checkDepsHelp root results deps new same cached importProblems isBlocked lastDep toImportErrors : Env -> ResultDict -> List Src.Import -> NE.Nonempty ( ModuleName.Raw, Import.Problem ) -> NE.Nonempty Import.Error toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems = let - knownModules : EverySet.EverySet ModuleName.Raw + knownModules : EverySet.EverySet String ModuleName.Raw knownModules = - EverySet.fromList compare + EverySet.fromList identity (List.concat - [ Dict.keys foreigns - , Dict.keys locals - , Dict.keys results + [ Dict.keys compare foreigns + , Dict.keys compare locals + , Dict.keys compare results ] ) - unimportedModules : EverySet.EverySet ModuleName.Raw + unimportedModules : EverySet.EverySet String ModuleName.Raw unimportedModules = - EverySet.diff knownModules (EverySet.fromList compare (List.map Src.getImportName imports)) + EverySet.diff knownModules (EverySet.fromList identity (List.map Src.getImportName imports)) - regionDict : Dict Name.Name A.Region + regionDict : Dict String Name.Name A.Region regionDict = - Dict.fromList compare (List.map (\(Src.Import (A.At region name) _ _) -> ( name, region )) imports) + Dict.fromList identity (List.map (\(Src.Import (A.At region name) _ _) -> ( name, region )) imports) toError : ( Name.Name, Import.Problem ) -> Import.Error toError ( name, problem ) = - Import.Error (Utils.find name regionDict) name unimportedModules problem + Import.Error (Utils.find identity name regionDict) name unimportedModules problem in NE.map toError problems @@ -709,7 +709,7 @@ toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems = -- LOAD CACHED INTERFACES -loadInterfaces : FilePath -> List Dep -> List CDep -> IO (Maybe (Dict ModuleName.Raw I.Interface)) +loadInterfaces : FilePath -> List Dep -> List CDep -> IO (Maybe (Dict String ModuleName.Raw I.Interface)) loadInterfaces root same cached = Utils.listTraverse (fork maybeDepCodec << loadInterface root) cached |> IO.bind @@ -722,7 +722,7 @@ loadInterfaces root same cached = IO.pure Nothing Just loaded -> - IO.pure <| Just <| Dict.union compare (Dict.fromList compare loaded) (Dict.fromList compare same) + IO.pure <| Just <| Dict.union (Dict.fromList identity loaded) (Dict.fromList identity same) ) ) @@ -761,7 +761,7 @@ loadInterface root ( name, ciMvar ) = -- CHECK PROJECT -checkMidpoint : MVar (Maybe Dependencies) -> Dict ModuleName.Raw Status -> IO (Result Exit.BuildProjectProblem Dependencies) +checkMidpoint : MVar (Maybe Dependencies) -> Dict String ModuleName.Raw Status -> IO (Result Exit.BuildProjectProblem Dependencies) checkMidpoint dmvar statuses = case checkForCycles statuses of Nothing -> @@ -781,7 +781,7 @@ checkMidpoint dmvar statuses = |> IO.fmap (\_ -> Err (Exit.BP_Cycle name names)) -checkMidpointAndRoots : MVar (Maybe Dependencies) -> Dict ModuleName.Raw Status -> NE.Nonempty RootStatus -> IO (Result Exit.BuildProjectProblem Dependencies) +checkMidpointAndRoots : MVar (Maybe Dependencies) -> Dict String ModuleName.Raw Status -> NE.Nonempty RootStatus -> IO (Result Exit.BuildProjectProblem Dependencies) checkMidpointAndRoots dmvar statuses sroots = case checkForCycles statuses of Nothing -> @@ -811,12 +811,12 @@ checkMidpointAndRoots dmvar statuses sroots = -- CHECK FOR CYCLES -checkForCycles : Dict ModuleName.Raw Status -> Maybe (NE.Nonempty ModuleName.Raw) +checkForCycles : Dict String ModuleName.Raw Status -> Maybe (NE.Nonempty ModuleName.Raw) checkForCycles modules = let graph : List Node graph = - Dict.foldr addToGraph [] modules + Dict.foldr compare addToGraph [] modules sccs : List (Graph.SCC ModuleName.Raw) sccs = @@ -878,19 +878,19 @@ addToGraph name status graph = -- CHECK UNIQUE ROOTS -checkUniqueRoots : Dict ModuleName.Raw Status -> NE.Nonempty RootStatus -> Maybe Exit.BuildProjectProblem +checkUniqueRoots : Dict String ModuleName.Raw Status -> NE.Nonempty RootStatus -> Maybe Exit.BuildProjectProblem checkUniqueRoots insides sroots = let - outsidesDict : Dict ModuleName.Raw (OneOrMore.OneOrMore FilePath) + outsidesDict : Dict String ModuleName.Raw (OneOrMore.OneOrMore FilePath) outsidesDict = - Utils.mapFromListWith compare OneOrMore.more (List.filterMap rootStatusToNamePathPair (NE.toList sroots)) + Utils.mapFromListWith identity OneOrMore.more (List.filterMap rootStatusToNamePathPair (NE.toList sroots)) in - case Utils.mapTraverseWithKeyResult compare checkOutside outsidesDict of + case Utils.mapTraverseWithKeyResult identity compare checkOutside outsidesDict of Err problem -> Just problem Ok outsides -> - case Utils.sequenceDictResult_ compare (Utils.mapIntersectionWithKey compare checkInside outsides insides) of + case Utils.sequenceDictResult_ identity compare (Utils.mapIntersectionWithKey identity compare checkInside outsides insides) of Ok () -> Nothing @@ -947,7 +947,7 @@ checkInside name p1 status = -- COMPILE MODULE -compile : Env -> DocsNeed -> Details.Local -> String -> Dict ModuleName.Raw I.Interface -> Src.Module -> IO BResult +compile : Env -> DocsNeed -> Details.Local -> String -> Dict String ModuleName.Raw I.Interface -> Src.Module -> IO BResult compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul = let pkg : Pkg.Name @@ -1056,20 +1056,20 @@ projectTypeToPkg projectType = -- WRITE DETAILS -writeDetails : FilePath -> Details.Details -> Dict ModuleName.Raw BResult -> IO () +writeDetails : FilePath -> Details.Details -> Dict String ModuleName.Raw BResult -> IO () writeDetails root (Details.Details time outline buildID locals foreigns extras) results = File.writeBinary Details.detailsCodec (Stuff.details root) <| - Details.Details time outline buildID (Dict.foldr addNewLocal locals results) foreigns extras + Details.Details time outline buildID (Dict.foldr compare addNewLocal locals results) foreigns extras -addNewLocal : ModuleName.Raw -> BResult -> Dict ModuleName.Raw Details.Local -> Dict ModuleName.Raw Details.Local +addNewLocal : ModuleName.Raw -> BResult -> Dict String ModuleName.Raw Details.Local -> Dict String ModuleName.Raw Details.Local addNewLocal name result locals = case result of RNew local _ _ _ -> - Dict.insert compare name local locals + Dict.insert identity name local locals RSame local _ _ _ -> - Dict.insert compare name local locals + Dict.insert identity name local locals RCached _ _ _ -> locals @@ -1094,14 +1094,14 @@ addNewLocal name result locals = -- FINALIZE EXPOSED -finalizeExposed : FilePath -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> Dict ModuleName.Raw BResult -> IO (Result Exit.BuildProblem docs) +finalizeExposed : FilePath -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> Dict String ModuleName.Raw BResult -> IO (Result Exit.BuildProblem docs) finalizeExposed root docsGoal exposed results = case List.foldr (addImportProblems results) [] (NE.toList exposed) of p :: ps -> IO.pure <| Err <| Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.Nonempty p ps)) [] -> - case Dict.foldr (\_ -> addErrors) [] results of + case Dict.foldr compare (\_ -> addErrors) [] results of [] -> IO.fmap Ok (finalizeDocs docsGoal results) @@ -1137,9 +1137,9 @@ addErrors result errors = errors -addImportProblems : Dict ModuleName.Raw BResult -> ModuleName.Raw -> List ( ModuleName.Raw, Import.Problem ) -> List ( ModuleName.Raw, Import.Problem ) +addImportProblems : Dict String ModuleName.Raw BResult -> ModuleName.Raw -> List ( ModuleName.Raw, Import.Problem ) -> List ( ModuleName.Raw, Import.Problem ) addImportProblems results name problems = - case Utils.find name results of + case Utils.find identity name results of RNew _ _ _ _ -> problems @@ -1170,19 +1170,19 @@ addImportProblems results name problems = type DocsGoal docs - = KeepDocs (Dict ModuleName.Raw BResult -> docs) - | WriteDocs (Dict ModuleName.Raw BResult -> IO docs) + = KeepDocs (Dict String ModuleName.Raw BResult -> docs) + | WriteDocs (Dict String ModuleName.Raw BResult -> IO docs) | IgnoreDocs docs -keepDocs : DocsGoal (Dict ModuleName.Raw Docs.Module) +keepDocs : DocsGoal (Dict String ModuleName.Raw Docs.Module) keepDocs = - KeepDocs (Utils.mapMapMaybe compare toDocs) + KeepDocs (Utils.mapMapMaybe identity compare toDocs) writeDocs : FilePath -> DocsGoal () writeDocs path = - WriteDocs (E.writeUgly path << Docs.encode << Utils.mapMapMaybe compare toDocs) + WriteDocs (E.writeUgly path << Docs.encode << Utils.mapMapMaybe identity compare toDocs) ignoreDocs : DocsGoal () @@ -1221,7 +1221,7 @@ makeDocs (DocsNeed isNeeded) modul = Ok Nothing -finalizeDocs : DocsGoal docs -> Dict ModuleName.Raw BResult -> IO docs +finalizeDocs : DocsGoal docs -> Dict String ModuleName.Raw BResult -> IO docs finalizeDocs goal results = case goal of KeepDocs f -> @@ -1270,7 +1270,7 @@ toDocs result = type ReplArtifacts - = ReplArtifacts TypeCheck.Canonical (List Module) L.Localizer (Dict Name.Name Can.Annotation) + = ReplArtifacts TypeCheck.Canonical (List Module) L.Localizer (Dict String Name.Name Can.Annotation) fromRepl : FilePath -> Details.Details -> String -> IO (Result Exit.Repl ReplArtifacts) @@ -1297,7 +1297,7 @@ fromRepl root details source = crawlDeps env mvar deps () |> IO.bind (\_ -> - IO.bind (Utils.mapTraverse compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec mvar) + IO.bind (Utils.mapTraverse identity compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec mvar) |> IO.bind (\statuses -> checkMidpoint dmvar statuses @@ -1311,13 +1311,13 @@ fromRepl root details source = Utils.newEmptyMVar |> IO.bind (\rmvar -> - forkWithKey compare bResultCodec (checkModule env foreigns rmvar) statuses + forkWithKey identity compare bResultCodec (checkModule env foreigns rmvar) statuses |> IO.bind (\resultMVars -> Utils.putMVar resultDictCodec rmvar resultMVars |> IO.bind (\_ -> - Utils.mapTraverse compare (Utils.readMVar bResultCodec) resultMVars + Utils.mapTraverse identity compare (Utils.readMVar bResultCodec) resultMVars |> IO.bind (\results -> writeDetails root details results @@ -1341,14 +1341,14 @@ fromRepl root details source = ) -finalizeReplArtifacts : Env -> String -> Src.Module -> DepsStatus -> ResultDict -> Dict ModuleName.Raw BResult -> IO (Result Exit.Repl ReplArtifacts) +finalizeReplArtifacts : Env -> String -> Src.Module -> DepsStatus -> ResultDict -> Dict String ModuleName.Raw BResult -> IO (Result Exit.Repl ReplArtifacts) finalizeReplArtifacts ((Env _ root projectType _ _ _ _) as env) source ((Src.Module _ _ _ imports _ _ _ _ _) as modul) depsStatus resultMVars results = let pkg : Pkg.Name pkg = projectTypeToPkg projectType - compileInput : Dict ModuleName.Raw I.Interface -> IO (Result Exit.Repl ReplArtifacts) + compileInput : Dict String ModuleName.Raw I.Interface -> IO (Result Exit.Repl ReplArtifacts) compileInput ifaces = Compile.compile pkg ifaces modul |> IO.fmap @@ -1366,7 +1366,7 @@ finalizeReplArtifacts ((Env _ root projectType _ _ _ _) as env) source ((Src.Mod ms : List Module ms = - Dict.foldr addInside [] results + Dict.foldr compare addInside [] results in Ok <| ReplArtifacts h (m :: ms) (L.fromModule modul) annotations @@ -1391,7 +1391,7 @@ finalizeReplArtifacts ((Env _ root projectType _ _ _ _) as env) source ((Src.Mod ) DepsBlock -> - case Dict.foldr (\_ -> addErrors) [] results of + case Dict.foldr compare (\_ -> addErrors) [] results of [] -> IO.pure <| Err <| Exit.ReplBlocked @@ -1450,8 +1450,8 @@ checkRoots infos = Err (Exit.BP_MainPathDuplicate relative relative2) in Result.map (\_ -> NE.map (\(RootInfo _ _ location) -> location) infos) <| - Utils.mapTraverseResult compare (OneOrMore.destruct fromOneOrMore) <| - Utils.mapFromListWith compare OneOrMore.more <| + Utils.mapTraverseResult identity compare (OneOrMore.destruct fromOneOrMore) <| + Utils.mapFromListWith identity OneOrMore.more <| List.map toOneOrMore (NE.toList infos) @@ -1602,7 +1602,7 @@ crawlRoot ((Env _ _ projectType _ buildID _ _) as env) mvar root = Utils.takeMVar statusDictCodec mvar |> IO.bind (\statusDict -> - Utils.putMVar statusDictCodec mvar (Dict.insert compare name statusMVar statusDict) + Utils.putMVar statusDictCodec mvar (Dict.insert identity name statusMVar statusDict) |> IO.bind (\_ -> IO.bind (Utils.putMVar statusCodec statusMVar) (crawlModule env mvar (DocsNeed False) name) @@ -1690,7 +1690,7 @@ checkRoot ((Env _ root _ _ _ _ _) as env) results rootStatus = ) -compileOutside : Env -> Details.Local -> String -> Dict ModuleName.Raw I.Interface -> Src.Module -> IO RootResult +compileOutside : Env -> Details.Local -> String -> Dict String ModuleName.Raw I.Interface -> Src.Module -> IO RootResult compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul = let pkg : Pkg.Name @@ -1723,7 +1723,7 @@ type Root | Outside ModuleName.Raw I.Interface Opt.LocalGraph -toArtifacts : Env -> Dependencies -> Dict ModuleName.Raw BResult -> NE.Nonempty RootResult -> Result Exit.BuildProblem Artifacts +toArtifacts : Env -> Dependencies -> Dict String ModuleName.Raw BResult -> NE.Nonempty RootResult -> Result Exit.BuildProblem Artifacts toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults = case gatherProblemsOrMains results rootResults of Err (NE.Nonempty e es) -> @@ -1732,10 +1732,10 @@ toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults = Ok roots -> Ok <| Artifacts (projectTypeToPkg projectType) foreigns roots <| - Dict.foldr addInside (NE.foldr addOutside [] rootResults) results + Dict.foldr compare addInside (NE.foldr addOutside [] rootResults) results -gatherProblemsOrMains : Dict ModuleName.Raw BResult -> NE.Nonempty RootResult -> Result (NE.Nonempty Error.Module) (NE.Nonempty Root) +gatherProblemsOrMains : Dict String ModuleName.Raw BResult -> NE.Nonempty RootResult -> Result (NE.Nonempty Error.Module) (NE.Nonempty Root) gatherProblemsOrMains results (NE.Nonempty rootResult rootResults) = let addResult : RootResult -> ( List Error.Module, List Root ) -> ( List Error.Module, List Root ) @@ -1755,7 +1755,7 @@ gatherProblemsOrMains results (NE.Nonempty rootResult rootResults) = errors : List Error.Module errors = - Dict.foldr (\_ -> addErrors) [] results + Dict.foldr compare (\_ -> addErrors) [] results in case ( rootResult, List.foldr addResult ( errors, [] ) rootResults ) of ( RInside n, ( [], ms ) ) -> @@ -1833,9 +1833,9 @@ addOutside root modules = -- ENCODERS and DECODERS -dictRawMVarBResultCodec : Codec e (Dict ModuleName.Raw (MVar BResult)) +dictRawMVarBResultCodec : Codec e (Dict String ModuleName.Raw (MVar BResult)) dictRawMVarBResultCodec = - S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec + S.assocListDict identity compare ModuleName.rawCodec Utils.mVarCodec bResultCodec : Codec (Serialize.Error e) BResult @@ -1891,7 +1891,7 @@ bResultCodec = statusDictCodec : Codec e StatusDict statusDictCodec = - S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec + S.assocListDict identity compare ModuleName.rawCodec Utils.mVarCodec statusCodec : Codec e Status @@ -1948,7 +1948,7 @@ rootStatusCodec = resultDictCodec : Codec e ResultDict resultDictCodec = - S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec + S.assocListDict identity compare ModuleName.rawCodec Utils.mVarCodec rootResultCodec : Codec (Serialize.Error e) RootResult @@ -1987,7 +1987,7 @@ depCodec = maybeDependenciesCodec : Codec e (Maybe Dependencies) maybeDependenciesCodec = - Serialize.maybe (S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec) + Serialize.maybe (S.assocListDict ModuleName.toComparableCanonical ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec) resultBuildProjectProblemRootInfoCodec : Codec (Serialize.Error e) (Result Exit.BuildProjectProblem RootInfo) @@ -2032,7 +2032,7 @@ artifactsCodec = dependenciesCodec : Codec e Dependencies dependenciesCodec = - S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec + S.assocListDict ModuleName.toComparableCanonical ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec rootCodec : Codec e Root diff --git a/src/Builder/Deps/Diff.elm b/src/Builder/Deps/Diff.elm index 223292be3..92fa5f734 100644 --- a/src/Builder/Deps/Diff.elm +++ b/src/Builder/Deps/Diff.elm @@ -30,25 +30,25 @@ import Utils.Main as Utils type PackageChanges - = PackageChanges (List ModuleName.Raw) (Dict ModuleName.Raw ModuleChanges) (List ModuleName.Raw) + = PackageChanges (List ModuleName.Raw) (Dict String ModuleName.Raw ModuleChanges) (List ModuleName.Raw) type ModuleChanges - = ModuleChanges (Changes Name.Name Docs.Union) (Changes Name.Name Docs.Alias) (Changes Name.Name Docs.Value) (Changes Name.Name Docs.Binop) + = ModuleChanges (Changes String Name.Name Docs.Union) (Changes String Name.Name Docs.Alias) (Changes String Name.Name Docs.Value) (Changes String Name.Name Docs.Binop) -type Changes k v - = Changes (Dict k v) (Dict k ( v, v )) (Dict k v) +type Changes c k v + = Changes (Dict c k v) (Dict c k ( v, v )) (Dict c k v) -getChanges : (k -> k -> Order) -> (v -> v -> Bool) -> Dict k v -> Dict k v -> Changes k v -getChanges keyComparison isEquivalent old new = +getChanges : (k -> comparable) -> (k -> k -> Order) -> (v -> v -> Bool) -> Dict comparable k v -> Dict comparable k v -> Changes comparable k v +getChanges toComparable keyComparison isEquivalent old new = let - overlap : Dict k ( v, v ) + overlap : Dict comparable k ( v, v ) overlap = - Utils.mapIntersectionWith keyComparison Tuple.pair old new + Utils.mapIntersectionWith toComparable keyComparison Tuple.pair old new - changed : Dict k ( v, v ) + changed : Dict comparable k ( v, v ) changed = Dict.filter (\_ ( v1, v2 ) -> not (isEquivalent v1 v2)) overlap in @@ -65,26 +65,26 @@ getChanges keyComparison isEquivalent old new = diff : Docs.Documentation -> Docs.Documentation -> PackageChanges diff oldDocs newDocs = let - filterOutPatches : Dict a ModuleChanges -> Dict a ModuleChanges + filterOutPatches : Dict comparable a ModuleChanges -> Dict comparable a ModuleChanges filterOutPatches chngs = Dict.filter (\_ chng -> moduleChangeMagnitude chng /= M.PATCH) chngs (Changes added changed removed) = - getChanges compare (\_ _ -> False) oldDocs newDocs + getChanges identity compare (\_ _ -> False) oldDocs newDocs in PackageChanges - (Dict.keys added) + (Dict.keys compare added) (filterOutPatches (Dict.map (\_ -> diffModule) changed)) - (Dict.keys removed) + (Dict.keys compare removed) diffModule : ( Docs.Module, Docs.Module ) -> ModuleChanges diffModule ( Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2 ) = ModuleChanges - (getChanges compare isEquivalentUnion u1 u2) - (getChanges compare isEquivalentAlias a1 a2) - (getChanges compare isEquivalentValue v1 v2) - (getChanges compare isEquivalentBinop b1 b2) + (getChanges identity compare isEquivalentUnion u1 u2) + (getChanges identity compare isEquivalentAlias a1 a2) + (getChanges identity compare isEquivalentValue v1 v2) + (getChanges identity compare isEquivalentBinop b1 b2) @@ -109,7 +109,7 @@ isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newCommen in (List.length oldCtors == List.length newCtors) && List.all identity (List.map2 (==) (List.map Tuple.first oldCtors) (List.map Tuple.first newCtors)) - && List.all identity (Dict.values (Utils.mapIntersectionWith compare equiv (Dict.fromList compare oldCtors) (Dict.fromList compare newCtors))) + && List.all identity (Dict.values compare (Utils.mapIntersectionWith identity compare equiv (Dict.fromList identity oldCtors) (Dict.fromList identity newCtors))) isEquivalentAlias : Docs.Alias -> Docs.Alias -> Bool @@ -243,11 +243,11 @@ isEquivalentRenaming varPairs = let renamings : List ( Name.Name, List Name.Name ) renamings = - Dict.toList (List.foldr insert Dict.empty varPairs) + Dict.toList compare (List.foldr insert Dict.empty varPairs) - insert : ( Name.Name, Name.Name ) -> Dict Name.Name (List Name.Name) -> Dict Name.Name (List Name.Name) + insert : ( Name.Name, Name.Name ) -> Dict String Name.Name (List Name.Name) -> Dict String Name.Name (List Name.Name) insert ( old, new ) dict = - Utils.mapInsertWith compare (++) old [ new ] dict + Utils.mapInsertWith identity (++) old [ new ] dict verify : ( a, List b ) -> Maybe ( a, b ) verify ( old, news ) = @@ -264,7 +264,7 @@ isEquivalentRenaming varPairs = allUnique : List comparable -> Bool allUnique list = - List.length list == EverySet.size (EverySet.fromList compare list) + List.length list == EverySet.size (EverySet.fromList identity list) in case Utils.maybeMapM verify renamings of Nothing -> @@ -364,7 +364,7 @@ toMagnitude (PackageChanges added changed removed) = changeMags : List M.Magnitude changeMags = - List.map moduleChangeMagnitude (Dict.values changed) + List.map moduleChangeMagnitude (Dict.values compare changed) in Utils.listMaximum M.compare (addMag :: removeMag :: changeMags) @@ -379,7 +379,7 @@ moduleChangeMagnitude (ModuleChanges unions aliases values binops) = ] -changeMagnitude : Changes k v -> M.Magnitude +changeMagnitude : Changes comparable k v -> M.Magnitude changeMagnitude (Changes added changed removed) = if Dict.size removed > 0 || Dict.size changed > 0 then M.MAJOR diff --git a/src/Builder/Deps/Registry.elm b/src/Builder/Deps/Registry.elm index d8c588785..2ac0a73c7 100644 --- a/src/Builder/Deps/Registry.elm +++ b/src/Builder/Deps/Registry.elm @@ -31,7 +31,7 @@ import System.IO as IO exposing (IO) type Registry - = Registry Int (Dict Pkg.Name KnownVersions) + = Registry Int (Dict ( String, String ) Pkg.Name KnownVersions) type KnownVersions @@ -68,7 +68,7 @@ fetch manager cache = let size : Int size = - Dict.foldr (\_ -> addEntry) 0 versions + Dict.foldr Pkg.compareName (\_ -> addEntry) 0 versions registry : Registry registry = @@ -87,7 +87,7 @@ addEntry (KnownVersions _ vs) count = count + 1 + List.length vs -allPkgsDecoder : D.Decoder () (Dict Pkg.Name KnownVersions) +allPkgsDecoder : D.Decoder () (Dict ( String, String ) Pkg.Name KnownVersions) allPkgsDecoder = let keyDecoder : D.KeyDecoder () Pkg.Name @@ -107,7 +107,7 @@ allPkgsDecoder = [] -> D.failure () in - D.dict Pkg.compareName keyDecoder (D.bind toKnownVersions versionsDecoder) + D.dict identity keyDecoder (D.bind toKnownVersions versionsDecoder) @@ -128,7 +128,7 @@ update manager cache ((Registry size packages) as oldRegistry) = newSize = size + List.length news - newPkgs : Dict Pkg.Name KnownVersions + newPkgs : Dict ( String, String ) Pkg.Name KnownVersions newPkgs = List.foldr addNew packages news @@ -140,7 +140,7 @@ update manager cache ((Registry size packages) as oldRegistry) = |> IO.fmap (\_ -> newRegistry) -addNew : ( Pkg.Name, V.Version ) -> Dict Pkg.Name KnownVersions -> Dict Pkg.Name KnownVersions +addNew : ( Pkg.Name, V.Version ) -> Dict ( String, String ) Pkg.Name KnownVersions -> Dict ( String, String ) Pkg.Name KnownVersions addNew ( name, version ) versions = let add : Maybe KnownVersions -> KnownVersions @@ -152,7 +152,7 @@ addNew ( name, version ) versions = Nothing -> KnownVersions version [] in - Dict.update Pkg.compareName name (Just << add) versions + Dict.update identity name (Just << add) versions @@ -204,17 +204,17 @@ latest manager cache = getVersions : Pkg.Name -> Registry -> Maybe KnownVersions getVersions name (Registry _ versions) = - Dict.get name versions + Dict.get identity name versions getVersions_ : Pkg.Name -> Registry -> Result (List Pkg.Name) KnownVersions getVersions_ name (Registry _ versions) = - case Dict.get name versions of + case Dict.get identity name versions of Just kvs -> Ok kvs Nothing -> - Err (Pkg.nearbyNames name (Dict.keys versions)) + Err (Pkg.nearbyNames name (Dict.keys compare versions)) @@ -248,5 +248,5 @@ registryCodec = (\registryCodecEncoder (Registry size packages) -> registryCodecEncoder size packages ) - |> Serialize.variant2 Registry Serialize.int (S.assocListDict Pkg.compareName Pkg.nameCodec knownVersionsCodec) + |> Serialize.variant2 Registry Serialize.int (S.assocListDict identity Pkg.compareName Pkg.nameCodec knownVersionsCodec) |> Serialize.finishCustomType diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index 15070ef03..8fe875d17 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -45,11 +45,11 @@ type InnerSolver a type State - = State Stuff.PackageCache Connection Registry.Registry (Dict ( Pkg.Name, V.Version ) Constraints) + = State Stuff.PackageCache Connection Registry.Registry (Dict ( ( String, String ), ( Int, Int, Int ) ) ( Pkg.Name, V.Version ) Constraints) type Constraints - = Constraints C.Constraint (Dict Pkg.Name C.Constraint) + = Constraints C.Constraint (Dict ( String, String ) Pkg.Name C.Constraint) type Connection @@ -73,10 +73,10 @@ type SolverResult a type Details - = Details V.Version (Dict Pkg.Name C.Constraint) + = Details V.Version (Dict ( String, String ) Pkg.Name C.Constraint) -verify : Stuff.PackageCache -> Connection -> Registry.Registry -> Dict Pkg.Name C.Constraint -> IO (SolverResult (Dict Pkg.Name Details)) +verify : Stuff.PackageCache -> Connection -> Registry.Registry -> Dict ( String, String ) Pkg.Name C.Constraint -> IO (SolverResult (Dict ( String, String ) Pkg.Name Details)) verify cache connection registry constraints = Stuff.withRegistryLock cache <| case try constraints of @@ -98,7 +98,7 @@ verify cache connection registry constraints = addDeps : State -> Pkg.Name -> V.Version -> Details addDeps (State _ _ _ constraints) name vsn = - case Dict.get ( name, vsn ) constraints of + case Dict.get (Tuple.mapSecond V.toComparable) ( name, vsn ) constraints of Just (Constraints _ deps) -> Details vsn deps @@ -121,28 +121,28 @@ noSolution connection = type AppSolution - = AppSolution (Dict Pkg.Name V.Version) (Dict Pkg.Name V.Version) Outline.AppOutline + = AppSolution (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) Outline.AppOutline addToApp : Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (SolverResult AppSolution) addToApp cache connection registry pkg ((Outline.AppOutline _ _ direct indirect testDirect testIndirect) as outline) = Stuff.withRegistryLock cache <| let - allIndirects : Dict Pkg.Name V.Version + allIndirects : Dict ( String, String ) Pkg.Name V.Version allIndirects = - Dict.union Pkg.compareName indirect testIndirect + Dict.union indirect testIndirect - allDirects : Dict Pkg.Name V.Version + allDirects : Dict ( String, String ) Pkg.Name V.Version allDirects = - Dict.union Pkg.compareName direct testDirect + Dict.union direct testDirect - allDeps : Dict Pkg.Name V.Version + allDeps : Dict ( String, String ) Pkg.Name V.Version allDeps = - Dict.union Pkg.compareName allDirects allIndirects + Dict.union allDirects allIndirects - attempt : (a -> C.Constraint) -> Dict Pkg.Name a -> Solver (Dict Pkg.Name V.Version) + attempt : (a -> C.Constraint) -> Dict ( String, String ) Pkg.Name a -> Solver (Dict ( String, String ) Pkg.Name V.Version) attempt toConstraint deps = - try (Dict.insert Pkg.compareName pkg C.anything (Dict.map (\_ -> toConstraint) deps)) + try (Dict.insert identity pkg C.anything (Dict.map (\_ -> toConstraint) deps)) in case oneOf @@ -169,50 +169,50 @@ addToApp cache connection registry pkg ((Outline.AppOutline _ _ direct indirect ) -toApp : State -> Pkg.Name -> Outline.AppOutline -> Dict Pkg.Name V.Version -> Dict Pkg.Name V.Version -> AppSolution +toApp : State -> Pkg.Name -> Outline.AppOutline -> Dict ( String, String ) Pkg.Name V.Version -> Dict ( String, String ) Pkg.Name V.Version -> AppSolution toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new = let - d : Dict Pkg.Name V.Version + d : Dict ( String, String ) Pkg.Name V.Version d = - Dict.intersection new (Dict.insert Pkg.compareName pkg V.one direct) + Dict.intersection Pkg.compareName new (Dict.insert identity pkg V.one direct) - i : Dict Pkg.Name V.Version + i : Dict ( String, String ) Pkg.Name V.Version i = - Dict.diff (getTransitive constraints new (Dict.toList d) Dict.empty) d + Dict.diff (getTransitive constraints new (Dict.toList compare d) Dict.empty) d - td : Dict Pkg.Name V.Version + td : Dict ( String, String ) Pkg.Name V.Version td = - Dict.intersection new (Dict.remove pkg testDirect) + Dict.intersection Pkg.compareName new (Dict.remove identity pkg testDirect) - ti : Dict Pkg.Name V.Version + ti : Dict ( String, String ) Pkg.Name V.Version ti = - Dict.diff new (Utils.mapUnions Pkg.compareName [ d, i, td ]) + Dict.diff new (Utils.mapUnions [ d, i, td ]) in AppSolution old new (Outline.AppOutline elm srcDirs d i td ti) -getTransitive : Dict ( Pkg.Name, V.Version ) Constraints -> Dict Pkg.Name V.Version -> List ( Pkg.Name, V.Version ) -> Dict Pkg.Name V.Version -> Dict Pkg.Name V.Version +getTransitive : Dict ( ( String, String ), ( Int, Int, Int ) ) ( Pkg.Name, V.Version ) Constraints -> Dict ( String, String ) Pkg.Name V.Version -> List ( Pkg.Name, V.Version ) -> Dict ( String, String ) Pkg.Name V.Version -> Dict ( String, String ) Pkg.Name V.Version getTransitive constraints solution unvisited visited = case unvisited of [] -> visited (( pkg, vsn ) as info) :: infos -> - if Dict.member pkg visited then + if Dict.member identity pkg visited then getTransitive constraints solution infos visited else let (Constraints _ newDeps) = - Utils.find info constraints + Utils.find (Tuple.mapSecond V.toComparable) info constraints newUnvisited : List ( Pkg.Name, V.Version ) newUnvisited = - Dict.toList (Dict.intersection solution (Dict.diff newDeps visited)) + Dict.toList compare (Dict.intersection Pkg.compareName solution (Dict.diff newDeps visited)) - newVisited : Dict Pkg.Name V.Version + newVisited : Dict ( String, String ) Pkg.Name V.Version newVisited = - Dict.insert Pkg.compareName pkg vsn visited + Dict.insert identity pkg vsn visited in getTransitive constraints solution infos <| getTransitive constraints solution newUnvisited newVisited @@ -222,7 +222,7 @@ getTransitive constraints solution unvisited visited = -- TRY -try : Dict Pkg.Name C.Constraint -> Solver (Dict Pkg.Name V.Version) +try : Dict ( String, String ) Pkg.Name C.Constraint -> Solver (Dict ( String, String ) Pkg.Name V.Version) try constraints = exploreGoals (Goals constraints Dict.empty) @@ -232,17 +232,17 @@ try constraints = type Goals - = Goals (Dict Pkg.Name C.Constraint) (Dict Pkg.Name V.Version) + = Goals (Dict ( String, String ) Pkg.Name C.Constraint) (Dict ( String, String ) Pkg.Name V.Version) -exploreGoals : Goals -> Solver (Dict Pkg.Name V.Version) +exploreGoals : Goals -> Solver (Dict ( String, String ) Pkg.Name V.Version) exploreGoals (Goals pending solved) = let - compare : ( Pkg.Name, b ) -> String - compare ( name, _ ) = - Pkg.toString name + compare : ( Pkg.Name, C.Constraint ) -> Pkg.Name + compare = + Tuple.first in - case Utils.mapMinViewWithKey Pkg.compareName compare pending of + case Utils.mapMinViewWithKey identity Basics.compare compare pending of Nothing -> pure solved @@ -267,10 +267,10 @@ addVersion (Goals pending solved) name version = |> bind (\(Constraints elm deps) -> if C.goodElm elm then - foldM (addConstraint solved) pending (Dict.toList deps) + foldM (addConstraint solved) pending (Dict.toList compare deps) |> fmap (\newPending -> - Goals newPending (Dict.insert Pkg.compareName name version solved) + Goals newPending (Dict.insert identity name version solved) ) else @@ -278,9 +278,9 @@ addVersion (Goals pending solved) name version = ) -addConstraint : Dict Pkg.Name V.Version -> Dict Pkg.Name C.Constraint -> ( Pkg.Name, C.Constraint ) -> Solver (Dict Pkg.Name C.Constraint) +addConstraint : Dict ( String, String ) Pkg.Name V.Version -> Dict ( String, String ) Pkg.Name C.Constraint -> ( Pkg.Name, C.Constraint ) -> Solver (Dict ( String, String ) Pkg.Name C.Constraint) addConstraint solved unsolved ( name, newConstraint ) = - case Dict.get name solved of + case Dict.get identity name solved of Just version -> if C.satisfies newConstraint version then pure unsolved @@ -289,9 +289,9 @@ addConstraint solved unsolved ( name, newConstraint ) = backtrack Nothing -> - case Dict.get name unsolved of + case Dict.get identity name unsolved of Nothing -> - pure (Dict.insert Pkg.compareName name newConstraint unsolved) + pure (Dict.insert identity name newConstraint unsolved) Just oldConstraint -> case C.intersect oldConstraint newConstraint of @@ -303,7 +303,7 @@ addConstraint solved unsolved ( name, newConstraint ) = pure unsolved else - pure (Dict.insert Pkg.compareName name mergedConstraint unsolved) + pure (Dict.insert identity name mergedConstraint unsolved) @@ -339,17 +339,8 @@ getConstraints pkg vsn = key : ( Pkg.Name, V.Version ) key = ( pkg, vsn ) - - compare : ( Pkg.Name, V.Version ) -> ( Pkg.Name, V.Version ) -> Order - compare ( pkg1, vsn1 ) ( pkg2, vsn2 ) = - case Pkg.compareName pkg1 pkg2 of - EQ -> - V.compare vsn1 vsn2 - - order -> - order in - case Dict.get key cDict of + case Dict.get (Tuple.mapSecond V.toComparable) key cDict of Just cs -> IO.pure (ISOk state cs) @@ -357,7 +348,7 @@ getConstraints pkg vsn = let toNewState : Constraints -> State toNewState cs = - State cache connection registry (Dict.insert compare key cs cDict) + State cache connection registry (Dict.insert (Tuple.mapSecond V.toComparable) key cs cDict) home : String home = diff --git a/src/Builder/Elm/Details.elm b/src/Builder/Elm/Details.elm index 25b046476..07dd28cb1 100644 --- a/src/Builder/Elm/Details.elm +++ b/src/Builder/Elm/Details.elm @@ -59,7 +59,7 @@ import Utils.Main as Utils exposing (FilePath, MVar) type Details - = Details File.Time ValidOutline BuildID (Dict ModuleName.Raw Local) (Dict ModuleName.Raw Foreign) Extras + = Details File.Time ValidOutline BuildID (Dict String ModuleName.Raw Local) (Dict String ModuleName.Raw Foreign) Extras type alias BuildID = @@ -68,7 +68,7 @@ type alias BuildID = type ValidOutline = ValidApp (NE.Nonempty Outline.SrcDir) - | ValidPkg Pkg.Name (List ModuleName.Raw) (Dict Pkg.Name V.Version {- for docs in reactor -}) + | ValidPkg Pkg.Name (List ModuleName.Raw) (Dict ( String, String ) Pkg.Name V.Version {- for docs in reactor -}) @@ -101,7 +101,7 @@ type Extras type alias Interfaces = - Dict TypeCheck.Canonical I.DependencyInterface + Dict (List String) TypeCheck.Canonical I.DependencyInterface @@ -253,7 +253,7 @@ type alias Task a = verifyPkg : Env -> File.Time -> Outline.PkgOutline -> Task Details verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) = if Con.goodElm elm then - union Pkg.compareName noDups direct testDirect + union identity Pkg.compareName noDups direct testDirect |> Task.bind (verifyConstraints env) |> Task.bind (\solution -> @@ -262,7 +262,7 @@ verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) exposedList = Outline.flattenExposed exposed - exactDeps : Dict Pkg.Name V.Version + exactDeps : Dict ( String, String ) Pkg.Name V.Version exactDeps = Dict.map (\_ (Solver.Details v _) -> v) solution @@ -296,13 +296,13 @@ verifyApp env time ((Outline.AppOutline elmVersion srcDirs direct _ _ _) as outl Task.throw (Exit.DetailsBadElmInAppOutline elmVersion) -checkAppDeps : Outline.AppOutline -> Task (Dict Pkg.Name V.Version) +checkAppDeps : Outline.AppOutline -> Task (Dict ( String, String ) Pkg.Name V.Version) checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) = - union Pkg.compareName allowEqualDups indirect testDirect + union identity Pkg.compareName allowEqualDups indirect testDirect |> Task.bind (\x -> - union Pkg.compareName noDups direct testIndirect - |> Task.bind (\y -> union Pkg.compareName noDups x y) + union identity Pkg.compareName noDups direct testIndirect + |> Task.bind (\y -> union identity Pkg.compareName noDups x y) ) @@ -310,7 +310,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) = -- VERIFY CONSTRAINTS -verifyConstraints : Env -> Dict Pkg.Name Con.Constraint -> Task (Dict Pkg.Name Solver.Details) +verifyConstraints : Env -> Dict ( String, String ) Pkg.Name Con.Constraint -> Task (Dict ( String, String ) Pkg.Name Solver.Details) verifyConstraints (Env _ _ _ cache _ connection registry) constraints = Task.io (Solver.verify cache connection registry constraints) |> Task.bind @@ -334,15 +334,15 @@ verifyConstraints (Env _ _ _ cache _ connection registry) constraints = -- UNION -union : (k -> k -> Order) -> (k -> v -> v -> Task v) -> Dict k v -> Dict k v -> Task (Dict k v) -union keyComparison tieBreaker deps1 deps2 = - Dict.merge - (\k dep -> Task.fmap (Dict.insert keyComparison k dep)) +union : (k -> comparable) -> (k -> k -> Order) -> (k -> v -> v -> Task v) -> Dict comparable k v -> Dict comparable k v -> Task (Dict comparable k v) +union toComparable keyComparison tieBreaker deps1 deps2 = + Dict.merge keyComparison + (\k dep -> Task.fmap (Dict.insert toComparable k dep)) (\k dep1 dep2 acc -> tieBreaker k dep1 dep2 - |> Task.bind (\v -> Task.fmap (Dict.insert keyComparison k v) acc) + |> Task.bind (\v -> Task.fmap (Dict.insert toComparable k v) acc) ) - (\k dep -> Task.fmap (Dict.insert keyComparison k dep)) + (\k dep -> Task.fmap (Dict.insert toComparable k dep)) deps1 deps2 (Task.pure Dict.empty) @@ -380,7 +380,7 @@ fork codec work = -- VERIFY DEPENDENCIES -verifyDependencies : Env -> File.Time -> ValidOutline -> Dict Pkg.Name Solver.Details -> Dict Pkg.Name a -> Task Details +verifyDependencies : Env -> File.Time -> ValidOutline -> Dict ( String, String ) Pkg.Name Solver.Details -> Dict ( String, String ) Pkg.Name a -> Task Details verifyDependencies ((Env key scope root cache _ _ _) as env) time outline solution directDeps = Task.eio identity (Reporting.report key (Reporting.DStart (Dict.size solution)) @@ -388,23 +388,23 @@ verifyDependencies ((Env key scope root cache _ _ _) as env) time outline soluti |> IO.bind (\mvar -> Stuff.withRegistryLock cache - (Utils.mapTraverseWithKey Pkg.compareName (\k v -> fork depCodec (verifyDep env mvar solution k v)) solution) + (Utils.mapTraverseWithKey identity Pkg.compareName (\k v -> fork depCodec (verifyDep env mvar solution k v)) solution) |> IO.bind (\mvars -> Utils.putMVar dictNameMVarDepCodec mvar mvars |> IO.bind (\_ -> - Utils.mapTraverse Pkg.compareName (Utils.readMVar depCodec) mvars + Utils.mapTraverse identity Pkg.compareName (Utils.readMVar depCodec) mvars |> IO.bind (\deps -> - case Utils.sequenceDictResult Pkg.compareName deps of + case Utils.sequenceDictResult identity Pkg.compareName deps of Err _ -> Stuff.getElmHome |> IO.fmap (\home -> Err (Exit.DetailsBadDeps home - (List.filterMap identity (Utils.eitherLefts (Dict.values deps))) + (List.filterMap identity (Utils.eitherLefts (Dict.values compare deps))) ) ) @@ -412,15 +412,15 @@ verifyDependencies ((Env key scope root cache _ _ _) as env) time outline soluti let objs : Opt.GlobalGraph objs = - Dict.foldr (\_ -> addObjects) Opt.empty artifacts + Dict.foldr compare (\_ -> addObjects) Opt.empty artifacts ifaces : Interfaces ifaces = - Dict.foldr (addInterfaces directDeps) Dict.empty artifacts + Dict.foldr compare (addInterfaces directDeps) Dict.empty artifacts - foreigns : Dict ModuleName.Raw Foreign + foreigns : Dict String ModuleName.Raw Foreign foreigns = - Dict.map (\_ -> OneOrMore.destruct Foreign) (Dict.foldr gatherForeigns Dict.empty (Dict.intersection artifacts directDeps)) + Dict.map (\_ -> OneOrMore.destruct Foreign) (Dict.foldr compare gatherForeigns Dict.empty (Dict.intersection compare artifacts directDeps)) details : Details details = @@ -442,14 +442,14 @@ addObjects (Artifacts _ objs) graph = Opt.addGlobalGraph objs graph -addInterfaces : Dict Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces +addInterfaces : Dict ( String, String ) Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces = - Dict.union ModuleName.compareCanonical + Dict.union dependencyInterfaces - (Dict.fromList ModuleName.compareCanonical + (Dict.fromList ModuleName.toComparableCanonical (List.map (Tuple.mapFirst (TypeCheck.Canonical pkg)) - (Dict.toList - (if Dict.member pkg directDeps then + (Dict.toList compare + (if Dict.member identity pkg directDeps then ifaces else @@ -460,7 +460,7 @@ addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces = ) -gatherForeigns : Pkg.Name -> Artifacts -> Dict ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Dict ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) +gatherForeigns : Pkg.Name -> Artifacts -> Dict String ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Dict String ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) gatherForeigns pkg (Artifacts ifaces _) foreigns = let isPublic : I.DependencyInterface -> Maybe (OneOrMore.OneOrMore Pkg.Name) @@ -472,7 +472,7 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns = I.Private _ _ _ -> Nothing in - Utils.mapUnionWith compare OneOrMore.more foreigns (Utils.mapMapMaybe compare isPublic ifaces) + Utils.mapUnionWith identity compare OneOrMore.more foreigns (Utils.mapMapMaybe identity compare isPublic ifaces) @@ -480,19 +480,19 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns = type Artifacts - = Artifacts (Dict ModuleName.Raw I.DependencyInterface) Opt.GlobalGraph + = Artifacts (Dict String ModuleName.Raw I.DependencyInterface) Opt.GlobalGraph type alias Dep = Result (Maybe Exit.DetailsBadDep) Artifacts -verifyDep : Env -> MVar (Dict Pkg.Name (MVar Dep)) -> Dict Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep +verifyDep : Env -> MVar (Dict ( String, String ) Pkg.Name (MVar Dep)) -> Dict ( String, String ) Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg ((Solver.Details vsn directDeps) as details) = let - fingerprint : Dict Pkg.Name V.Version + fingerprint : Dict ( String, String ) Pkg.Name V.Version fingerprint = - Utils.mapIntersectionWith Pkg.compareName (\(Solver.Details v _) _ -> v) solution directDeps + Utils.mapIntersectionWith identity Pkg.compareName (\(Solver.Details v _) _ -> v) solution directDeps in Utils.dirDoesDirectoryExist (Stuff.package cache pkg vsn ++ "/src") |> IO.bind @@ -509,7 +509,7 @@ verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg ((Solver.Details build key cache depsMVar pkg details fingerprint EverySet.empty Just (ArtifactCache fingerprints artifacts) -> - if EverySet.member fingerprint fingerprints then + if EverySet.member toComparableFingerprint fingerprint fingerprints then IO.fmap (\_ -> Ok artifacts) (Reporting.report key Reporting.DBuilt) else @@ -542,18 +542,24 @@ verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg ((Solver.Details type ArtifactCache - = ArtifactCache (EverySet Fingerprint) Artifacts + = ArtifactCache (EverySet (List ( ( String, String ), ( Int, Int, Int ) )) Fingerprint) Artifacts type alias Fingerprint = - Dict Pkg.Name V.Version + Dict ( String, String ) Pkg.Name V.Version + + +toComparableFingerprint : Fingerprint -> List ( ( String, String ), ( Int, Int, Int ) ) +toComparableFingerprint fingerprint = + Dict.toList compare fingerprint + |> List.map (Tuple.mapSecond V.toComparable) -- BUILD -build : Reporting.DKey -> Stuff.PackageCache -> MVar (Dict Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> EverySet Fingerprint -> IO Dep +build : Reporting.DKey -> Stuff.PackageCache -> MVar (Dict ( String, String ) Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> EverySet (List ( ( String, String ), ( Int, Int, Int ) )) Fingerprint -> IO Dep build key cache depsMVar pkg (Solver.Details vsn _) f fs = Outline.read (Stuff.package cache pkg vsn) |> IO.bind @@ -571,10 +577,10 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = Utils.readMVar dictPkgNameMVarDepCodec depsMVar |> IO.bind (\allDeps -> - Utils.mapTraverse Pkg.compareName (Utils.readMVar depCodec) (Dict.intersection allDeps deps) + Utils.mapTraverse identity Pkg.compareName (Utils.readMVar depCodec) (Dict.intersection compare allDeps deps) |> IO.bind (\directDeps -> - case Utils.sequenceDictResult Pkg.compareName directDeps of + case Utils.sequenceDictResult identity Pkg.compareName directDeps of Err _ -> Reporting.report key Reporting.DBroken |> IO.fmap (\_ -> Err Nothing) @@ -585,13 +591,13 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = src = Stuff.package cache pkg vsn ++ "/src" - foreignDeps : Dict ModuleName.Raw ForeignInterface + foreignDeps : Dict String ModuleName.Raw ForeignInterface foreignDeps = gatherForeignInterfaces directArtifacts - exposedDict : Dict ModuleName.Raw () + exposedDict : Dict String ModuleName.Raw () exposedDict = - Utils.mapFromKeys compare (\_ -> ()) (Outline.flattenExposed exposed) + Utils.mapFromKeys identity (\_ -> ()) (Outline.flattenExposed exposed) in getDocsStatus cache pkg vsn |> IO.bind @@ -599,15 +605,15 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = Utils.newEmptyMVar |> IO.bind (\mvar -> - Utils.mapTraverseWithKey compare (always << fork (Serialize.maybe statusCodec) << crawlModule foreignDeps mvar pkg src docsStatus) exposedDict + Utils.mapTraverseWithKey identity compare (always << fork (Serialize.maybe statusCodec) << crawlModule foreignDeps mvar pkg src docsStatus) exposedDict |> IO.bind (\mvars -> Utils.putMVar statusDictCodec mvar mvars - |> IO.bind (\_ -> Utils.dictMapM_ (Utils.readMVar (Serialize.maybe statusCodec)) mvars) - |> IO.bind (\_ -> IO.bind (Utils.mapTraverse compare (Utils.readMVar (Serialize.maybe statusCodec))) (Utils.readMVar statusDictCodec mvar)) + |> IO.bind (\_ -> Utils.dictMapM_ compare (Utils.readMVar (Serialize.maybe statusCodec)) mvars) + |> IO.bind (\_ -> IO.bind (Utils.mapTraverse identity compare (Utils.readMVar (Serialize.maybe statusCodec))) (Utils.readMVar statusDictCodec mvar)) |> IO.bind (\maybeStatuses -> - case Utils.sequenceDictMaybe compare maybeStatuses of + case Utils.sequenceDictMaybe identity compare maybeStatuses of Nothing -> Reporting.report key Reporting.DBroken |> IO.fmap (\_ -> Err (Just (Exit.BD_BadBuild pkg vsn f))) @@ -616,14 +622,14 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = Utils.newEmptyMVar |> IO.bind (\rmvar -> - Utils.mapTraverse compare (fork (Serialize.maybe dResultCodec) << compile pkg rmvar) statuses + Utils.mapTraverse identity compare (fork (Serialize.maybe dResultCodec) << compile pkg rmvar) statuses |> IO.bind (\rmvars -> Utils.putMVar dictRawMVarMaybeDResultCodec rmvar rmvars - |> IO.bind (\_ -> Utils.mapTraverse compare (Utils.readMVar (Serialize.maybe dResultCodec)) rmvars) + |> IO.bind (\_ -> Utils.mapTraverse identity compare (Utils.readMVar (Serialize.maybe dResultCodec)) rmvars) |> IO.bind (\maybeResults -> - case Utils.sequenceDictMaybe compare maybeResults of + case Utils.sequenceDictMaybe identity compare maybeResults of Nothing -> Reporting.report key Reporting.DBroken |> IO.fmap (\_ -> Err (Just (Exit.BD_BadBuild pkg vsn f))) @@ -634,7 +640,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = path = Stuff.package cache pkg vsn ++ "/artifacts.json" - ifaces : Dict ModuleName.Raw I.DependencyInterface + ifaces : Dict String ModuleName.Raw I.DependencyInterface ifaces = gatherInterfaces exposedDict results @@ -646,9 +652,9 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = artifacts = Artifacts ifaces objects - fingerprints : EverySet Fingerprint + fingerprints : EverySet (List ( ( String, String ), ( Int, Int, Int ) )) Fingerprint fingerprints = - EverySet.insert (\_ _ -> EQ) f fs + EverySet.insert toComparableFingerprint f fs in writeDocs cache pkg vsn docsStatus results |> IO.bind (\_ -> File.writeBinary artifactCacheCodec path (ArtifactCache fingerprints artifacts)) @@ -670,9 +676,9 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = -- GATHER -gatherObjects : Dict ModuleName.Raw DResult -> Opt.GlobalGraph +gatherObjects : Dict String ModuleName.Raw DResult -> Opt.GlobalGraph gatherObjects results = - Dict.foldr addLocalGraph Opt.empty results + Dict.foldr compare addLocalGraph Opt.empty results addLocalGraph : ModuleName.Raw -> DResult -> Opt.GlobalGraph -> Opt.GlobalGraph @@ -691,26 +697,26 @@ addLocalGraph name status graph = graph -gatherInterfaces : Dict ModuleName.Raw () -> Dict ModuleName.Raw DResult -> Dict ModuleName.Raw I.DependencyInterface +gatherInterfaces : Dict String ModuleName.Raw () -> Dict String ModuleName.Raw DResult -> Dict String ModuleName.Raw I.DependencyInterface gatherInterfaces exposed artifacts = let onLeft : a -> b -> c -> d onLeft _ _ _ = crash "compiler bug manifesting in Elm.Details.gatherInterfaces" - onBoth : comparable -> () -> DResult -> Dict comparable I.DependencyInterface -> Dict comparable I.DependencyInterface + onBoth : comparable -> () -> DResult -> Dict comparable comparable I.DependencyInterface -> Dict comparable comparable I.DependencyInterface onBoth k () iface = toLocalInterface I.public iface - |> Maybe.map (Dict.insert compare k) + |> Maybe.map (Dict.insert identity k) |> Maybe.withDefault identity - onRight : comparable -> DResult -> Dict comparable I.DependencyInterface -> Dict comparable I.DependencyInterface + onRight : comparable -> DResult -> Dict comparable comparable I.DependencyInterface -> Dict comparable comparable I.DependencyInterface onRight k iface = toLocalInterface I.private iface - |> Maybe.map (Dict.insert compare k) + |> Maybe.map (Dict.insert identity k) |> Maybe.withDefault identity in - Dict.merge onLeft onBoth onRight exposed artifacts Dict.empty + Dict.merge compare onLeft onBoth onRight exposed artifacts Dict.empty toLocalInterface : (I.Interface -> a) -> DResult -> Maybe a @@ -738,7 +744,7 @@ type ForeignInterface | ForeignSpecific I.Interface -gatherForeignInterfaces : Dict Pkg.Name Artifacts -> Dict ModuleName.Raw ForeignInterface +gatherForeignInterfaces : Dict ( String, String ) Pkg.Name Artifacts -> Dict String ModuleName.Raw ForeignInterface gatherForeignInterfaces directArtifacts = let finalize : I.Interface -> List I.Interface -> ForeignInterface @@ -750,9 +756,9 @@ gatherForeignInterfaces directArtifacts = _ :: _ -> ForeignAmbiguous - gather : Pkg.Name -> Artifacts -> Dict ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Dict ModuleName.Raw (OneOrMore.OneOrMore I.Interface) + gather : Pkg.Name -> Artifacts -> Dict String ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Dict String ModuleName.Raw (OneOrMore.OneOrMore I.Interface) gather _ (Artifacts ifaces _) buckets = - Utils.mapUnionWith compare OneOrMore.more buckets (Utils.mapMapMaybe compare isPublic ifaces) + Utils.mapUnionWith identity compare OneOrMore.more buckets (Utils.mapMapMaybe identity compare isPublic ifaces) isPublic : I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface) isPublic di = @@ -764,7 +770,7 @@ gatherForeignInterfaces directArtifacts = Nothing in Dict.map (\_ -> OneOrMore.destruct finalize) <| - Dict.foldr gather Dict.empty directArtifacts + Dict.foldr compare gather Dict.empty directArtifacts @@ -772,17 +778,17 @@ gatherForeignInterfaces directArtifacts = type alias StatusDict = - Dict ModuleName.Raw (MVar (Maybe Status)) + Dict String ModuleName.Raw (MVar (Maybe Status)) type Status - = SLocal DocsStatus (Dict ModuleName.Raw ()) Src.Module + = SLocal DocsStatus (Dict String ModuleName.Raw ()) Src.Module | SForeign I.Interface | SKernelLocal (List Kernel.Chunk) | SKernelForeign -crawlModule : Dict ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status) +crawlModule : Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status) crawlModule foreignDeps mvar pkg src docsStatus name = let path : FilePath @@ -792,7 +798,7 @@ crawlModule foreignDeps mvar pkg src docsStatus name = File.exists path |> IO.bind (\exists -> - case Dict.get name foreignDeps of + case Dict.get identity name foreignDeps of Just ForeignAmbiguous -> IO.pure Nothing @@ -815,7 +821,7 @@ crawlModule foreignDeps mvar pkg src docsStatus name = ) -crawlFile : Dict ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status) +crawlFile : Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status) crawlFile foreignDeps mvar pkg src docsStatus expectedName path = File.readUtf8 path |> IO.bind @@ -834,31 +840,31 @@ crawlFile foreignDeps mvar pkg src docsStatus expectedName path = ) -crawlImports : Dict ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> List Src.Import -> IO (Dict ModuleName.Raw ()) +crawlImports : Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> List Src.Import -> IO (Dict String ModuleName.Raw ()) crawlImports foreignDeps mvar pkg src imports = Utils.takeMVar statusDictCodec mvar |> IO.bind (\statusDict -> let - deps : Dict Name.Name () + deps : Dict String Name.Name () deps = - Dict.fromList compare (List.map (\i -> ( Src.getImportName i, () )) imports) + Dict.fromList identity (List.map (\i -> ( Src.getImportName i, () )) imports) - news : Dict Name.Name () + news : Dict String Name.Name () news = Dict.diff deps statusDict in - Utils.mapTraverseWithKey compare (always << fork (Serialize.maybe statusCodec) << crawlModule foreignDeps mvar pkg src DocsNotNeeded) news + Utils.mapTraverseWithKey identity compare (always << fork (Serialize.maybe statusCodec) << crawlModule foreignDeps mvar pkg src DocsNotNeeded) news |> IO.bind (\mvars -> - Utils.putMVar statusDictCodec mvar (Dict.union compare mvars statusDict) - |> IO.bind (\_ -> Utils.dictMapM_ (Utils.readMVar (Serialize.maybe statusCodec)) mvars) + Utils.putMVar statusDictCodec mvar (Dict.union mvars statusDict) + |> IO.bind (\_ -> Utils.dictMapM_ compare (Utils.readMVar (Serialize.maybe statusCodec)) mvars) |> IO.fmap (\_ -> deps) ) ) -crawlKernel : Dict ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status) +crawlKernel : Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status) crawlKernel foreignDeps mvar pkg src name = let path : FilePath @@ -872,7 +878,7 @@ crawlKernel foreignDeps mvar pkg src name = File.readUtf8 path |> IO.bind (\bytes -> - case Kernel.fromByteString pkg (Utils.mapMapMaybe compare getDepHome foreignDeps) bytes of + case Kernel.fromByteString pkg (Utils.mapMapMaybe identity compare getDepHome foreignDeps) bytes of Nothing -> IO.pure Nothing @@ -907,19 +913,19 @@ type DResult | RKernelForeign -compile : Pkg.Name -> MVar (Dict ModuleName.Raw (MVar (Maybe DResult))) -> Status -> IO (Maybe DResult) +compile : Pkg.Name -> MVar (Dict String ModuleName.Raw (MVar (Maybe DResult))) -> Status -> IO (Maybe DResult) compile pkg mvar status = case status of SLocal docsStatus deps modul -> Utils.readMVar moduleNameRawMVarMaybeDResultCodec mvar |> IO.bind (\resultsDict -> - Utils.mapTraverse compare (Utils.readMVar (Serialize.maybe dResultCodec)) (Dict.intersection resultsDict deps) + Utils.mapTraverse identity compare (Utils.readMVar (Serialize.maybe dResultCodec)) (Dict.intersection compare resultsDict deps) |> IO.bind (\maybeResults -> - case Utils.sequenceDictMaybe compare maybeResults of + case Utils.sequenceDictMaybe identity compare maybeResults of Just results -> - Compile.compile pkg (Utils.mapMapMaybe compare getInterface results) modul + Compile.compile pkg (Utils.mapMapMaybe identity compare getInterface results) modul |> IO.fmap (\result -> case result of @@ -1007,12 +1013,12 @@ makeDocs status modul = Nothing -writeDocs : Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Dict ModuleName.Raw DResult -> IO () +writeDocs : Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Dict String ModuleName.Raw DResult -> IO () writeDocs cache pkg vsn status results = case status of DocsNeeded -> E.writeUgly (Stuff.package cache pkg vsn ++ "/docs.json") - (Docs.encode (Utils.mapMapMaybe compare toDocs results)) + (Docs.encode (Utils.mapMapMaybe identity compare toDocs results)) DocsNotNeeded -> IO.pure () @@ -1092,15 +1098,15 @@ detailsCodec = File.timeCodec validOutlineCodec Serialize.int - (S.assocListDict compare ModuleName.rawCodec localCodec) - (S.assocListDict compare ModuleName.rawCodec foreignCodec) + (S.assocListDict identity compare ModuleName.rawCodec localCodec) + (S.assocListDict identity compare ModuleName.rawCodec foreignCodec) extrasCodec |> Serialize.finishCustomType interfacesCodec : Codec e Interfaces interfacesCodec = - S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec + S.assocListDict ModuleName.toComparableCanonical ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec resultRegistryProblemEnvCodec : Codec e (Result Exit.RegistryProblem Solver.Env) @@ -1119,13 +1125,13 @@ artifactsCodec = (\artifactsCodecEncoder (Artifacts ifaces objects) -> artifactsCodecEncoder ifaces objects ) - |> Serialize.variant2 Artifacts (S.assocListDict compare ModuleName.rawCodec I.dependencyInterfaceCodec) Opt.globalGraphCodec + |> Serialize.variant2 Artifacts (S.assocListDict identity compare ModuleName.rawCodec I.dependencyInterfaceCodec) Opt.globalGraphCodec |> Serialize.finishCustomType -dictNameMVarDepCodec : Codec e (Dict Pkg.Name (MVar Dep)) +dictNameMVarDepCodec : Codec e (Dict ( String, String ) Pkg.Name (MVar Dep)) dictNameMVarDepCodec = - S.assocListDict Pkg.compareName Pkg.nameCodec Utils.mVarCodec + S.assocListDict identity Pkg.compareName Pkg.nameCodec Utils.mVarCodec artifactCacheCodec : Codec e ArtifactCache @@ -1134,13 +1140,13 @@ artifactCacheCodec = (\artifactCacheCodecEncoder (ArtifactCache fingerprints artifacts) -> artifactCacheCodecEncoder fingerprints artifacts ) - |> Serialize.variant2 ArtifactCache (S.everySet (\_ _ -> EQ) fingerprintCodec) artifactsCodec + |> Serialize.variant2 ArtifactCache (S.everySet toComparableFingerprint (\_ _ -> EQ) fingerprintCodec) artifactsCodec |> Serialize.finishCustomType -dictPkgNameMVarDepCodec : Codec e (Dict Pkg.Name (MVar Dep)) +dictPkgNameMVarDepCodec : Codec e (Dict ( String, String ) Pkg.Name (MVar Dep)) dictPkgNameMVarDepCodec = - S.assocListDict Pkg.compareName Pkg.nameCodec Utils.mVarCodec + S.assocListDict identity Pkg.compareName Pkg.nameCodec Utils.mVarCodec statusCodec : Codec e Status @@ -1160,21 +1166,21 @@ statusCodec = SKernelForeign -> sKernelForeignEncoder ) - |> Serialize.variant3 SLocal docsStatusCodec (S.assocListDict compare ModuleName.rawCodec Serialize.unit) Src.moduleCodec + |> Serialize.variant3 SLocal docsStatusCodec (S.assocListDict identity compare ModuleName.rawCodec Serialize.unit) Src.moduleCodec |> Serialize.variant1 SForeign I.interfaceCodec |> Serialize.variant1 SKernelLocal (Serialize.list Kernel.chunkCodec) |> Serialize.variant0 SKernelForeign |> Serialize.finishCustomType -dictRawMVarMaybeDResultCodec : Codec e (Dict ModuleName.Raw (MVar (Maybe DResult))) +dictRawMVarMaybeDResultCodec : Codec e (Dict String ModuleName.Raw (MVar (Maybe DResult))) dictRawMVarMaybeDResultCodec = - S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec + S.assocListDict identity compare ModuleName.rawCodec Utils.mVarCodec -moduleNameRawMVarMaybeDResultCodec : Codec e (Dict ModuleName.Raw (MVar (Maybe DResult))) +moduleNameRawMVarMaybeDResultCodec : Codec e (Dict String ModuleName.Raw (MVar (Maybe DResult))) moduleNameRawMVarMaybeDResultCodec = - S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec + S.assocListDict identity compare ModuleName.rawCodec Utils.mVarCodec dResultCodec : Codec e DResult @@ -1203,7 +1209,7 @@ dResultCodec = statusDictCodec : Codec e StatusDict statusDictCodec = - S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec + S.assocListDict identity compare ModuleName.rawCodec Utils.mVarCodec localCodec : Codec e Local @@ -1228,7 +1234,7 @@ validOutlineCodec = validPkgEncoder pkg exposedList exactDeps ) |> Serialize.variant1 ValidApp (S.nonempty Outline.srcDirCodec) - |> Serialize.variant3 ValidPkg Pkg.nameCodec (Serialize.list ModuleName.rawCodec) (S.assocListDict Pkg.compareName Pkg.nameCodec V.versionCodec) + |> Serialize.variant3 ValidPkg Pkg.nameCodec (Serialize.list ModuleName.rawCodec) (S.assocListDict identity Pkg.compareName Pkg.nameCodec V.versionCodec) |> Serialize.finishCustomType @@ -1260,7 +1266,7 @@ extrasCodec = fingerprintCodec : Codec e Fingerprint fingerprintCodec = - S.assocListDict Pkg.compareName Pkg.nameCodec V.versionCodec + S.assocListDict identity Pkg.compareName Pkg.nameCodec V.versionCodec docsStatusCodec : Codec e DocsStatus diff --git a/src/Builder/Elm/Outline.elm b/src/Builder/Elm/Outline.elm index d799fff9a..bddf98007 100644 --- a/src/Builder/Elm/Outline.elm +++ b/src/Builder/Elm/Outline.elm @@ -46,11 +46,11 @@ type Outline type AppOutline - = AppOutline V.Version (NE.Nonempty SrcDir) (Dict Pkg.Name V.Version) (Dict Pkg.Name V.Version) (Dict Pkg.Name V.Version) (Dict Pkg.Name V.Version) + = AppOutline V.Version (NE.Nonempty SrcDir) (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) type PkgOutline - = PkgOutline Pkg.Name String Licenses.License V.Version Exposed (Dict Pkg.Name Con.Constraint) (Dict Pkg.Name Con.Constraint) Con.Constraint + = PkgOutline Pkg.Name String Licenses.License V.Version Exposed (Dict ( String, String ) Pkg.Name Con.Constraint) (Dict ( String, String ) Pkg.Name Con.Constraint) Con.Constraint type Exposed @@ -150,7 +150,7 @@ encodeModule name = E.name name -encodeDeps : (a -> E.Value) -> Dict Pkg.Name a -> E.Value +encodeDeps : (a -> E.Value) -> Dict ( String, String ) Pkg.Name a -> E.Value encodeDeps encodeValue deps = E.dict Pkg.compareName Pkg.toJsonString encodeValue deps @@ -182,17 +182,17 @@ read root = case outline of Pkg (PkgOutline pkg _ _ _ _ deps _ _) -> IO.pure <| - if not (Dict.member Pkg.core deps) && pkg /= Pkg.core then + if not (Dict.member identity Pkg.core deps) && pkg /= Pkg.core then Err Exit.OutlineNoPkgCore else Ok outline App (AppOutline _ srcDirs direct indirect _ _) -> - if not (Dict.member Pkg.core direct) then + if not (Dict.member identity Pkg.core direct) then IO.pure <| Err Exit.OutlineNoAppCore - else if not (Dict.member Pkg.json direct) && not (Dict.member Pkg.json indirect) then + else if not (Dict.member identity Pkg.json direct) && not (Dict.member identity Pkg.json indirect) then IO.pure <| Err Exit.OutlineNoAppJson else @@ -249,8 +249,8 @@ detectDuplicates root srcDirs = |> IO.fmap (\pairs -> Utils.mapLookupMin <| - Utils.mapMapMaybe compare isDup <| - Utils.mapFromListWith compare OneOrMore.more pairs + Utils.mapMapMaybe identity compare isDup <| + Utils.mapFromListWith identity OneOrMore.more pairs ) @@ -356,9 +356,9 @@ constraintDecoder = D.mapError Exit.OP_BadConstraint Con.decoder -depsDecoder : Decoder a -> Decoder (Dict Pkg.Name a) +depsDecoder : Decoder a -> Decoder (Dict ( String, String ) Pkg.Name a) depsDecoder valueDecoder = - D.dict Pkg.compareName (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder + D.dict identity (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder dirsDecoder : Decoder (NE.Nonempty SrcDir) diff --git a/src/Builder/Generate.elm b/src/Builder/Generate.elm index 9c2c778a3..aab010d0d 100644 --- a/src/Builder/Generate.elm +++ b/src/Builder/Generate.elm @@ -60,7 +60,7 @@ debug root details (Build.Artifacts pkg ifaces roots modules) = graph = objectsToGlobalGraph objects - mains : Dict TypeCheck.Canonical Opt.Main + mains : Dict (List String) TypeCheck.Canonical Opt.Main mains = gatherMains pkg objects roots in @@ -84,7 +84,7 @@ dev root details (Build.Artifacts pkg _ roots modules) = graph = objectsToGlobalGraph objects - mains : Dict TypeCheck.Canonical Opt.Main + mains : Dict (List String) TypeCheck.Canonical Opt.Main mains = gatherMains pkg objects roots in @@ -109,7 +109,7 @@ prod root details (Build.Artifacts pkg _ roots modules) = mode = Mode.Prod (Mode.shortenFieldNames graph) - mains : Dict TypeCheck.Canonical Opt.Main + mains : Dict (List String) TypeCheck.Canonical Opt.Main mains = gatherMains pkg objects roots in @@ -128,7 +128,7 @@ repl root details ansi (Build.ReplArtifacts home modules localizer annotations) graph = objectsToGlobalGraph objects in - JS.generateForRepl ansi localizer graph home name (Utils.find name annotations) + JS.generateForRepl ansi localizer graph home name (Utils.find identity name annotations) ) @@ -138,7 +138,7 @@ repl root details ansi (Build.ReplArtifacts home modules localizer annotations) checkForDebugUses : Objects -> Task () checkForDebugUses (Objects _ locals) = - case Dict.keys (Dict.filter (\_ -> Nitpick.hasDebugUses) locals) of + case Dict.keys compare (Dict.filter (\_ -> Nitpick.hasDebugUses) locals) of [] -> Task.pure () @@ -150,12 +150,12 @@ checkForDebugUses (Objects _ locals) = -- GATHER MAINS -gatherMains : Pkg.Name -> Objects -> NE.Nonempty Build.Root -> Dict TypeCheck.Canonical Opt.Main +gatherMains : Pkg.Name -> Objects -> NE.Nonempty Build.Root -> Dict (List String) TypeCheck.Canonical Opt.Main gatherMains pkg (Objects _ locals) roots = - Dict.fromList ModuleName.compareCanonical (List.filterMap (lookupMain pkg locals) (NE.toList roots)) + Dict.fromList ModuleName.toComparableCanonical (List.filterMap (lookupMain pkg locals) (NE.toList roots)) -lookupMain : Pkg.Name -> Dict ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe ( TypeCheck.Canonical, Opt.Main ) +lookupMain : Pkg.Name -> Dict String ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe ( TypeCheck.Canonical, Opt.Main ) lookupMain pkg locals root = let toPair : N.Name -> Opt.LocalGraph -> Maybe ( TypeCheck.Canonical, Opt.Main ) @@ -164,7 +164,7 @@ lookupMain pkg locals root = in case root of Build.Inside name -> - Maybe.andThen (toPair name) (Dict.get name locals) + Maybe.andThen (toPair name) (Dict.get identity name locals) Build.Outside name _ g -> toPair name g @@ -175,7 +175,7 @@ lookupMain pkg locals root = type LoadingObjects - = LoadingObjects (MVar (Maybe Opt.GlobalGraph)) (Dict ModuleName.Raw (MVar (Maybe Opt.LocalGraph))) + = LoadingObjects (MVar (Maybe Opt.GlobalGraph)) (Dict String ModuleName.Raw (MVar (Maybe Opt.LocalGraph))) loadObjects : FilePath -> Details.Details -> List Build.Module -> Task LoadingObjects @@ -187,7 +187,7 @@ loadObjects root details modules = Utils.listTraverse (loadObject root) modules |> IO.fmap (\mvars -> - LoadingObjects mvar (Dict.fromList compare mvars) + LoadingObjects mvar (Dict.fromList identity mvars) ) ) ) @@ -214,7 +214,7 @@ loadObject root modul = type Objects - = Objects Opt.GlobalGraph (Dict ModuleName.Raw Opt.LocalGraph) + = Objects Opt.GlobalGraph (Dict String ModuleName.Raw Opt.LocalGraph) finalizeObjects : LoadingObjects -> Task Objects @@ -223,10 +223,10 @@ finalizeObjects (LoadingObjects mvar mvars) = (Utils.readMVar (Serialize.maybe Opt.globalGraphCodec) mvar |> IO.bind (\result -> - Utils.mapTraverse compare (Utils.readMVar (Serialize.maybe Opt.localGraphCodec)) mvars + Utils.mapTraverse identity compare (Utils.readMVar (Serialize.maybe Opt.localGraphCodec)) mvars |> IO.fmap (\results -> - case Maybe.map2 Objects result (Utils.sequenceDictMaybe compare results) of + case Maybe.map2 Objects result (Utils.sequenceDictMaybe identity compare results) of Just loaded -> Ok loaded @@ -239,14 +239,14 @@ finalizeObjects (LoadingObjects mvar mvars) = objectsToGlobalGraph : Objects -> Opt.GlobalGraph objectsToGlobalGraph (Objects globals locals) = - Dict.foldr (\_ -> Opt.addLocalGraph) globals locals + Dict.foldr compare (\_ -> Opt.addLocalGraph) globals locals -- LOAD TYPES -loadTypes : FilePath -> Dict TypeCheck.Canonical I.DependencyInterface -> List Build.Module -> Task Extract.Types +loadTypes : FilePath -> Dict (List String) TypeCheck.Canonical I.DependencyInterface -> List Build.Module -> Task Extract.Types loadTypes root ifaces modules = Task.eio identity (Utils.listTraverse (loadTypesHelp root) modules @@ -255,7 +255,7 @@ loadTypes root ifaces modules = let foreigns : Extract.Types foreigns = - Extract.mergeMany (Dict.values (Dict.map Extract.fromDependencyInterface ifaces)) + Extract.mergeMany (Dict.values ModuleName.compareCanonical (Dict.map Extract.fromDependencyInterface ifaces)) in Utils.listTraverse (Utils.readMVar (Serialize.maybe Extract.typesCodec)) mvars |> IO.fmap diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm index 3a0b645c7..fb4f0025e 100644 --- a/src/Builder/Reporting/Exit.elm +++ b/src/Builder/Reporting/Exit.elm @@ -1840,7 +1840,7 @@ type Details type DetailsBadDep = BD_BadDownload Pkg.Name V.Version PackageProblem - | BD_BadBuild Pkg.Name V.Version (Dict Pkg.Name V.Version) + | BD_BadBuild Pkg.Name V.Version (Dict ( String, String ) Pkg.Name V.Version) toDetailsReport : Details -> Help.Report @@ -2019,7 +2019,7 @@ toDetailsReport details = , D.indent 4 <| D.vcat <| List.map (\( p, v ) -> D.fromChars <| Pkg.toChars p ++ " " ++ V.toChars v) <| - Dict.toList fingerprint + Dict.toList compare fingerprint , D.reflow <| "If you want to help out even more, try building the package locally. That should give you much more specific information about why this package is failing to build, which will in turn make it easier for the package author to fix it!" ] @@ -2832,7 +2832,7 @@ detailsBadDepCodec = bdBadBuildEncoder pkg vsn fingerprint ) |> Serialize.variant3 BD_BadDownload Pkg.nameCodec V.versionCodec packageProblemCodec - |> Serialize.variant3 BD_BadBuild Pkg.nameCodec V.versionCodec (S.assocListDict Pkg.compareName Pkg.nameCodec V.versionCodec) + |> Serialize.variant3 BD_BadBuild Pkg.nameCodec V.versionCodec (S.assocListDict identity Pkg.compareName Pkg.nameCodec V.versionCodec) |> Serialize.finishCustomType diff --git a/src/Compiler/AST/Canonical.elm b/src/Compiler/AST/Canonical.elm index 2f82c4b43..b74fdd09e 100644 --- a/src/Compiler/AST/Canonical.elm +++ b/src/Compiler/AST/Canonical.elm @@ -101,8 +101,8 @@ type Expr_ | Case Expr (List CaseBranch) | Accessor Name | Access Expr (A.Located Name) - | Update Name Expr (Dict Name FieldUpdate) - | Record (Dict Name Expr) + | Update Name Expr (Dict String Name FieldUpdate) + | Record (Dict String Name Expr) | Unit | Tuple Expr Expr (Maybe Expr) | Shader Shader.Source Shader.Types @@ -184,14 +184,14 @@ type Annotation type alias FreeVars = - Dict Name () + Dict String Name () type Type = TLambda Type Type | TVar Name | TType IO.Canonical Name (List Type) - | TRecord (Dict Name FieldType) (Maybe Name) + | TRecord (Dict String Name FieldType) (Maybe Name) | TUnit | TTuple Type Type (Maybe Type) | TAlias IO.Canonical Name (List ( Name, Type )) AliasType @@ -212,7 +212,7 @@ type FieldType -- the orders will all be zeros. -fieldsToList : Dict Name FieldType -> List ( Name, Type ) +fieldsToList : Dict String Name FieldType -> List ( Name, Type ) fieldsToList fields = let getIndex : ( a, FieldType ) -> Int @@ -223,7 +223,7 @@ fieldsToList fields = dropIndex ( name, FieldType _ tipe ) = ( name, tipe ) in - Dict.toList fields + Dict.toList compare fields |> List.sortBy getIndex |> List.map dropIndex @@ -233,7 +233,7 @@ fieldsToList fields = type Module - = Module IO.Canonical Exports Src.Docs Decls (Dict Name Union) (Dict Name Alias) (Dict Name Binop) Effects + = Module IO.Canonical Exports Src.Docs Decls (Dict String Name Union) (Dict String Name Alias) (Dict String Name Binop) Effects type Alias @@ -270,7 +270,7 @@ type Ctor type Exports = ExportEverything A.Region - | Export (Dict Name (A.Located Export)) + | Export (Dict String Name (A.Located Export)) type Export @@ -284,7 +284,7 @@ type Export type Effects = NoEffects - | Ports (Dict Name Port) + | Ports (Dict String Name Port) | Manager A.Region A.Region A.Region Manager @@ -323,7 +323,7 @@ annotationCodec = freeVarsCodec : Codec e FreeVars freeVarsCodec = - S.assocListDict compare Serialize.string Serialize.unit + S.assocListDict identity compare Serialize.string Serialize.unit aliasCodec : Codec e Alias @@ -365,7 +365,7 @@ typeCodec = |> Serialize.variant2 TLambda (Serialize.lazy (\() -> typeCodec)) (Serialize.lazy (\() -> typeCodec)) |> Serialize.variant1 TVar Serialize.string |> Serialize.variant3 TType ModuleName.canonicalCodec Serialize.string (Serialize.list (Serialize.lazy (\() -> typeCodec))) - |> Serialize.variant2 TRecord (S.assocListDict compare Serialize.string fieldTypeCodec) (Serialize.maybe Serialize.string) + |> Serialize.variant2 TRecord (S.assocListDict identity compare Serialize.string fieldTypeCodec) (Serialize.maybe Serialize.string) |> Serialize.variant0 TUnit |> Serialize.variant3 TTuple (Serialize.lazy (\() -> typeCodec)) (Serialize.lazy (\() -> typeCodec)) (Serialize.maybe (Serialize.lazy (\() -> typeCodec))) |> Serialize.variant4 TAlias ModuleName.canonicalCodec Serialize.string (Serialize.list (Serialize.tuple Serialize.string (Serialize.lazy (\() -> typeCodec)))) aliasTypeCodec @@ -614,8 +614,8 @@ expr_Codec = Update Serialize.string (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) - (S.assocListDict compare Serialize.string fieldUpdateCodec) - |> Serialize.variant1 Record (S.assocListDict compare Serialize.string (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + (S.assocListDict identity compare Serialize.string fieldUpdateCodec) + |> Serialize.variant1 Record (S.assocListDict identity compare Serialize.string (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) |> Serialize.variant0 Unit |> Serialize.variant3 Tuple diff --git a/src/Compiler/AST/Optimized.elm b/src/Compiler/AST/Optimized.elm index 978a60096..570cb9a24 100644 --- a/src/Compiler/AST/Optimized.elm +++ b/src/Compiler/AST/Optimized.elm @@ -18,6 +18,7 @@ module Compiler.AST.Optimized exposing , empty , globalGraphCodec , localGraphCodec + , toComparableGlobal , toKernelGlobal ) @@ -64,11 +65,11 @@ type Expr | Case Name Name (Decider Choice) (List ( Int, Expr )) | Accessor Name | Access Expr Name - | Update Expr (Dict Name Expr) - | Record (Dict Name Expr) + | Update Expr (Dict String Name Expr) + | Record (Dict String Name Expr) | Unit | Tuple Expr Expr (Maybe Expr) - | Shader Shader.Source (EverySet Name) (EverySet Name) + | Shader Shader.Source (EverySet String Name) (EverySet String Name) type Global @@ -88,6 +89,11 @@ compareGlobal (Global home1 name1) (Global home2 name2) = GT +toComparableGlobal : Global -> List String +toComparableGlobal (Global home name) = + ModuleName.toComparableCanonical home ++ [ name ] + + -- DEFINITIONS @@ -128,15 +134,15 @@ type Choice type GlobalGraph - = GlobalGraph (Dict Global Node) (Dict Name Int) + = GlobalGraph (Dict (List String) Global Node) (Dict String Name Int) type LocalGraph = LocalGraph (Maybe Main) -- PERF profile switching Global to Name - (Dict Global Node) - (Dict Name Int) + (Dict (List String) Global Node) + (Dict String Name Int) type Main @@ -145,17 +151,17 @@ type Main type Node - = Define Expr (EverySet Global) - | DefineTailFunc (List Name) Expr (EverySet Global) + = Define Expr (EverySet (List String) Global) + | DefineTailFunc (List Name) Expr (EverySet (List String) Global) | Ctor Index.ZeroBased Int | Enum Index.ZeroBased | Box | Link Global - | Cycle (List Name) (List ( Name, Expr )) (List Def) (EverySet Global) + | Cycle (List Name) (List ( Name, Expr )) (List Def) (EverySet (List String) Global) | Manager EffectsType - | Kernel (List K.Chunk) (EverySet Global) - | PortIncoming Expr (EverySet Global) - | PortOutgoing Expr (EverySet Global) + | Kernel (List K.Chunk) (EverySet (List String) Global) + | PortIncoming Expr (EverySet (List String) Global) + | PortOutgoing Expr (EverySet (List String) Global) type EffectsType @@ -176,15 +182,15 @@ empty = addGlobalGraph : GlobalGraph -> GlobalGraph -> GlobalGraph addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) = GlobalGraph - (Dict.union compareGlobal nodes1 nodes2) - (Dict.union compare fields1 fields2) + (Dict.union nodes1 nodes2) + (Dict.union fields1 fields2) addLocalGraph : LocalGraph -> GlobalGraph -> GlobalGraph addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) = GlobalGraph - (Dict.union compareGlobal nodes1 nodes2) - (Dict.union compare fields1 fields2) + (Dict.union nodes1 nodes2) + (Dict.union fields1 fields2) addKernel : Name -> List K.Chunk -> GlobalGraph -> GlobalGraph @@ -199,21 +205,21 @@ addKernel shortName chunks (GlobalGraph nodes fields) = Kernel chunks (List.foldr addKernelDep EverySet.empty chunks) in GlobalGraph - (Dict.insert compareGlobal global node nodes) - (Dict.union compare (K.countFields chunks) fields) + (Dict.insert toComparableGlobal global node nodes) + (Dict.union (K.countFields chunks) fields) -addKernelDep : K.Chunk -> EverySet Global -> EverySet Global +addKernelDep : K.Chunk -> EverySet (List String) Global -> EverySet (List String) Global addKernelDep chunk deps = case chunk of K.JS _ -> deps K.ElmVar home name -> - EverySet.insert compareGlobal (Global home name) deps + EverySet.insert toComparableGlobal (Global home name) deps K.JsVar shortName _ -> - EverySet.insert compareGlobal (toKernelGlobal shortName) deps + EverySet.insert toComparableGlobal (toKernelGlobal shortName) deps K.ElmField _ -> deps @@ -246,7 +252,7 @@ globalGraphCodec = (\globalGraphCodecEncoder (GlobalGraph nodes fields) -> globalGraphCodecEncoder nodes fields ) - |> Serialize.variant2 GlobalGraph (S.assocListDict compareGlobal globalCodec nodeCodec) (S.assocListDict compare Serialize.string Serialize.int) + |> Serialize.variant2 GlobalGraph (S.assocListDict toComparableGlobal compareGlobal globalCodec nodeCodec) (S.assocListDict identity compare Serialize.string Serialize.int) |> Serialize.finishCustomType @@ -258,8 +264,8 @@ localGraphCodec = ) |> Serialize.variant3 LocalGraph (Serialize.maybe mainCodec) - (S.assocListDict compareGlobal globalCodec nodeCodec) - (S.assocListDict compare Serialize.string Serialize.int) + (S.assocListDict toComparableGlobal compareGlobal globalCodec nodeCodec) + (S.assocListDict identity compare Serialize.string Serialize.int) |> Serialize.finishCustomType @@ -327,17 +333,17 @@ nodeCodec = PortOutgoing encoder deps -> portOutgoingEncoder encoder deps ) - |> Serialize.variant2 Define exprCodec (S.everySet compareGlobal globalCodec) - |> Serialize.variant3 DefineTailFunc (Serialize.list Serialize.string) exprCodec (S.everySet compareGlobal globalCodec) + |> Serialize.variant2 Define exprCodec (S.everySet toComparableGlobal compareGlobal globalCodec) + |> Serialize.variant3 DefineTailFunc (Serialize.list Serialize.string) exprCodec (S.everySet toComparableGlobal compareGlobal globalCodec) |> Serialize.variant2 Ctor Index.zeroBasedCodec Serialize.int |> Serialize.variant1 Enum Index.zeroBasedCodec |> Serialize.variant0 Box |> Serialize.variant1 Link globalCodec - |> Serialize.variant4 Cycle (Serialize.list Serialize.string) (Serialize.list (Serialize.tuple Serialize.string exprCodec)) (Serialize.list defCodec) (S.everySet compareGlobal globalCodec) + |> Serialize.variant4 Cycle (Serialize.list Serialize.string) (Serialize.list (Serialize.tuple Serialize.string exprCodec)) (Serialize.list defCodec) (S.everySet toComparableGlobal compareGlobal globalCodec) |> Serialize.variant1 Manager effectsTypeCodec - |> Serialize.variant2 Kernel (Serialize.list K.chunkCodec) (S.everySet compareGlobal globalCodec) - |> Serialize.variant2 PortIncoming exprCodec (S.everySet compareGlobal globalCodec) - |> Serialize.variant2 PortOutgoing exprCodec (S.everySet compareGlobal globalCodec) + |> Serialize.variant2 Kernel (Serialize.list K.chunkCodec) (S.everySet toComparableGlobal compareGlobal globalCodec) + |> Serialize.variant2 PortIncoming exprCodec (S.everySet toComparableGlobal compareGlobal globalCodec) + |> Serialize.variant2 PortOutgoing exprCodec (S.everySet toComparableGlobal compareGlobal globalCodec) |> Serialize.finishCustomType @@ -449,11 +455,11 @@ exprCodec = |> Serialize.variant4 Case Serialize.string Serialize.string (deciderCodec choiceCodec) (Serialize.list (Serialize.tuple Serialize.int (Serialize.lazy (\() -> exprCodec)))) |> Serialize.variant1 Accessor Serialize.string |> Serialize.variant2 Access (Serialize.lazy (\() -> exprCodec)) Serialize.string - |> Serialize.variant2 Update (Serialize.lazy (\() -> exprCodec)) (S.assocListDict compare Serialize.string (Serialize.lazy (\() -> exprCodec))) - |> Serialize.variant1 Record (S.assocListDict compare Serialize.string (Serialize.lazy (\() -> exprCodec))) + |> Serialize.variant2 Update (Serialize.lazy (\() -> exprCodec)) (S.assocListDict identity compare Serialize.string (Serialize.lazy (\() -> exprCodec))) + |> Serialize.variant1 Record (S.assocListDict identity compare Serialize.string (Serialize.lazy (\() -> exprCodec))) |> Serialize.variant0 Unit |> Serialize.variant3 Tuple (Serialize.lazy (\() -> exprCodec)) (Serialize.lazy (\() -> exprCodec)) (Serialize.maybe (Serialize.lazy (\() -> exprCodec))) - |> Serialize.variant3 Shader Shader.sourceCodec (S.everySet compare Serialize.string) (S.everySet compare Serialize.string) + |> Serialize.variant3 Shader Shader.sourceCodec (S.everySet identity compare Serialize.string) (S.everySet identity compare Serialize.string) |> Serialize.finishCustomType diff --git a/src/Compiler/AST/Utils/Shader.elm b/src/Compiler/AST/Utils/Shader.elm index 26154953d..5b10dc989 100644 --- a/src/Compiler/AST/Utils/Shader.elm +++ b/src/Compiler/AST/Utils/Shader.elm @@ -27,7 +27,7 @@ type Source type Types - = Types (Dict Name Type) (Dict Name Type) (Dict Name Type) + = Types (Dict String Name Type) (Dict String Name Type) (Dict String Name Type) type Type @@ -109,9 +109,9 @@ typesCodec = ) |> Serialize.variant3 Types - (S.assocListDict compare Serialize.string typeCodec) - (S.assocListDict compare Serialize.string typeCodec) - (S.assocListDict compare Serialize.string typeCodec) + (S.assocListDict identity compare Serialize.string typeCodec) + (S.assocListDict identity compare Serialize.string typeCodec) + (S.assocListDict identity compare Serialize.string typeCodec) |> Serialize.finishCustomType diff --git a/src/Compiler/AST/Utils/Type.elm b/src/Compiler/AST/Utils/Type.elm index b0e629567..ebbf2ab4a 100644 --- a/src/Compiler/AST/Utils/Type.elm +++ b/src/Compiler/AST/Utils/Type.elm @@ -32,13 +32,13 @@ dealias : List ( Name, Type ) -> AliasType -> Type dealias args aliasType = case aliasType of Holey tipe -> - dealiasHelp (Dict.fromList compare args) tipe + dealiasHelp (Dict.fromList identity args) tipe Filled tipe -> tipe -dealiasHelp : Dict Name Type -> Type -> Type +dealiasHelp : Dict String Name Type -> Type -> Type dealiasHelp typeTable tipe = case tipe of TLambda a b -> @@ -47,7 +47,7 @@ dealiasHelp typeTable tipe = (dealiasHelp typeTable b) TVar x -> - Dict.get x typeTable + Dict.get identity x typeTable |> Maybe.withDefault tipe TRecord fields ext -> @@ -69,7 +69,7 @@ dealiasHelp typeTable tipe = (Maybe.map (dealiasHelp typeTable) maybeC) -dealiasField : Dict Name Type -> FieldType -> FieldType +dealiasField : Dict String Name Type -> FieldType -> FieldType dealiasField typeTable (FieldType index tipe) = FieldType index (dealiasHelp typeTable tipe) diff --git a/src/Compiler/Canonicalize/Effects.elm b/src/Compiler/Canonicalize/Effects.elm index 9bf73ac55..12e61d937 100644 --- a/src/Compiler/Canonicalize/Effects.elm +++ b/src/Compiler/Canonicalize/Effects.elm @@ -33,7 +33,7 @@ type alias EResult i w a = canonicalize : Env.Env -> List (A.Located Src.Value) - -> Dict Name.Name union + -> Dict String Name.Name union -> Src.Effects -> EResult i w Can.Effects canonicalize env values unions effects = @@ -47,13 +47,13 @@ canonicalize env values unions effects = pairs = R.traverse (canonicalizePort env) ports in - R.fmap (Can.Ports << Dict.fromList compare) pairs + R.fmap (Can.Ports << Dict.fromList identity) pairs Src.Manager region manager -> let - dict : Dict Name.Name A.Region + dict : Dict String Name.Name A.Region dict = - Dict.fromList compare (List.map toNameRegion values) + Dict.fromList identity (List.map toNameRegion values) in R.ok Can.Manager |> R.apply (verifyManager region dict "init") @@ -176,9 +176,9 @@ canonicalizePort env (Src.Port (A.At region portName) tipe) = -- VERIFY MANAGER -verifyEffectType : A.Located Name.Name -> Dict Name.Name a -> EResult i w Name.Name +verifyEffectType : A.Located Name.Name -> Dict String Name.Name a -> EResult i w Name.Name verifyEffectType (A.At region name) unions = - if Dict.member name unions then + if Dict.member identity name unions then R.ok name else @@ -190,9 +190,9 @@ toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) = ( name, region ) -verifyManager : A.Region -> Dict Name.Name A.Region -> Name.Name -> EResult i w A.Region +verifyManager : A.Region -> Dict String Name.Name A.Region -> Name.Name -> EResult i w A.Region verifyManager tagRegion values name = - case Dict.get name values of + case Dict.get identity name values of Just region -> R.ok region @@ -255,7 +255,8 @@ checkPayload tipe = Err ( tipe, Error.ExtendedRecord ) Can.TRecord fields Nothing -> - Dict.foldl (\_ field acc -> Result.andThen (\_ -> checkFieldPayload field) acc) + Dict.foldl compare + (\_ field acc -> Result.andThen (\_ -> checkFieldPayload field) acc) (Ok ()) fields diff --git a/src/Compiler/Canonicalize/Environment.elm b/src/Compiler/Canonicalize/Environment.elm index a7c3e784b..fab735f80 100644 --- a/src/Compiler/Canonicalize/Environment.elm +++ b/src/Compiler/Canonicalize/Environment.elm @@ -45,7 +45,7 @@ type alias EResult i w a = type alias Env = { home : Canonical - , vars : Dict Name.Name Var + , vars : Dict String Name.Name Var , types : Exposed Type , ctors : Exposed Ctor , binops : Exposed Binop @@ -56,11 +56,11 @@ type alias Env = type alias Exposed a = - Dict Name.Name (Info a) + Dict String Name.Name (Info a) type alias Qualified a = - Dict Name.Name (Dict Name.Name (Info a)) + Dict String Name.Name (Dict String Name.Name (Info a)) @@ -137,15 +137,16 @@ type Binop -- VARIABLE -- ADD LOCALS -addLocals : Dict Name.Name A.Region -> Env -> EResult i w Env +addLocals : Dict String Name.Name A.Region -> Env -> EResult i w Env addLocals names env = R.fmap (\newVars -> { env | vars = newVars }) - (Dict.merge (\name region -> R.fmap (Dict.insert compare name (addLocalLeft name region))) + (Dict.merge compare + (\name region -> R.fmap (Dict.insert identity name (addLocalLeft name region))) (\name region var acc -> addLocalBoth name region var - |> R.bind (\var_ -> R.fmap (Dict.insert compare name var_) acc) + |> R.bind (\var_ -> R.fmap (Dict.insert identity name var_) acc) ) - (\name var -> R.fmap (Dict.insert compare name var)) + (\name var -> R.fmap (Dict.insert identity name var)) names env.vars (R.ok Dict.empty) @@ -179,7 +180,7 @@ addLocalBoth name region var = findType : A.Region -> Env -> Name.Name -> EResult i w Type findType region { types, q_types } name = - case Dict.get name types of + case Dict.get identity name types of Just (Specific _ tipe) -> R.ok tipe @@ -192,9 +193,9 @@ findType region { types, q_types } name = findTypeQual : A.Region -> Env -> Name.Name -> Name.Name -> EResult i w Type findTypeQual region { types, q_types } prefix name = - case Dict.get prefix q_types of + case Dict.get identity prefix q_types of Just qualified -> - case Dict.get name qualified of + case Dict.get identity name qualified of Just (Specific _ tipe) -> R.ok tipe @@ -214,7 +215,7 @@ findTypeQual region { types, q_types } prefix name = findCtor : A.Region -> Env -> Name.Name -> EResult i w Ctor findCtor region { ctors, q_ctors } name = - case Dict.get name ctors of + case Dict.get identity name ctors of Just (Specific _ ctor) -> R.ok ctor @@ -227,9 +228,9 @@ findCtor region { ctors, q_ctors } name = findCtorQual : A.Region -> Env -> Name.Name -> Name.Name -> EResult i w Ctor findCtorQual region { ctors, q_ctors } prefix name = - case Dict.get prefix q_ctors of + case Dict.get identity prefix q_ctors of Just qualified -> - case Dict.get name qualified of + case Dict.get identity name qualified of Just (Specific _ pattern) -> R.ok pattern @@ -249,7 +250,7 @@ findCtorQual region { ctors, q_ctors } prefix name = findBinop : A.Region -> Env -> Name.Name -> EResult i w Binop findBinop region { binops } name = - case Dict.get name binops of + case Dict.get identity name binops of Just (Specific _ binop) -> R.ok binop @@ -257,7 +258,7 @@ findBinop region { binops } name = R.throw (Error.AmbiguousBinop region name h hs) Nothing -> - R.throw (Error.NotFoundBinop region name (EverySet.fromList compare (Dict.keys binops))) + R.throw (Error.NotFoundBinop region name (EverySet.fromList identity (Dict.keys compare binops))) @@ -266,4 +267,4 @@ findBinop region { binops } name = toPossibleNames : Exposed a -> Qualified a -> Error.PossibleNames toPossibleNames exposed qualified = - Error.PossibleNames (EverySet.fromList compare (Dict.keys exposed)) (Dict.map (\_ -> Dict.keys >> EverySet.fromList compare) qualified) + Error.PossibleNames (EverySet.fromList identity (Dict.keys compare exposed)) (Dict.map (\_ -> Dict.keys compare >> EverySet.fromList identity) qualified) diff --git a/src/Compiler/Canonicalize/Environment/Dups.elm b/src/Compiler/Canonicalize/Environment/Dups.elm index 71dfb2693..00e735b42 100644 --- a/src/Compiler/Canonicalize/Environment/Dups.elm +++ b/src/Compiler/Canonicalize/Environment/Dups.elm @@ -26,7 +26,7 @@ import Utils.Main as Utils type alias Tracker value = - Dict Name (OneOrMore (Info value)) + Dict String Name (OneOrMore (Info value)) type alias Info value = @@ -43,13 +43,13 @@ type alias ToError = Name -> A.Region -> A.Region -> Error -detect : ToError -> Tracker a -> R.RResult i w Error (Dict Name a) +detect : ToError -> Tracker a -> R.RResult i w Error (Dict String Name a) detect toError dict = - Dict.foldl + Dict.foldl compare (\name values -> R.bind (\acc -> - R.fmap (\b -> Dict.insert compare name b acc) + R.fmap (\b -> Dict.insert identity name b acc) (detectHelp toError name values) ) ) @@ -75,24 +75,24 @@ detectHelp toError name values = -- CHECK FIELDS -checkFields : List ( A.Located Name, a ) -> R.RResult i w Error (Dict Name a) +checkFields : List ( A.Located Name, a ) -> R.RResult i w Error (Dict String Name a) checkFields fields = detect Error.DuplicateField (List.foldr addField none fields) addField : ( A.Located Name, a ) -> Tracker a -> Tracker a addField ( A.At region name, value ) dups = - Utils.mapInsertWith compare OneOrMore.more name (OneOrMore.one (Info region value)) dups + Utils.mapInsertWith identity OneOrMore.more name (OneOrMore.one (Info region value)) dups -checkFields_ : (A.Region -> a -> b) -> List ( A.Located Name, a ) -> R.RResult i w Error (Dict Name b) +checkFields_ : (A.Region -> a -> b) -> List ( A.Located Name, a ) -> R.RResult i w Error (Dict String Name b) checkFields_ toValue fields = detect Error.DuplicateField (List.foldr (addField_ toValue) none fields) addField_ : (A.Region -> a -> b) -> ( A.Located Name, a ) -> Tracker b -> Tracker b addField_ toValue ( A.At region name, value ) dups = - Utils.mapInsertWith compare OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups + Utils.mapInsertWith identity OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups @@ -106,17 +106,17 @@ none = one : Name -> A.Region -> value -> Tracker value one name region value = - Dict.singleton name (OneOrMore.one (Info region value)) + Dict.singleton identity name (OneOrMore.one (Info region value)) insert : Name -> A.Region -> a -> Tracker a -> Tracker a insert name region value dict = - Utils.mapInsertWith compare (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict + Utils.mapInsertWith identity (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict union : Tracker a -> Tracker a -> Tracker a union a b = - Utils.mapUnionWith compare OneOrMore.more a b + Utils.mapUnionWith identity compare OneOrMore.more a b unions : List (Tracker a) -> Tracker a diff --git a/src/Compiler/Canonicalize/Environment/Foreign.elm b/src/Compiler/Canonicalize/Environment/Foreign.elm index 469bc03c5..3d057da9f 100644 --- a/src/Compiler/Canonicalize/Environment/Foreign.elm +++ b/src/Compiler/Canonicalize/Environment/Foreign.elm @@ -20,7 +20,7 @@ type alias FResult i w a = R.RResult i w Error.Error a -createInitialEnv : IO.Canonical -> Dict ModuleName.Raw I.Interface -> List Src.Import -> FResult i w Env.Env +createInitialEnv : IO.Canonical -> Dict String ModuleName.Raw I.Interface -> List Src.Import -> FResult i w Env.Env createInitialEnv home ifaces imports = Utils.foldM (addImport ifaces) emptyState (toSafeImports home imports) |> R.fmap @@ -68,7 +68,7 @@ emptyState = emptyTypes : Env.Exposed Env.Type emptyTypes = - Dict.fromList compare [ ( "List", Env.Specific ModuleName.list (Env.Union 1 ModuleName.list) ) ] + Dict.fromList identity [ ( "List", Env.Specific ModuleName.list (Env.Union 1 ModuleName.list) ) ] @@ -102,11 +102,11 @@ isNormal (Src.Import (A.At _ name) maybeAlias _) = -- ADD IMPORTS -addImport : Dict ModuleName.Raw I.Interface -> State -> Src.Import -> FResult i w State +addImport : Dict String ModuleName.Raw I.Interface -> State -> Src.Import -> FResult i w State addImport ifaces state (Src.Import (A.At _ name) maybeAlias exposing_) = let (I.Interface pkg defs unions aliases binops) = - Utils.find name ifaces + Utils.find identity name ifaces prefix : Name prefix = @@ -116,29 +116,29 @@ addImport ifaces state (Src.Import (A.At _ name) maybeAlias exposing_) = home = IO.Canonical pkg name - rawTypeInfo : Dict Name ( Env.Type, Env.Exposed Env.Ctor ) + rawTypeInfo : Dict String Name ( Env.Type, Env.Exposed Env.Ctor ) rawTypeInfo = - Dict.union compare - (Dict.toList unions + Dict.union + (Dict.toList compare unions |> List.filterMap (\( k, a ) -> Maybe.map (Tuple.pair k) (unionToType home k a)) - |> Dict.fromList compare + |> Dict.fromList identity ) - (Dict.toList aliases + (Dict.toList compare aliases |> List.filterMap (\( k, a ) -> Maybe.map (Tuple.pair k) (aliasToType home k a)) - |> Dict.fromList compare + |> Dict.fromList identity ) - vars : Dict Name (Env.Info Can.Annotation) + vars : Dict String Name (Env.Info Can.Annotation) vars = Dict.map (\_ -> Env.Specific home) defs - types : Dict Name (Env.Info Env.Type) + types : Dict String Name (Env.Info Env.Type) types = Dict.map (\_ -> Env.Specific home << Tuple.first) rawTypeInfo ctors : Env.Exposed Env.Ctor ctors = - Dict.foldr (\_ -> addExposed << Tuple.second) Dict.empty rawTypeInfo + Dict.foldr compare (\_ -> addExposed << Tuple.second) Dict.empty rawTypeInfo qvs2 : Env.Qualified Can.Annotation qvs2 = @@ -182,12 +182,12 @@ addImport ifaces state (Src.Import (A.At _ name) maybeAlias exposing_) = addExposed : Env.Exposed a -> Env.Exposed a -> Env.Exposed a addExposed = - Utils.mapUnionWith compare Env.mergeInfo + Utils.mapUnionWith identity compare Env.mergeInfo addQualified : Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a addQualified prefix exposed qualified = - Utils.mapInsertWith compare addExposed prefix exposed qualified + Utils.mapInsertWith identity addExposed prefix exposed qualified @@ -202,9 +202,9 @@ unionToType home name union = unionToTypeHelp : IO.Canonical -> Name -> Can.Union -> ( Env.Type, Env.Exposed Env.Ctor ) unionToTypeHelp home name ((Can.Union vars ctors _ _) as union) = let - addCtor : Can.Ctor -> Dict Name (Env.Info Env.Ctor) -> Dict Name (Env.Info Env.Ctor) + addCtor : Can.Ctor -> Dict String Name (Env.Info Env.Ctor) -> Dict String Name (Env.Info Env.Ctor) addCtor (Can.Ctor ctor index _ args) dict = - Dict.insert compare ctor (Env.Specific home (Env.Ctor home name union index args)) dict + Dict.insert identity ctor (Env.Specific home (Env.Ctor home name union index args)) dict in ( Env.Union (List.length vars) home , List.foldl addCtor Dict.empty ctors @@ -237,7 +237,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) = (Can.TAlias home name avars (Can.Filled tipe)) (Can.fieldsToList fields) in - Dict.singleton name (Env.Specific home (Env.RecordCtor home vars alias_)) + Dict.singleton identity name (Env.Specific home (Env.RecordCtor home vars alias_)) _ -> Dict.empty @@ -260,40 +260,40 @@ binopToBinop home op (I.Binop name annotation associativity precedence) = addExposedValue : IO.Canonical -> Env.Exposed Can.Annotation - -> Dict Name ( Env.Type, Env.Exposed Env.Ctor ) - -> Dict Name I.Binop + -> Dict String Name ( Env.Type, Env.Exposed Env.Ctor ) + -> Dict String Name I.Binop -> State -> Src.Exposed -> FResult i w State addExposedValue home vars types binops state exposed = case exposed of Src.Lower (A.At region name) -> - case Dict.get name vars of + case Dict.get identity name vars of Just info -> - R.ok { state | vars = Utils.mapInsertWith compare Env.mergeInfo name info state.vars } + R.ok { state | vars = Utils.mapInsertWith identity Env.mergeInfo name info state.vars } Nothing -> - R.throw (Error.ImportExposingNotFound region home name (Dict.keys vars)) + R.throw (Error.ImportExposingNotFound region home name (Dict.keys compare vars)) Src.Upper (A.At region name) privacy -> case privacy of Src.Private -> - case Dict.get name types of + case Dict.get identity name types of Just ( tipe, ctors ) -> case tipe of Env.Union _ _ -> let - ts2 : Dict Name (Env.Info Env.Type) + ts2 : Dict String Name (Env.Info Env.Type) ts2 = - Dict.insert compare name (Env.Specific home tipe) state.types + Dict.insert identity name (Env.Specific home tipe) state.types in R.ok { state | types = ts2 } Env.Alias _ _ _ _ -> let - ts2 : Dict Name (Env.Info Env.Type) + ts2 : Dict String Name (Env.Info Env.Type) ts2 = - Dict.insert compare name (Env.Specific home tipe) state.types + Dict.insert identity name (Env.Specific home tipe) state.types cs2 : Env.Exposed Env.Ctor cs2 = @@ -307,17 +307,17 @@ addExposedValue home vars types binops state exposed = R.throw <| Error.ImportCtorByName region name tipe [] -> - R.throw <| Error.ImportExposingNotFound region home name (Dict.keys types) + R.throw <| Error.ImportExposingNotFound region home name (Dict.keys compare types) Src.Public dotDotRegion -> - case Dict.get name types of + case Dict.get identity name types of Just ( tipe, ctors ) -> case tipe of Env.Union _ _ -> let - ts2 : Dict Name (Env.Info Env.Type) + ts2 : Dict String Name (Env.Info Env.Type) ts2 = - Dict.insert compare name (Env.Specific home tipe) state.types + Dict.insert identity name (Env.Specific home tipe) state.types cs2 : Env.Exposed Env.Ctor cs2 = @@ -329,28 +329,28 @@ addExposedValue home vars types binops state exposed = R.throw (Error.ImportOpenAlias dotDotRegion name) Nothing -> - R.throw (Error.ImportExposingNotFound region home name (Dict.keys types)) + R.throw (Error.ImportExposingNotFound region home name (Dict.keys compare types)) Src.Operator region op -> - case Dict.get op binops of + case Dict.get identity op binops of Just binop -> let - bs2 : Dict Name (Env.Info Env.Binop) + bs2 : Dict String Name (Env.Info Env.Binop) bs2 = - Dict.insert compare op (binopToBinop home op binop) state.binops + Dict.insert identity op (binopToBinop home op binop) state.binops in R.ok { state | binops = bs2 } Nothing -> - R.throw (Error.ImportExposingNotFound region home op (Dict.keys binops)) + R.throw (Error.ImportExposingNotFound region home op (Dict.keys compare binops)) -checkForCtorMistake : Name -> Dict Name ( Env.Type, Env.Exposed Env.Ctor ) -> List Name +checkForCtorMistake : Name -> Dict String Name ( Env.Type, Env.Exposed Env.Ctor ) -> List Name checkForCtorMistake givenName types = let - addMatches : a -> ( b, Dict Name (Env.Info Env.Ctor) ) -> List Name -> List Name + addMatches : a -> ( b, Dict String Name (Env.Info Env.Ctor) ) -> List Name -> List Name addMatches _ ( _, exposedCtors ) matches = - Dict.foldr addMatch matches exposedCtors + Dict.foldr compare addMatch matches exposedCtors addMatch : Name -> Env.Info Env.Ctor -> List Name -> List Name addMatch ctorName info matches = @@ -368,4 +368,4 @@ checkForCtorMistake givenName types = Env.Ambiguous _ _ -> matches in - Dict.foldr addMatches [] types + Dict.foldr compare addMatches [] types diff --git a/src/Compiler/Canonicalize/Environment/Local.elm b/src/Compiler/Canonicalize/Environment/Local.elm index 18bc3907e..36aee6744 100644 --- a/src/Compiler/Canonicalize/Environment/Local.elm +++ b/src/Compiler/Canonicalize/Environment/Local.elm @@ -25,11 +25,11 @@ type alias LResult i w a = type alias Unions = - Dict Name Can.Union + Dict String Name Can.Union type alias Aliases = - Dict Name Can.Alias + Dict String Name Can.Alias add : Src.Module -> Env.Env -> LResult i w ( Env.Env, Unions, Aliases ) @@ -49,16 +49,16 @@ addVars module_ env = |> R.fmap (\topLevelVars -> let - vs2 : Dict Name Env.Var + vs2 : Dict String Name Env.Var vs2 = - Dict.union compare topLevelVars env.vars + Dict.union topLevelVars env.vars in -- Use union to overwrite foreign stuff. { env | vars = vs2 } ) -collectVars : Src.Module -> LResult i w (Dict Name.Name Env.Var) +collectVars : Src.Module -> LResult i w (Dict String Name.Name Env.Var) collectVars (Src.Module _ _ _ _ values _ _ _ effects) = let addDecl : A.Located Src.Value -> Dups.Tracker Env.Var -> Dups.Tracker Env.Var @@ -133,7 +133,7 @@ addUnion home types ((A.At _ (Src.Union (A.At _ name) _ _)) as union) = one = Env.Specific home (Env.Union arity home) in - Dict.insert compare name one types + Dict.insert identity name one types ) (checkUnionFreeVars union) @@ -171,9 +171,9 @@ addAlias ({ home, vars, types, ctors, binops, q_vars, q_types, q_ctors } as env) one = Env.Specific home (Env.Alias (List.length args) home args ctype) - ts1 : Dict Name (Env.Info Env.Type) + ts1 : Dict String Name (Env.Info Env.Type) ts1 = - Dict.insert compare name one types + Dict.insert identity name one types in R.ok (Env.Env home vars ts1 ctors binops q_vars q_types q_ctors) ) @@ -240,7 +240,7 @@ checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) = addArg (A.At region arg) dict = Dups.insert arg region region dict - addCtorFreeVars : ( a, List Src.Type ) -> Dict Name A.Region -> Dict Name A.Region + addCtorFreeVars : ( a, List Src.Type ) -> Dict String Name A.Region -> Dict String Name A.Region addCtorFreeVars ( _, tipes ) freeVars = List.foldl addFreeVars freeVars tipes in @@ -248,11 +248,11 @@ checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) = |> R.bind (\boundVars -> let - freeVars : Dict Name A.Region + freeVars : Dict String Name A.Region freeVars = List.foldr addCtorFreeVars Dict.empty ctors in - case Dict.toList (Dict.diff freeVars boundVars) of + case Dict.toList compare (Dict.diff freeVars boundVars) of [] -> R.ok (List.length args) @@ -273,13 +273,13 @@ checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) = |> R.bind (\boundVars -> let - freeVars : Dict Name A.Region + freeVars : Dict String Name A.Region freeVars = addFreeVars tipe Dict.empty overlap : Int overlap = - Dict.size (Dict.intersection boundVars freeVars) + Dict.size (Dict.intersection compare boundVars freeVars) in if Dict.size boundVars == overlap && Dict.size freeVars == overlap then R.ok (List.map A.toValue args) @@ -289,19 +289,19 @@ checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) = Error.TypeVarsMessedUpInAlias aliasRegion name (List.map A.toValue args) - (Dict.toList (Dict.diff boundVars freeVars)) - (Dict.toList (Dict.diff freeVars boundVars)) + (Dict.toList compare (Dict.diff boundVars freeVars)) + (Dict.toList compare (Dict.diff freeVars boundVars)) ) -addFreeVars : Src.Type -> Dict Name.Name A.Region -> Dict Name.Name A.Region +addFreeVars : Src.Type -> Dict String Name.Name A.Region -> Dict String Name.Name A.Region addFreeVars (A.At region tipe) freeVars = case tipe of Src.TLambda arg result -> addFreeVars result (addFreeVars arg freeVars) Src.TVar name -> - Dict.insert compare name region freeVars + Dict.insert identity name region freeVars Src.TType _ _ args -> List.foldl addFreeVars freeVars args @@ -311,14 +311,14 @@ addFreeVars (A.At region tipe) freeVars = Src.TRecord fields maybeExt -> let - extFreeVars : Dict Name A.Region + extFreeVars : Dict String Name A.Region extFreeVars = case maybeExt of Nothing -> freeVars Just (A.At extRegion ext) -> - Dict.insert compare ext extRegion freeVars + Dict.insert identity ext extRegion freeVars in List.foldl (\( _, t ) fvs -> addFreeVars t fvs) extFreeVars fields @@ -349,14 +349,14 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env = |> R.bind (\ctors -> let - cs2 : Dict Name (Env.Info Env.Ctor) + cs2 : Dict String Name (Env.Info Env.Ctor) cs2 = - Dict.union compare ctors env.ctors + Dict.union ctors env.ctors in R.ok ( { env | ctors = cs2 } - , Dict.fromList compare (List.map Tuple.first unionInfo) - , Dict.fromList compare (List.map Tuple.first aliasInfo) + , Dict.fromList identity (List.map Tuple.first unionInfo) + , Dict.fromList identity (List.map Tuple.first aliasInfo) ) ) ) @@ -393,7 +393,7 @@ canonicalizeAlias ({ home } as env) (A.At _ (Src.Alias (A.At region name) args t ) -toRecordCtor : IO.Canonical -> Name.Name -> List Name.Name -> Dict Name.Name Can.FieldType -> Env.Ctor +toRecordCtor : IO.Canonical -> Name.Name -> List Name.Name -> Dict String Name.Name Can.FieldType -> Env.Ctor toRecordCtor home name vars fields = let avars : List ( Name, Can.Type ) diff --git a/src/Compiler/Canonicalize/Expression.elm b/src/Compiler/Canonicalize/Expression.elm index f99d5e0f8..612d2eeb4 100644 --- a/src/Compiler/Canonicalize/Expression.elm +++ b/src/Compiler/Canonicalize/Expression.elm @@ -40,7 +40,7 @@ type alias EResult i w a = type alias FreeLocals = - Dict Name.Name Uses + Dict String Name.Name Uses type Uses @@ -148,19 +148,19 @@ canonicalize env (A.At region expression) = Src.Update (A.At reg name) fields -> let - makeCanFields : R.RResult i w Error.Error (Dict Name (R.RResult FreeLocals (List W.Warning) Error.Error Can.FieldUpdate)) + makeCanFields : R.RResult i w Error.Error (Dict String Name (R.RResult FreeLocals (List W.Warning) Error.Error Can.FieldUpdate)) makeCanFields = Dups.checkFields_ (\r t -> R.fmap (Can.FieldUpdate r) (canonicalize env t)) fields in R.pure (Can.Update name) |> R.apply (R.fmap (A.At reg) (findVar reg env name)) - |> R.apply (R.bind (Utils.sequenceADict compare) makeCanFields) + |> R.apply (R.bind (Utils.sequenceADict identity compare) makeCanFields) Src.Record fields -> Dups.checkFields fields |> R.bind (\fieldDict -> - R.fmap Can.Record (R.traverseDict compare (canonicalize env) fieldDict) + R.fmap Can.Record (R.traverseDict identity compare (canonicalize env) fieldDict) ) Src.Unit -> @@ -423,7 +423,7 @@ addDefNodes env nodes (A.At _ def) = node : ( Binding, Name, List Name ) node = - ( Define cdef, name, Dict.keys freeLocals ) + ( Define cdef, name, Dict.keys compare freeLocals ) in logLetLocals args freeLocals (node :: nodes) ) @@ -451,7 +451,7 @@ addDefNodes env nodes (A.At _ def) = node : ( Binding, Name, List Name ) node = - ( Define cdef, name, Dict.keys freeLocals ) + ( Define cdef, name, Dict.keys compare freeLocals ) in logLetLocals args freeLocals (node :: nodes) ) @@ -481,17 +481,17 @@ addDefNodes env nodes (A.At _ def) = node : ( Binding, Name, List Name ) node = - ( Destruct cpattern cbody, name, Dict.keys freeLocals ) + ( Destruct cpattern cbody, name, Dict.keys compare freeLocals ) in Ok (R.ROk - (Utils.mapUnionWith compare combineUses fs freeLocals) + (Utils.mapUnionWith identity compare combineUses fs freeLocals) warnings (List.foldl (addEdge [ name ]) (node :: nodes) names) ) Err (R.RErr freeLocals warnings errors) -> - Err (R.RErr (Utils.mapUnionWith compare combineUses freeLocals fs) warnings errors) + Err (R.RErr (Utils.mapUnionWith identity compare combineUses freeLocals fs) warnings errors) ) ) @@ -502,7 +502,8 @@ logLetLocals args letLocals value = (\freeLocals warnings -> Ok (R.ROk - (Utils.mapUnionWith compare + (Utils.mapUnionWith identity + compare combineUses freeLocals (case args of @@ -691,7 +692,7 @@ logVar : Name.Name -> a -> EResult FreeLocals w a logVar name value = R.RResult <| \freeLocals warnings -> - Ok (R.ROk (Utils.mapInsertWith compare combineUses name oneDirectUse freeLocals) warnings value) + Ok (R.ROk (Utils.mapInsertWith identity combineUses name oneDirectUse freeLocals) warnings value) oneDirectUse : Uses @@ -733,7 +734,7 @@ verifyBindings context bindings (R.RResult k) = case k Dict.empty warnings of Ok (R.ROk freeLocals warnings1 value) -> let - outerFreeLocals : Dict Name Uses + outerFreeLocals : Dict String Name Uses outerFreeLocals = Dict.diff freeLocals bindings @@ -745,7 +746,7 @@ verifyBindings context bindings (R.RResult k) = warnings1 else - Dict.foldl (addUnusedWarning context) warnings1 <| + Dict.foldl compare (addUnusedWarning context) warnings1 <| Dict.diff bindings freeLocals in Ok (R.ROk info warnings2 ( value, outerFreeLocals )) @@ -766,7 +767,7 @@ directUsage (R.RResult k) = (\freeLocals warnings -> case k () warnings of Ok (R.ROk () ws ( value, newFreeLocals )) -> - Ok (R.ROk (Utils.mapUnionWith compare combineUses freeLocals newFreeLocals) ws value) + Ok (R.ROk (Utils.mapUnionWith identity compare combineUses freeLocals newFreeLocals) ws value) Err (R.RErr () ws es) -> Err (R.RErr freeLocals ws es) @@ -780,11 +781,11 @@ delayedUsage (R.RResult k) = case k () warnings of Ok (R.ROk () ws ( value, newFreeLocals )) -> let - delayedLocals : Dict Name Uses + delayedLocals : Dict String Name Uses delayedLocals = Dict.map (\_ -> delayUse) newFreeLocals in - Ok (R.ROk (Utils.mapUnionWith compare combineUses freeLocals delayedLocals) ws value) + Ok (R.ROk (Utils.mapUnionWith identity compare combineUses freeLocals delayedLocals) ws value) Err (R.RErr () ws es) -> Err (R.RErr freeLocals ws es) @@ -797,7 +798,7 @@ delayedUsage (R.RResult k) = findVar : A.Region -> Env.Env -> Name -> EResult FreeLocals w Can.Expr_ findVar region env name = - case Dict.get name env.vars of + case Dict.get identity name env.vars of Just var -> case var of Env.Local _ -> @@ -824,9 +825,9 @@ findVar region env name = findVarQual : A.Region -> Env.Env -> Name -> Name -> EResult FreeLocals w Can.Expr_ findVarQual region env prefix name = - case Dict.get prefix env.q_vars of + case Dict.get identity prefix env.q_vars of Just qualified -> - case Dict.get name qualified of + case Dict.get identity name qualified of Just (Env.Specific home annotation) -> R.ok <| if home == ModuleName.debug then @@ -853,9 +854,9 @@ findVarQual region env prefix name = R.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames env.vars env.q_vars)) -toPossibleNames : Dict Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames +toPossibleNames : Dict String Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames toPossibleNames exposed qualified = - Error.PossibleNames (Utils.keysSet compare exposed) (Dict.map (\_ -> Utils.keysSet compare) qualified) + Error.PossibleNames (Utils.keysSet identity compare exposed) (Dict.map (\_ -> Utils.keysSet identity compare) qualified) @@ -867,9 +868,9 @@ toVarCtor name ctor = case ctor of Env.Ctor home typeName (Can.Union vars _ _ opts) index args -> let - freeVars : Dict Name () + freeVars : Dict String Name () freeVars = - Dict.fromList compare (List.map (\v -> ( v, () )) vars) + Dict.fromList identity (List.map (\v -> ( v, () )) vars) result : Can.Type result = @@ -883,8 +884,8 @@ toVarCtor name ctor = Env.RecordCtor home vars tipe -> let - freeVars : Dict Name () + freeVars : Dict String Name () freeVars = - Dict.fromList compare (List.map (\v -> ( v, () )) vars) + Dict.fromList identity (List.map (\v -> ( v, () )) vars) in Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe) diff --git a/src/Compiler/Canonicalize/Module.elm b/src/Compiler/Canonicalize/Module.elm index 30c8b5234..80daac45c 100644 --- a/src/Compiler/Canonicalize/Module.elm +++ b/src/Compiler/Canonicalize/Module.elm @@ -37,16 +37,16 @@ type alias MResult i w a = -- MODULES -canonicalize : Pkg.Name -> Dict ModuleName.Raw I.Interface -> Src.Module -> MResult i (List W.Warning) Can.Module +canonicalize : Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> MResult i (List W.Warning) Can.Module canonicalize pkg ifaces ((Src.Module _ exports docs imports values _ _ binops effects) as modul) = let home : IO.Canonical home = IO.Canonical pkg (Src.getName modul) - cbinops : Dict Name Can.Binop + cbinops : Dict String Name Can.Binop cbinops = - Dict.fromList compare (List.map canonicalizeBinop binops) + Dict.fromList identity (List.map canonicalizeBinop binops) in Foreign.createInitialEnv home ifaces imports |> R.bind (Local.add modul) @@ -190,7 +190,7 @@ toNodeOne env (A.At _ (Src.Value ((A.At _ name) as aname) srcArgs body maybeType in ( toNodeTwo name srcArgs def freeLocals , name - , Dict.keys freeLocals + , Dict.keys compare freeLocals ) ) ) @@ -217,7 +217,7 @@ toNodeOne env (A.At _ (Src.Value ((A.At _ name) as aname) srcArgs body maybeType in ( toNodeTwo name srcArgs def freeLocals , name - , Dict.keys freeLocals + , Dict.keys compare freeLocals ) ) ) @@ -229,7 +229,7 @@ toNodeTwo : Name -> List arg -> Can.Def -> Expr.FreeLocals -> NodeTwo toNodeTwo name args def freeLocals = case args of [] -> - ( def, name, Dict.foldr addDirects [] freeLocals ) + ( def, name, Dict.foldr compare addDirects [] freeLocals ) _ -> ( def, name, [] ) @@ -250,9 +250,9 @@ addDirects name (Expr.Uses { direct }) directDeps = canonicalizeExports : List (A.Located Src.Value) - -> Dict Name union - -> Dict Name alias - -> Dict Name binop + -> Dict String Name union + -> Dict String Name alias + -> Dict String Name binop -> Can.Effects -> A.Located Src.Exposing -> MResult i w Can.Exports @@ -263,9 +263,9 @@ canonicalizeExports values unions aliases binops effects (A.At region exposing_) Src.Explicit exposeds -> let - names : Dict Name () + names : Dict String Name () names = - Dict.fromList compare (List.map valueToName values) + Dict.fromList identity (List.map valueToName values) in R.traverse (checkExposed names unions aliases binops effects) exposeds |> R.bind @@ -281,17 +281,17 @@ valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) = checkExposed : - Dict Name value - -> Dict Name union - -> Dict Name alias - -> Dict Name binop + Dict String Name value + -> Dict String Name union + -> Dict String Name alias + -> Dict String Name binop -> Can.Effects -> Src.Exposed -> MResult i w (Dups.Tracker (A.Located Can.Export)) checkExposed values unions aliases binops effects exposed = case exposed of Src.Lower (A.At region name) -> - if Dict.member name values then + if Dict.member identity name values then ok name region Can.ExportValue else @@ -300,34 +300,34 @@ checkExposed values unions aliases binops effects exposed = ok name region Can.ExportPort Just ports -> - R.throw (Error.ExportNotFound region Error.BadVar name (ports ++ Dict.keys values)) + R.throw (Error.ExportNotFound region Error.BadVar name (ports ++ Dict.keys compare values)) Src.Operator region name -> - if Dict.member name binops then + if Dict.member identity name binops then ok name region Can.ExportBinop else - R.throw (Error.ExportNotFound region Error.BadOp name (Dict.keys binops)) + R.throw (Error.ExportNotFound region Error.BadOp name (Dict.keys compare binops)) Src.Upper (A.At region name) (Src.Public dotDotRegion) -> - if Dict.member name unions then + if Dict.member identity name unions then ok name region Can.ExportUnionOpen - else if Dict.member name aliases then + else if Dict.member identity name aliases then R.throw (Error.ExportOpenAlias dotDotRegion name) else - R.throw (Error.ExportNotFound region Error.BadType name (Dict.keys unions ++ Dict.keys aliases)) + R.throw (Error.ExportNotFound region Error.BadType name (Dict.keys compare unions ++ Dict.keys compare aliases)) Src.Upper (A.At region name) Src.Private -> - if Dict.member name unions then + if Dict.member identity name unions then ok name region Can.ExportUnionClosed - else if Dict.member name aliases then + else if Dict.member identity name aliases then ok name region Can.ExportAlias else - R.throw (Error.ExportNotFound region Error.BadType name (Dict.keys unions ++ Dict.keys aliases)) + R.throw (Error.ExportNotFound region Error.BadType name (Dict.keys compare unions ++ Dict.keys compare aliases)) checkPorts : Can.Effects -> Name -> Maybe (List Name) @@ -337,11 +337,11 @@ checkPorts effects name = Just [] Can.Ports ports -> - if Dict.member name ports then + if Dict.member identity name ports then Nothing else - Just (Dict.keys ports) + Just (Dict.keys compare ports) Can.Manager _ _ _ _ -> Just [] diff --git a/src/Compiler/Canonicalize/Pattern.elm b/src/Compiler/Canonicalize/Pattern.elm index bc2e7fd17..f00b5c22f 100644 --- a/src/Compiler/Canonicalize/Pattern.elm +++ b/src/Compiler/Canonicalize/Pattern.elm @@ -29,7 +29,7 @@ type alias PResult i w a = type alias Bindings = - Dict Name.Name A.Region + Dict String Name.Name A.Region diff --git a/src/Compiler/Canonicalize/Type.elm b/src/Compiler/Canonicalize/Type.elm index f56622e87..d84e6cb2a 100644 --- a/src/Compiler/Canonicalize/Type.elm +++ b/src/Compiler/Canonicalize/Type.elm @@ -62,7 +62,7 @@ canonicalize env (A.At typeRegion tipe) = Src.TRecord fields ext -> Dups.checkFields (canonicalizeFields env fields) - |> R.bind (Utils.sequenceADict compare) + |> R.bind (Utils.sequenceADict identity compare) |> R.fmap (\cfields -> Can.TRecord cfields (Maybe.map A.toValue ext)) Src.TUnit -> @@ -135,23 +135,23 @@ checkArity expected region name args answer = -- ADD FREE VARS -addFreeVars : Dict Name.Name () -> Can.Type -> Dict Name.Name () +addFreeVars : Dict String Name.Name () -> Can.Type -> Dict String Name.Name () addFreeVars freeVars tipe = case tipe of Can.TLambda arg result -> addFreeVars (addFreeVars freeVars result) arg Can.TVar var -> - Dict.insert compare var () freeVars + Dict.insert identity var () freeVars Can.TType _ _ args -> List.foldl (\b c -> addFreeVars c b) freeVars args Can.TRecord fields Nothing -> - Dict.foldl (\_ b c -> addFieldFreeVars c b) freeVars fields + Dict.foldl compare (\_ b c -> addFieldFreeVars c b) freeVars fields Can.TRecord fields (Just ext) -> - Dict.foldl (\_ b c -> addFieldFreeVars c b) (Dict.insert compare ext () freeVars) fields + Dict.foldl compare (\_ b c -> addFieldFreeVars c b) (Dict.insert identity ext () freeVars) fields Can.TUnit -> freeVars @@ -168,6 +168,6 @@ addFreeVars freeVars tipe = List.foldl (\( _, arg ) fvs -> addFreeVars fvs arg) freeVars args -addFieldFreeVars : Dict Name.Name () -> Can.FieldType -> Dict Name.Name () +addFieldFreeVars : Dict String Name.Name () -> Can.FieldType -> Dict String Name.Name () addFieldFreeVars freeVars (Can.FieldType _ tipe) = addFreeVars freeVars tipe diff --git a/src/Compiler/Compile.elm b/src/Compiler/Compile.elm index 5c5e3f929..6181c238c 100644 --- a/src/Compiler/Compile.elm +++ b/src/Compiler/Compile.elm @@ -28,10 +28,10 @@ import System.TypeCheck.IO as TypeCheck type Artifacts - = Artifacts Can.Module (Dict Name Can.Annotation) Opt.LocalGraph + = Artifacts Can.Module (Dict String Name Can.Annotation) Opt.LocalGraph -compile : Pkg.Name -> Dict ModuleName.Raw I.Interface -> Src.Module -> IO (Result E.Error Artifacts) +compile : Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> IO (Result E.Error Artifacts) compile pkg ifaces modul = IO.pure (canonicalize pkg ifaces modul) |> IO.fmap @@ -56,7 +56,7 @@ compile pkg ifaces modul = -- PHASES -canonicalize : Pkg.Name -> Dict ModuleName.Raw I.Interface -> Src.Module -> Result E.Error Can.Module +canonicalize : Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Result E.Error Can.Module canonicalize pkg ifaces modul = case Tuple.second (R.run (Canonicalize.canonicalize pkg ifaces modul)) of Ok canonical -> @@ -66,7 +66,7 @@ canonicalize pkg ifaces modul = Err (E.BadNames errors) -typeCheck : Src.Module -> Can.Module -> Result E.Error (Dict Name Can.Annotation) +typeCheck : Src.Module -> Can.Module -> Result E.Error (Dict String Name Can.Annotation) typeCheck modul canonical = case TypeCheck.unsafePerformIO (TypeCheck.bind Type.run (Type.constrain canonical)) of Ok annotations -> @@ -86,7 +86,7 @@ nitpick canonical = Err (E.BadPatterns errors) -optimize : Src.Module -> Dict Name.Name Can.Annotation -> Can.Module -> Result E.Error Opt.LocalGraph +optimize : Src.Module -> Dict String Name.Name Can.Annotation -> Can.Module -> Result E.Error Opt.LocalGraph optimize modul annotations canonical = case Tuple.second (R.run (Optimize.optimize annotations canonical)) of Ok localGraph -> diff --git a/src/Compiler/Data/Map/Utils.elm b/src/Compiler/Data/Map/Utils.elm index a1cfcc14b..f45ecd695 100644 --- a/src/Compiler/Data/Map/Utils.elm +++ b/src/Compiler/Data/Map/Utils.elm @@ -13,20 +13,20 @@ import Utils.Main as Utils -- FROM KEYS -fromKeys : (comparable -> v) -> List comparable -> Dict comparable v +fromKeys : (comparable -> v) -> List comparable -> Dict comparable comparable v fromKeys toValue keys = - Dict.fromList compare (List.map (\k -> ( k, toValue k )) keys) + Dict.fromList identity (List.map (\k -> ( k, toValue k )) keys) -fromKeysA : (k -> k -> Order) -> (k -> IO v) -> List k -> IO (Dict k v) -fromKeysA keyComparison toValue keys = - IO.fmap (Dict.fromList keyComparison) (Utils.listTraverse (\k -> IO.fmap (Tuple.pair k) (toValue k)) keys) +fromKeysA : (k -> comparable) -> (k -> IO v) -> List k -> IO (Dict comparable k v) +fromKeysA toComparable toValue keys = + IO.fmap (Dict.fromList toComparable) (Utils.listTraverse (\k -> IO.fmap (Tuple.pair k) (toValue k)) keys) -- ANY -any : (v -> Bool) -> Dict k v -> Bool +any : (v -> Bool) -> Dict c k v -> Bool any isGood dict = - Dict.foldl (\_ v acc -> isGood v || acc) False dict + Dict.foldl (\_ _ -> EQ) (\_ v acc -> isGood v || acc) False dict diff --git a/src/Compiler/Elm/Compiler/Type/Extract.elm b/src/Compiler/Elm/Compiler/Type/Extract.elm index b879b17b7..35db4a9d7 100644 --- a/src/Compiler/Elm/Compiler/Type/Extract.elm +++ b/src/Compiler/Elm/Compiler/Type/Extract.elm @@ -89,11 +89,11 @@ type Types = -- PERF profile Opt.Global representation -- current representation needs less allocation -- but maybe the lookup is much worse - Types (Dict IO.Canonical Types_) + Types (Dict (List String) IO.Canonical Types_) type Types_ - = Types_ (Dict Name.Name Can.Union) (Dict Name.Name Can.Alias) + = Types_ (Dict String Name.Name Can.Union) (Dict String Name.Name Can.Alias) mergeMany : List Types -> Types @@ -108,20 +108,20 @@ mergeMany listOfTypes = merge : Types -> Types -> Types merge (Types types1) (Types types2) = - Types (Dict.union ModuleName.compareCanonical types1 types2) + Types (Dict.union types1 types2) fromInterface : ModuleName.Raw -> I.Interface -> Types fromInterface name (I.Interface pkg _ unions aliases _) = Types <| - Dict.singleton (IO.Canonical pkg name) <| + Dict.singleton ModuleName.toComparableCanonical (IO.Canonical pkg name) <| Types_ (Dict.map (\_ -> I.extractUnion) unions) (Dict.map (\_ -> I.extractAlias) aliases) fromDependencyInterface : IO.Canonical -> I.DependencyInterface -> Types fromDependencyInterface home di = Types - (Dict.singleton home <| + (Dict.singleton ModuleName.toComparableCanonical home <| case di of I.Public (I.Interface _ _ unions aliases _) -> Types_ (Dict.map (\_ -> I.extractUnion) unions) (Dict.map (\_ -> I.extractAlias) aliases) @@ -150,11 +150,11 @@ fromMsg types message = extractTransitive : Types -> Deps -> Deps -> ( List T.Alias, List T.Union ) extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) = let - aliases : EverySet Opt.Global + aliases : EverySet (List String) Opt.Global aliases = EverySet.diff nextAliases seenAliases - unions : EverySet Opt.Global + unions : EverySet (List String) Opt.Global unions = EverySet.diff nextUnions seenUnions in @@ -166,13 +166,13 @@ extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnio ( newDeps, ( resultAlias, resultUnion ) ) = run (pure Tuple.pair - |> apply (traverse (extractAlias types) (EverySet.toList aliases)) - |> apply (traverse (extractUnion types) (EverySet.toList unions)) + |> apply (traverse (extractAlias types) (EverySet.toList Opt.compareGlobal aliases)) + |> apply (traverse (extractUnion types) (EverySet.toList Opt.compareGlobal unions)) ) oldDeps : Deps oldDeps = - Deps (EverySet.union Opt.compareGlobal seenAliases nextAliases) (EverySet.union Opt.compareGlobal seenUnions nextUnions) + Deps (EverySet.union seenAliases nextAliases) (EverySet.union seenUnions nextUnions) ( remainingResultAlias, remainingResultUnion ) = extractTransitive types oldDeps newDeps @@ -184,9 +184,9 @@ extractAlias : Types -> Opt.Global -> Extractor T.Alias extractAlias (Types dict) (Opt.Global home name) = let (Can.Alias args aliasType) = - Utils.find home dict + Utils.find ModuleName.toComparableCanonical home dict |> (\(Types_ _ aliasInfo) -> aliasInfo) - |> Utils.find name + |> Utils.find identity name in fmap (T.Alias (toPublicName home name) args) (extract aliasType) @@ -203,9 +203,9 @@ extractUnion (Types dict) (Opt.Global home name) = toPublicName home name (Can.Union vars ctors _ _) = - Utils.find home dict + Utils.find ModuleName.toComparableCanonical home dict |> (\(Types_ unionInfo _) -> unionInfo) - |> Utils.find name + |> Utils.find identity name in fmap (T.Union pname vars) (traverse extractCtor ctors) @@ -220,7 +220,7 @@ extractCtor (Can.Ctor ctor _ _ args) = type Deps - = Deps (EverySet Opt.Global) (EverySet Opt.Global) + = Deps (EverySet (List String) Opt.Global) (EverySet (List String) Opt.Global) noDeps : Deps @@ -233,11 +233,11 @@ noDeps = type Extractor a - = Extractor (EverySet Opt.Global -> EverySet Opt.Global -> EResult a) + = Extractor (EverySet (List String) Opt.Global -> EverySet (List String) Opt.Global -> EResult a) type EResult a - = EResult (EverySet Opt.Global) (EverySet Opt.Global) a + = EResult (EverySet (List String) Opt.Global) (EverySet (List String) Opt.Global) a run : Extractor a -> ( Deps, a ) @@ -251,14 +251,14 @@ addAlias : Opt.Global -> a -> Extractor a addAlias alias value = Extractor <| \aliases unions -> - EResult (EverySet.insert Opt.compareGlobal alias aliases) unions value + EResult (EverySet.insert Opt.toComparableGlobal alias aliases) unions value addUnion : Opt.Global -> a -> Extractor a addUnion union value = Extractor <| \aliases unions -> - EResult aliases (EverySet.insert Opt.compareGlobal union unions) value + EResult aliases (EverySet.insert Opt.toComparableGlobal union unions) value fmap : (a -> b) -> Extractor a -> Extractor b @@ -318,7 +318,7 @@ typesCodec = (\typesCodecEncoder (Types types) -> typesCodecEncoder types ) - |> Serialize.variant1 Types (S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec types_Codec) + |> Serialize.variant1 Types (S.assocListDict ModuleName.toComparableCanonical ModuleName.compareCanonical ModuleName.canonicalCodec types_Codec) |> Serialize.finishCustomType @@ -330,6 +330,6 @@ types_Codec = ) |> Serialize.variant2 Types_ - (S.assocListDict compare Serialize.string Can.unionCodec) - (S.assocListDict compare Serialize.string Can.aliasCodec) + (S.assocListDict identity compare Serialize.string Can.unionCodec) + (S.assocListDict identity compare Serialize.string Can.aliasCodec) |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/Docs.elm b/src/Compiler/Elm/Docs.elm index fed8d27e1..df5fd769d 100644 --- a/src/Compiler/Elm/Docs.elm +++ b/src/Compiler/Elm/Docs.elm @@ -46,11 +46,11 @@ import Utils.Main as Utils type alias Documentation = - Dict Name Module + Dict String Name Module type Module - = Module Name Comment (Dict Name Union) (Dict Name Alias) (Dict Name Value) (Dict Name Binop) + = Module Name Comment (Dict String Name Union) (Dict String Name Alias) (Dict String Name Value) (Dict String Name Binop) type alias Comment = @@ -79,7 +79,7 @@ type Binop encode : Documentation -> E.Value encode docs = - E.list encodeModule (Dict.values docs) + E.list encodeModule (Dict.values compare docs) encodeModule : Module -> E.Value @@ -87,10 +87,10 @@ encodeModule (Module name comment unions aliases values binops) = E.object [ ( "name", ModuleName.encode name ) , ( "comment", E.string comment ) - , ( "unions", E.list encodeUnion (Dict.toList unions) ) - , ( "aliases", E.list encodeAlias (Dict.toList aliases) ) - , ( "values", E.list encodeValue (Dict.toList values) ) - , ( "binops", E.list encodeBinop (Dict.toList binops) ) + , ( "unions", E.list encodeUnion (Dict.toList compare unions) ) + , ( "aliases", E.list encodeAlias (Dict.toList compare aliases) ) + , ( "values", E.list encodeValue (Dict.toList compare values) ) + , ( "binops", E.list encodeBinop (Dict.toList compare binops) ) ] @@ -107,7 +107,7 @@ decoder = toDict : List Module -> Documentation toDict modules = - Dict.fromList compare (List.map toDictHelp modules) + Dict.fromList identity (List.map toDictHelp modules) toDictHelp : Module -> ( Name.Name, Module ) @@ -126,9 +126,9 @@ moduleDecoder = |> D.apply (D.field "binops" (dictDecoder binop)) -dictDecoder : D.Decoder Error a -> D.Decoder Error (Dict Name a) +dictDecoder : D.Decoder Error a -> D.Decoder Error (Dict String Name a) dictDecoder entryDecoder = - D.fmap (Dict.fromList compare) (D.list (named entryDecoder)) + D.fmap (Dict.fromList identity) (D.list (named entryDecoder)) named : D.Decoder Error a -> D.Decoder Error ( Name.Name, a ) @@ -332,7 +332,7 @@ fromModule ((Can.Module _ exports docs _ _ _ _ _) as modul) = Src.YesDocs overview comments -> parseOverview overview |> Result.andThen (checkNames exportDict) - |> Result.andThen (\_ -> checkDefs exportDict overview (Dict.fromList compare comments) modul) + |> Result.andThen (\_ -> checkDefs exportDict overview (Dict.fromList identity comments) modul) @@ -484,7 +484,7 @@ untilDocs src pos end row col = -- CHECK NAMES -checkNames : Dict Name (A.Located Can.Export) -> List (A.Located Name) -> Result E.Error () +checkNames : Dict String Name (A.Located Can.Export) -> List (A.Located Name) -> Result E.Error () checkNames exports names = let docs : DocNameRegions @@ -503,7 +503,7 @@ checkNames exports names = loneDoc name regions _ = onlyInDocs name regions in - case Result.run (Dict.merge loneExport checkBoth loneDoc exports docs (Result.ok A.zero)) of + case Result.run (Dict.merge compare loneExport checkBoth loneDoc exports docs (Result.ok A.zero)) of ( _, Ok _ ) -> Ok () @@ -512,12 +512,12 @@ checkNames exports names = type alias DocNameRegions = - Dict Name (OneOrMore.OneOrMore A.Region) + Dict String Name (OneOrMore.OneOrMore A.Region) addName : A.Located Name -> DocNameRegions -> DocNameRegions addName (A.At region name) dict = - Utils.mapInsertWith compare OneOrMore.more name (OneOrMore.one region) dict + Utils.mapInsertWith identity OneOrMore.more name (OneOrMore.one region) dict isUnique : Name -> OneOrMore.OneOrMore A.Region -> Result.RResult i w E.NameProblem A.Region @@ -552,7 +552,7 @@ onlyInExports name (A.At region _) = -- CHECK DEFS -checkDefs : Dict Name (A.Located Can.Export) -> Src.Comment -> Dict Name Src.Comment -> Can.Module -> Result E.Error Module +checkDefs : Dict String Name (A.Located Can.Export) -> Src.Comment -> Dict String Name Src.Comment -> Can.Module -> Result E.Error Module checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) = let types : Types @@ -563,12 +563,12 @@ checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases info = Info comments types unions aliases infixes effects in - case Result.run (Result.mapTraverseWithKey compare (checkExport info) exportDict) of + case Result.run (Result.mapTraverseWithKey identity compare (checkExport info) exportDict) of ( _, Err problems ) -> Err (E.DefProblems (OneOrMore.destruct NE.Nonempty problems)) ( _, Ok inserters ) -> - Ok (Dict.foldr (\_ -> (<|)) (emptyModule name overview) inserters) + Ok (Dict.foldr compare (\_ -> (<|)) (emptyModule name overview) inserters) emptyModule : IO.Canonical -> Src.Comment -> Module @@ -577,7 +577,7 @@ emptyModule (IO.Canonical _ name) (Src.Comment overview) = type Info - = Info (Dict Name.Name Src.Comment) (Dict Name.Name (Result A.Region Can.Type)) (Dict Name.Name Can.Union) (Dict Name.Name Can.Alias) (Dict Name.Name Can.Binop) Can.Effects + = Info (Dict String Name.Name Src.Comment) (Dict String Name.Name (Result A.Region Can.Type)) (Dict String Name.Name Can.Union) (Dict String Name.Name Can.Alias) (Dict String Name.Name Can.Binop) Can.Effects checkExport : Info -> Name -> A.Located Can.Export -> Result.RResult i w E.DefProblem (Module -> Module) @@ -597,7 +597,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex mComment mUnions mAliases - (Dict.insert compare name (Value comment tipe) mValues) + (Dict.insert identity name (Value comment tipe) mValues) mBinops ) ) @@ -606,7 +606,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex Can.ExportBinop -> let (Can.Binop_ assoc prec realName) = - Utils.find name iBinops + Utils.find identity name iBinops in getType realName info |> Result.bind @@ -622,7 +622,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex mUnions mAliases mValues - (Dict.insert compare name (Binop comment tipe assoc prec) mBinops) + (Dict.insert identity name (Binop comment tipe assoc prec) mBinops) ) ) ) @@ -630,7 +630,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex Can.ExportAlias -> let (Can.Alias tvars tipe) = - Utils.find name iAliases + Utils.find identity name iAliases in getComment region name info |> Result.bind @@ -640,7 +640,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex Module mName mComment mUnions - (Dict.insert compare name (Alias comment tvars (Extract.fromType tipe)) mAliases) + (Dict.insert identity name (Alias comment tvars (Extract.fromType tipe)) mAliases) mValues mBinops ) @@ -649,7 +649,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex Can.ExportUnionOpen -> let (Can.Union tvars ctors _ _) = - Utils.find name iUnions + Utils.find identity name iUnions in getComment region name info |> Result.bind @@ -658,7 +658,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex (\(Module mName mComment mUnions mAliases mValues mBinops) -> Module mName mComment - (Dict.insert compare name (Union comment tvars (List.map dector ctors)) mUnions) + (Dict.insert identity name (Union comment tvars (List.map dector ctors)) mUnions) mAliases mValues mBinops @@ -668,7 +668,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex Can.ExportUnionClosed -> let (Can.Union tvars _ _ _) = - Utils.find name iUnions + Utils.find identity name iUnions in getComment region name info |> Result.bind @@ -677,7 +677,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex (\(Module mName mComment mUnions mAliases mValues mBinops) -> Module mName mComment - (Dict.insert compare name (Union comment tvars []) mUnions) + (Dict.insert identity name (Union comment tvars []) mUnions) mAliases mValues mBinops @@ -697,7 +697,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex mComment mUnions mAliases - (Dict.insert compare name (Value comment tipe) mValues) + (Dict.insert identity name (Value comment tipe) mValues) mBinops ) ) @@ -706,7 +706,7 @@ checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region ex getComment : A.Region -> Name.Name -> Info -> Result.RResult i w E.DefProblem Comment getComment region name (Info iComments _ _ _ _ _) = - case Dict.get name iComments of + case Dict.get identity name iComments of Nothing -> Result.throw (E.NoComment name region) @@ -716,7 +716,7 @@ getComment region name (Info iComments _ _ _ _ _) = getType : Name.Name -> Info -> Result.RResult i w E.DefProblem Type.Type getType name (Info _ iValues _ _ _ _) = - case Utils.find name iValues of + case Utils.find identity name iValues of Err region -> Result.throw (E.NoAnnotation name region) @@ -734,7 +734,7 @@ dector (Can.Ctor name _ _ args) = type alias Types = - Dict Name.Name (Result A.Region Can.Type) + Dict String Name.Name (Result A.Region Can.Type) gatherTypes : Can.Decls -> Types -> Types @@ -754,7 +754,7 @@ addDef : Types -> Can.Def -> Types addDef types def = case def of Can.Def (A.At region name) _ _ -> - Dict.insert compare name (Err region) types + Dict.insert identity name (Err region) types Can.TypedDef (A.At _ name) _ typedArgs _ resultType -> let @@ -762,7 +762,7 @@ addDef types def = tipe = List.foldr Can.TLambda resultType (List.map Tuple.second typedArgs) in - Dict.insert compare name (Ok tipe) types + Dict.insert identity name (Ok tipe) types @@ -771,7 +771,7 @@ addDef types def = jsonCodec : Codec e Documentation jsonCodec = - S.assocListDict compare Serialize.string moduleCodec + S.assocListDict identity compare Serialize.string moduleCodec moduleCodec : Codec e Module @@ -784,10 +784,10 @@ moduleCodec = Module Serialize.string Serialize.string - (S.assocListDict compare Serialize.string unionCodec) - (S.assocListDict compare Serialize.string aliasCodec) - (S.assocListDict compare Serialize.string valueCodec) - (S.assocListDict compare Serialize.string binopCodec) + (S.assocListDict identity compare Serialize.string unionCodec) + (S.assocListDict identity compare Serialize.string aliasCodec) + (S.assocListDict identity compare Serialize.string valueCodec) + (S.assocListDict identity compare Serialize.string binopCodec) |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/Interface.elm b/src/Compiler/Elm/Interface.elm index 10b92eaf3..ef0e03d1a 100644 --- a/src/Compiler/Elm/Interface.elm +++ b/src/Compiler/Elm/Interface.elm @@ -33,7 +33,7 @@ import Utils.Main as Utils type Interface - = Interface Pkg.Name (Dict Name.Name Can.Annotation) (Dict Name.Name Union) (Dict Name.Name Alias) (Dict Name.Name Binop) + = Interface Pkg.Name (Dict String Name.Name Can.Annotation) (Dict String Name.Name Union) (Dict String Name.Name Alias) (Dict String Name.Name Binop) type Union @@ -55,7 +55,7 @@ type Binop -- FROM MODULE -fromModule : Pkg.Name -> Can.Module -> Dict Name.Name Can.Annotation -> Interface +fromModule : Pkg.Name -> Can.Module -> Dict String Name.Name Can.Annotation -> Interface fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations = Interface home (restrict exports annotations) @@ -64,57 +64,58 @@ fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations = (restrict exports (Dict.map (\_ -> toOp annotations) binops)) -restrict : Can.Exports -> Dict Name.Name a -> Dict Name.Name a +restrict : Can.Exports -> Dict String Name.Name a -> Dict String Name.Name a restrict exports dict = case exports of Can.ExportEverything _ -> dict Can.Export explicitExports -> - Dict.intersection dict explicitExports + Dict.intersection compare dict explicitExports -toOp : Dict Name.Name Can.Annotation -> Can.Binop -> Binop +toOp : Dict String Name.Name Can.Annotation -> Can.Binop -> Binop toOp types (Can.Binop_ associativity precedence name) = - Binop name (Utils.find name types) associativity precedence + Binop name (Utils.find identity name types) associativity precedence -restrictUnions : Can.Exports -> Dict Name.Name Can.Union -> Dict Name.Name Union +restrictUnions : Can.Exports -> Dict String Name.Name Can.Union -> Dict String Name.Name Union restrictUnions exports unions = case exports of Can.ExportEverything _ -> Dict.map (\_ -> OpenUnion) unions Can.Export explicitExports -> - Dict.merge + Dict.merge compare (\_ _ result -> result) (\k (A.At _ export) union result -> case export of Can.ExportUnionOpen -> - Dict.insert compare k (OpenUnion union) result + Dict.insert identity k (OpenUnion union) result Can.ExportUnionClosed -> - Dict.insert compare k (ClosedUnion union) result + Dict.insert identity k (ClosedUnion union) result _ -> crash "impossible exports discovered in restrictUnions" ) - (\k union result -> Dict.insert compare k (PrivateUnion union) result) + (\k union result -> Dict.insert identity k (PrivateUnion union) result) explicitExports unions Dict.empty -restrictAliases : Can.Exports -> Dict Name.Name Can.Alias -> Dict Name.Name Alias +restrictAliases : Can.Exports -> Dict String Name.Name Can.Alias -> Dict String Name.Name Alias restrictAliases exports aliases = case exports of Can.ExportEverything _ -> Dict.map (\_ alias -> PublicAlias alias) aliases Can.Export explicitExports -> - Dict.merge (\_ _ result -> result) - (\k _ alias result -> Dict.insert compare k (PublicAlias alias) result) - (\k alias result -> Dict.insert compare k (PrivateAlias alias) result) + Dict.merge compare + (\_ _ result -> result) + (\k _ alias result -> Dict.insert identity k (PublicAlias alias) result) + (\k alias result -> Dict.insert identity k (PrivateAlias alias) result) explicitExports aliases Dict.empty @@ -153,7 +154,7 @@ toPublicAlias iAlias = type DependencyInterface = Public Interface - | Private Pkg.Name (Dict Name.Name Can.Union) (Dict Name.Name Can.Alias) + | Private Pkg.Name (Dict String Name.Name Can.Union) (Dict String Name.Name Can.Alias) public : Interface -> DependencyInterface @@ -211,10 +212,10 @@ interfaceCodec = ) |> Serialize.variant5 Interface Pkg.nameCodec - (S.assocListDict compare Serialize.string Can.annotationCodec) - (S.assocListDict compare Serialize.string unionCodec) - (S.assocListDict compare Serialize.string aliasCodec) - (S.assocListDict compare Serialize.string binopCodec) + (S.assocListDict identity compare Serialize.string Can.annotationCodec) + (S.assocListDict identity compare Serialize.string unionCodec) + (S.assocListDict identity compare Serialize.string aliasCodec) + (S.assocListDict identity compare Serialize.string binopCodec) |> Serialize.finishCustomType @@ -276,5 +277,5 @@ dependencyInterfaceCodec = privateEncoder pkg unions aliases ) |> Serialize.variant1 Public interfaceCodec - |> Serialize.variant3 Private Pkg.nameCodec (S.assocListDict compare Serialize.string Can.unionCodec) (S.assocListDict compare Serialize.string Can.aliasCodec) + |> Serialize.variant3 Private Pkg.nameCodec (S.assocListDict identity compare Serialize.string Can.unionCodec) (S.assocListDict identity compare Serialize.string Can.aliasCodec) |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/Kernel.elm b/src/Compiler/Elm/Kernel.elm index 70d81bcb9..b2a681cb9 100644 --- a/src/Compiler/Elm/Kernel.elm +++ b/src/Compiler/Elm/Kernel.elm @@ -41,12 +41,12 @@ type Chunk -- COUNT FIELDS -countFields : List Chunk -> Dict Name Int +countFields : List Chunk -> Dict String Name Int countFields chunks = List.foldr addField Dict.empty chunks -addField : Chunk -> Dict Name Int -> Dict Name Int +addField : Chunk -> Dict String Name Int -> Dict String Name Int addField chunk fields = case chunk of JS _ -> @@ -59,7 +59,7 @@ addField chunk fields = fields ElmField f -> - Dict.update compare + Dict.update identity f (Maybe.map ((+) 1) >> Maybe.withDefault 1 @@ -89,7 +89,7 @@ type Content type alias Foreigns = - Dict ModuleName.Raw Pkg.Name + Dict String ModuleName.Raw Pkg.Name fromByteString : Pkg.Name -> Foreigns -> String -> Maybe Content @@ -196,11 +196,11 @@ chompChunks vs es fs src pos end row col lastPos revChunks = type alias Enums = - Dict Int (Dict Name Int) + Dict Int Int (Dict String Name Int) type alias Fields = - Dict Name Int + Dict String Name Int toByteString : String -> Int -> Int -> String @@ -274,7 +274,7 @@ chompTag vs es fs src pos end row col revChunks = chompChunks vs es fs src newPos end row newCol newPos (Prod :: revChunks) else - case Dict.get name vs of + case Dict.get identity name vs of Just chunk -> chompChunks vs es fs src newPos end row newCol newPos (chunk :: revChunks) @@ -284,7 +284,7 @@ chompTag vs es fs src pos end row col revChunks = lookupField : Name -> Fields -> ( Int, Fields ) lookupField name fields = - case Dict.get name fields of + case Dict.get identity name fields of Just n -> ( n, fields ) @@ -294,7 +294,7 @@ lookupField name fields = n = Dict.size fields in - ( n, Dict.insert compare name n fields ) + ( n, Dict.insert identity name n fields ) lookupEnum : Char -> Name -> Enums -> ( Int, Enums ) @@ -304,12 +304,12 @@ lookupEnum word var allEnums = code = Char.toCode word - enums : Dict Name Int + enums : Dict String Name Int enums = - Dict.get code allEnums + Dict.get identity code allEnums |> Maybe.withDefault Dict.empty in - case Dict.get var enums of + case Dict.get identity var enums of Just n -> ( n, allEnums ) @@ -319,7 +319,7 @@ lookupEnum word var allEnums = n = Dict.size enums in - ( n, Dict.insert compare code (Dict.insert compare var n enums) allEnums ) + ( n, Dict.insert identity code (Dict.insert identity var n enums) allEnums ) @@ -327,7 +327,7 @@ lookupEnum word var allEnums = type alias VarTable = - Dict Name Chunk + Dict String Name Chunk toVarTable : Pkg.Name -> Foreigns -> List Src.Import -> VarTable @@ -348,9 +348,9 @@ addImport pkg foreigns (Src.Import (A.At _ importName) maybeAlias exposing_) vta home = Name.getKernel importName - add : Name -> Dict Name Chunk -> Dict Name Chunk + add : Name -> Dict String Name Chunk -> Dict String Name Chunk add name table = - Dict.insert compare (Name.sepBy '_' home name) (JsVar home name) table + Dict.insert identity (Name.sepBy '_' home name) (JsVar home name) table in List.foldl add vtable (toNames exposing_) @@ -358,15 +358,15 @@ addImport pkg foreigns (Src.Import (A.At _ importName) maybeAlias exposing_) vta let home : IO.Canonical home = - IO.Canonical (Dict.get importName foreigns |> Maybe.withDefault pkg) importName + IO.Canonical (Dict.get identity importName foreigns |> Maybe.withDefault pkg) importName prefix : Name prefix = toPrefix importName maybeAlias - add : Name -> Dict Name Chunk -> Dict Name Chunk + add : Name -> Dict String Name Chunk -> Dict String Name Chunk add name table = - Dict.insert compare (Name.sepBy '_' prefix name) (ElmVar home name) table + Dict.insert identity (Name.sepBy '_' prefix name) (ElmVar home name) table in List.foldl add vtable (toNames exposing_) diff --git a/src/Compiler/Elm/Licenses.elm b/src/Compiler/Elm/Licenses.elm index bca8fd253..ef291c10b 100644 --- a/src/Compiler/Elm/Licenses.elm +++ b/src/Compiler/Elm/Licenses.elm @@ -49,15 +49,15 @@ decoder toError = check : String -> Result (List String) License check givenCode = - if Dict.member givenCode osiApprovedSpdxLicenses then + if Dict.member identity givenCode osiApprovedSpdxLicenses then Ok (License givenCode) else let pairs : List ( String, String ) pairs = - List.map (\code -> ( code, code )) (Dict.keys osiApprovedSpdxLicenses) - ++ Dict.toList osiApprovedSpdxLicenses + List.map (\code -> ( code, code )) (Dict.keys compare osiApprovedSpdxLicenses) + ++ Dict.toList compare osiApprovedSpdxLicenses in Err (List.map Tuple.first @@ -71,9 +71,9 @@ check givenCode = -- LIST OF LICENSES -osiApprovedSpdxLicenses : Dict String String +osiApprovedSpdxLicenses : Dict String String String osiApprovedSpdxLicenses = - Dict.fromList compare + Dict.fromList identity [ ( "0BSD", "BSD Zero Clause License" ) , ( "AAL", "Attribution Assurance License" ) , ( "AFL-1.1", "Academic Free License v1.1" ) diff --git a/src/Compiler/Elm/ModuleName.elm b/src/Compiler/Elm/ModuleName.elm index 23d76b282..e337454ec 100644 --- a/src/Compiler/Elm/ModuleName.elm +++ b/src/Compiler/Elm/ModuleName.elm @@ -22,6 +22,7 @@ module Compiler.Elm.ModuleName exposing , sub , texture , toChars + , toComparableCanonical , toFilePath , toHyphenPath , tuple @@ -181,6 +182,11 @@ compareCanonical (Canonical pkg1 name1) (Canonical pkg2 name2) = GT +toComparableCanonical : Canonical -> List String +toComparableCanonical (Canonical ( author, project ) name) = + [ author, project, name ] + + -- CORE diff --git a/src/Compiler/Elm/Package.elm b/src/Compiler/Elm/Package.elm index 9bfa85907..2fb678da7 100644 --- a/src/Compiler/Elm/Package.elm +++ b/src/Compiler/Elm/Package.elm @@ -173,7 +173,7 @@ elm_explorations = -- PACKAGE SUGGESTIONS -suggestions : Dict String Name +suggestions : Dict String String Name suggestions = let random : Name @@ -188,7 +188,7 @@ suggestions = file = toName elm "file" in - Dict.fromList compare + Dict.fromList identity [ ( "Browser", browser ) , ( "File", file ) , ( "File.Download", file ) diff --git a/src/Compiler/Elm/Version.elm b/src/Compiler/Elm/Version.elm index 9e76ac67d..d3bae4643 100644 --- a/src/Compiler/Elm/Version.elm +++ b/src/Compiler/Elm/Version.elm @@ -15,6 +15,7 @@ module Compiler.Elm.Version exposing , one , parser , toChars + , toComparable , versionCodec ) @@ -52,6 +53,11 @@ compare (Version major1 minor1 patch1) (Version major2 minor2 patch2) = majorRes +toComparable : Version -> ( Int, Int, Int ) +toComparable (Version major_ minor_ patch_) = + ( major_, minor_, patch_ ) + + min : Version -> Version -> Version min v1 v2 = case compare v1 v2 of diff --git a/src/Compiler/Generate/JavaScript.elm b/src/Compiler/Generate/JavaScript.elm index 652640619..10b94a08c 100644 --- a/src/Compiler/Generate/JavaScript.elm +++ b/src/Compiler/Generate/JavaScript.elm @@ -34,11 +34,11 @@ import Utils.Main as Utils type alias Graph = - Dict Opt.Global Opt.Node + Dict (List String) Opt.Global Opt.Node type alias Mains = - Dict IO.Canonical Opt.Main + Dict (List String) IO.Canonical Opt.Main generate : Mode.Mode -> Opt.GlobalGraph -> Mains -> String @@ -46,7 +46,7 @@ generate mode (Opt.GlobalGraph graph _) mains = let state : State state = - Dict.foldr (addMain mode graph) emptyState mains + Dict.foldr ModuleName.compareCanonical (addMain mode graph) emptyState mains in "(function(scope){\n'use strict';" ++ Functions.functions @@ -198,7 +198,7 @@ postMessage localizer home maybeName tipe = type State - = State (List String) (List String) (EverySet Opt.Global) + = State (List String) (List String) (EverySet (List String) Opt.Global) emptyState : State @@ -218,28 +218,28 @@ prependBuilders revBuilders monolith = addGlobal : Mode.Mode -> Graph -> State -> Opt.Global -> State addGlobal mode graph ((State revKernels builders seen) as state) global = - if EverySet.member global seen then + if EverySet.member Opt.toComparableGlobal global seen then state else addGlobalHelp mode graph global <| - State revKernels builders (EverySet.insert Opt.compareGlobal global seen) + State revKernels builders (EverySet.insert Opt.toComparableGlobal global seen) addGlobalHelp : Mode.Mode -> Graph -> Opt.Global -> State -> State addGlobalHelp mode graph global state = let - addDeps : EverySet Opt.Global -> State -> State + addDeps : EverySet (List String) Opt.Global -> State -> State addDeps deps someState = let sortedDeps : List Opt.Global sortedDeps = -- This is required given that it looks like `Data.Set.union` sorts its elements - List.sortWith Opt.compareGlobal (EverySet.toList deps) + List.sortWith Opt.compareGlobal (EverySet.toList Opt.compareGlobal deps) in List.foldl (flip (addGlobal mode graph)) someState sortedDeps in - case Utils.find global graph of + case Utils.find Opt.toComparableGlobal global graph of Opt.Define expr deps -> addStmt (addDeps deps state) (var global (Expr.generate mode expr)) @@ -579,7 +579,7 @@ toMainExports mode mains = exports : String exports = - generateExports mode (Dict.foldr addToTrie emptyTrie mains) + generateExports mode (Dict.foldr ModuleName.compareCanonical addToTrie emptyTrie mains) in export ++ "(" ++ exports ++ ");" @@ -598,7 +598,7 @@ generateExports mode (Trie maybeMain subs) = ++ JS.exprToBuilder (Expr.generateMain mode home main) ++ end in - case Dict.toList subs of + case Dict.toList compare subs of [] -> starter "" ++ "}" @@ -621,7 +621,7 @@ addSubTrie mode end ( name, trie ) = type Trie - = Trie (Maybe ( IO.Canonical, Opt.Main )) (Dict Name.Name Trie) + = Trie (Maybe ( IO.Canonical, Opt.Main )) (Dict String Name.Name Trie) emptyTrie : Trie @@ -641,14 +641,14 @@ segmentsToTrie home segments main = Trie (Just ( home, main )) Dict.empty segment :: otherSegments -> - Trie Nothing (Dict.singleton segment (segmentsToTrie home otherSegments main)) + Trie Nothing (Dict.singleton identity segment (segmentsToTrie home otherSegments main)) merge : Trie -> Trie -> Trie merge (Trie main1 subs1) (Trie main2 subs2) = Trie (checkedMerge main1 main2) - (Utils.mapUnionWith compare merge subs1 subs2) + (Utils.mapUnionWith identity compare merge subs1 subs2) checkedMerge : Maybe a -> Maybe a -> Maybe a diff --git a/src/Compiler/Generate/JavaScript/Expression.elm b/src/Compiler/Generate/JavaScript/Expression.elm index 29f71bdb8..44fe22d82 100644 --- a/src/Compiler/Generate/JavaScript/Expression.elm +++ b/src/Compiler/Generate/JavaScript/Expression.elm @@ -192,9 +192,9 @@ generate mode expression = , JS.ExprString (generateField mode field) ) - toTranslationObject : EverySet.EverySet Name.Name -> JS.Expr + toTranslationObject : EverySet.EverySet String Name.Name -> JS.Expr toTranslationObject fields = - JS.ExprObject (List.map toTranlation (EverySet.toList fields)) + JS.ExprObject (List.map toTranlation (EverySet.toList compare fields)) in JsExpr <| JS.ExprObject @@ -303,14 +303,14 @@ ctorToInt home name index = -- RECORDS -generateRecord : Mode.Mode -> Dict Name.Name Opt.Expr -> JS.Expr +generateRecord : Mode.Mode -> Dict String Name.Name Opt.Expr -> JS.Expr generateRecord mode fields = let toPair : ( Name.Name, Opt.Expr ) -> ( JsName.Name, JS.Expr ) toPair ( field, value ) = ( generateField mode field, generateJsExpr mode value ) in - JS.ExprObject (List.map toPair (Dict.toList fields)) + JS.ExprObject (List.map toPair (Dict.toList compare fields)) generateField : Mode.Mode -> Name.Name -> JsName.Name @@ -320,7 +320,7 @@ generateField mode name = JsName.fromLocal name Mode.Prod fields -> - Utils.find name fields + Utils.find identity name fields @@ -370,7 +370,7 @@ positionToJsExpr (A.Position line column) = generateFunction : List JsName.Name -> Code -> Code generateFunction args body = - case Dict.get (List.length args) funcHelpers of + case Dict.get identity (List.length args) funcHelpers of Just helper -> JsExpr <| JS.ExprCall helper @@ -389,9 +389,9 @@ generateFunction args body = List.foldr addArg body args -funcHelpers : Dict Int JS.Expr +funcHelpers : Dict Int Int JS.Expr funcHelpers = - Dict.fromList compare <| + Dict.fromList identity <| List.map (\n -> ( n, JS.ExprRef (JsName.makeF n) )) (List.range 2 9) @@ -440,7 +440,7 @@ generateGlobalCall home name args = generateNormalCall : JS.Expr -> List JS.Expr -> JS.Expr generateNormalCall func args = - case Dict.get (List.length args) callHelpers of + case Dict.get identity (List.length args) callHelpers of Just helper -> JS.ExprCall helper (func :: args) @@ -448,9 +448,9 @@ generateNormalCall func args = List.foldl (\a f -> JS.ExprCall f [ a ]) func args -callHelpers : Dict Int JS.Expr +callHelpers : Dict Int Int JS.Expr callHelpers = - Dict.fromList compare <| + Dict.fromList identity <| List.map (\n -> ( n, JS.ExprRef (JsName.makeA n) )) (List.range 2 9) diff --git a/src/Compiler/Generate/JavaScript/Name.elm b/src/Compiler/Generate/JavaScript/Name.elm index 6964f3459..2469f7b7e 100644 --- a/src/Compiler/Generate/JavaScript/Name.elm +++ b/src/Compiler/Generate/JavaScript/Name.elm @@ -44,7 +44,7 @@ fromInt n = fromLocal : Name.Name -> Name fromLocal name = - if EverySet.member name reservedNames then + if EverySet.member identity name reservedNames then "_" ++ name else @@ -114,14 +114,14 @@ usd = -- RESERVED NAMES -reservedNames : EverySet String +reservedNames : EverySet String String reservedNames = - EverySet.union compare jsReservedWords elmReservedWords + EverySet.union jsReservedWords elmReservedWords -jsReservedWords : EverySet String +jsReservedWords : EverySet String String jsReservedWords = - EverySet.fromList compare + EverySet.fromList identity [ "do" , "if" , "in" @@ -192,9 +192,9 @@ jsReservedWords = ] -elmReservedWords : EverySet String +elmReservedWords : EverySet String String elmReservedWords = - EverySet.fromList compare + EverySet.fromList identity [ "F2" , "F3" , "F4" @@ -250,7 +250,7 @@ intToAsciiHelp width blockSize badFields n = name = unsafeIntToAscii width [] n in - Dict.get name renamings |> Maybe.withDefault name + Dict.get identity name renamings |> Maybe.withDefault name else intToAsciiHelp (width + 1) (blockSize * numInnerBytes) biggerBadFields (n - availableSize) @@ -328,17 +328,17 @@ type BadFields type alias Renamings = - Dict Name.Name Name.Name + Dict String Name.Name Name.Name allBadFields : List BadFields allBadFields = let - add : String -> Dict Int BadFields -> Dict Int BadFields + add : String -> Dict Int Int BadFields -> Dict Int Int BadFields add keyword dict = - Dict.update compare (String.length keyword) (Just << addRenaming keyword) dict + Dict.update identity (String.length keyword) (Just << addRenaming keyword) dict in - Dict.values (EverySet.foldr add Dict.empty jsReservedWords) + Dict.values compare (EverySet.foldr compare add Dict.empty jsReservedWords) addRenaming : String -> Maybe BadFields -> BadFields @@ -354,7 +354,7 @@ addRenaming keyword maybeBadFields = in case maybeBadFields of Nothing -> - BadFields (Dict.singleton keyword (unsafeIntToAscii width [] maxName)) + BadFields (Dict.singleton identity keyword (unsafeIntToAscii width [] maxName)) Just (BadFields renamings) -> - BadFields (Dict.insert compare keyword (unsafeIntToAscii width [] (maxName - Dict.size renamings)) renamings) + BadFields (Dict.insert identity keyword (unsafeIntToAscii width [] (maxName - Dict.size renamings)) renamings) diff --git a/src/Compiler/Generate/Mode.elm b/src/Compiler/Generate/Mode.elm index 689f79bf9..232c17d91 100644 --- a/src/Compiler/Generate/Mode.elm +++ b/src/Compiler/Generate/Mode.elm @@ -40,18 +40,18 @@ isDebug mode = type alias ShortFieldNames = - Dict Name.Name JsName.Name + Dict String Name.Name JsName.Name shortenFieldNames : Opt.GlobalGraph -> ShortFieldNames shortenFieldNames (Opt.GlobalGraph _ frequencies) = - Dict.foldr (\_ -> addToShortNames) Dict.empty <| - Dict.foldr addToBuckets Dict.empty frequencies + Dict.foldr compare (\_ -> addToShortNames) Dict.empty <| + Dict.foldr compare addToBuckets Dict.empty frequencies -addToBuckets : Name.Name -> Int -> Dict Int (List Name.Name) -> Dict Int (List Name.Name) +addToBuckets : Name.Name -> Int -> Dict Int Int (List Name.Name) -> Dict Int Int (List Name.Name) addToBuckets field frequency buckets = - Utils.mapInsertWith compare (++) frequency [ field ] buckets + Utils.mapInsertWith identity (++) frequency [ field ] buckets addToShortNames : List Name.Name -> ShortFieldNames -> ShortFieldNames @@ -66,4 +66,4 @@ addField field shortNames = rename = JsName.fromInt (Dict.size shortNames) in - Dict.insert compare field rename shortNames + Dict.insert identity field rename shortNames diff --git a/src/Compiler/Json/Decode.elm b/src/Compiler/Json/Decode.elm index 8f678e2dc..431160056 100644 --- a/src/Compiler/Json/Decode.elm +++ b/src/Compiler/Json/Decode.elm @@ -47,10 +47,10 @@ import Utils.Crash exposing (crash) -- CORE HELPERS -assocListDict : (k -> k -> Order) -> Decode.Decoder k -> Decode.Decoder v -> Decode.Decoder (Dict k v) -assocListDict keyComparison keyDecoder valueDecoder = +assocListDict : (k -> comparable) -> Decode.Decoder k -> Decode.Decoder v -> Decode.Decoder (Dict comparable k v) +assocListDict toComparable keyDecoder valueDecoder = Decode.list (jsonPair keyDecoder valueDecoder) - |> Decode.map (Dict.fromList keyComparison) + |> Decode.map (Dict.fromList toComparable) jsonPair : Decode.Decoder a -> Decode.Decoder b -> Decode.Decoder ( a, b ) @@ -60,10 +60,10 @@ jsonPair firstDecoder secondDecoder = (Decode.field "b" secondDecoder) -everySet : (a -> a -> Order) -> Decode.Decoder a -> Decode.Decoder (EverySet a) -everySet keyComparison decoder = +everySet : (a -> comparable) -> Decode.Decoder a -> Decode.Decoder (EverySet comparable a) +everySet toComparable decoder = Decode.list decoder - |> Decode.map (EverySet.fromList keyComparison) + |> Decode.map (EverySet.fromList toComparable) nonempty : Decode.Decoder a -> Decode.Decoder (NE.Nonempty a) @@ -331,9 +331,9 @@ type KeyDecoder x a = KeyDecoder (P.Parser x a) (Row -> Col -> x) -dict : (k -> k -> Order) -> KeyDecoder x k -> Decoder x a -> Decoder x (Dict k a) -dict keyComparison keyDecoder valueDecoder = - fmap (Dict.fromList keyComparison) (pairs keyDecoder valueDecoder) +dict : (k -> comparable) -> KeyDecoder x k -> Decoder x a -> Decoder x (Dict comparable k a) +dict toComparable keyDecoder valueDecoder = + fmap (Dict.fromList toComparable) (pairs keyDecoder valueDecoder) pairs : KeyDecoder x k -> Decoder x a -> Decoder x (List ( k, a )) diff --git a/src/Compiler/Json/Encode.elm b/src/Compiler/Json/Encode.elm index c79ee45eb..890df1c51 100644 --- a/src/Compiler/Json/Encode.elm +++ b/src/Compiler/Json/Encode.elm @@ -36,9 +36,9 @@ import System.IO as IO exposing (IO(..)) -- CORE HELPERS -assocListDict : (k -> Encode.Value) -> (v -> Encode.Value) -> Dict k v -> Encode.Value -assocListDict keyEncoder valueEncoder = - Encode.list (jsonPair keyEncoder valueEncoder) << List.reverse << Dict.toList +assocListDict : (k -> k -> Order) -> (k -> Encode.Value) -> (v -> Encode.Value) -> Dict c k v -> Encode.Value +assocListDict keyComparison keyEncoder valueEncoder = + Encode.list (jsonPair keyEncoder valueEncoder) << List.reverse << Dict.toList keyComparison jsonPair : (a -> Encode.Value) -> (b -> Encode.Value) -> ( a, b ) -> Encode.Value @@ -49,9 +49,9 @@ jsonPair firstEncoder secondEncoder ( a, b ) = ] -everySet : (a -> Encode.Value) -> EverySet a -> Encode.Value -everySet encoder = - Encode.list encoder << List.reverse << EverySet.toList +everySet : (a -> a -> Order) -> (a -> Encode.Value) -> EverySet c a -> Encode.Value +everySet keyComparison encoder = + Encode.list encoder << List.reverse << EverySet.toList keyComparison result : (x -> Encode.Value) -> (a -> Encode.Value) -> Result x a -> Encode.Value @@ -152,11 +152,10 @@ null = Null -dict : (k -> k -> Order) -> (k -> String) -> (v -> Value) -> Dict k v -> Value +dict : (k -> k -> Order) -> (k -> String) -> (v -> Value) -> Dict c k v -> Value dict keyComparison encodeKey encodeValue pairs = Object - (Dict.toList pairs - |> List.sortWith (\( ka, _ ) ( kb, _ ) -> keyComparison ka kb) + (Dict.toList keyComparison pairs |> List.map (\( k, v ) -> ( encodeKey k, encodeValue v )) ) diff --git a/src/Compiler/Nitpick/Debug.elm b/src/Compiler/Nitpick/Debug.elm index 85bb81dbc..de97881ad 100644 --- a/src/Compiler/Nitpick/Debug.elm +++ b/src/Compiler/Nitpick/Debug.elm @@ -121,10 +121,10 @@ hasDebug expression = hasDebug r Opt.Update r fs -> - hasDebug r || List.any hasDebug (Dict.values fs) + hasDebug r || List.any hasDebug (Dict.values compare fs) Opt.Record fs -> - List.any hasDebug (Dict.values fs) + List.any hasDebug (Dict.values compare fs) Opt.Unit -> False diff --git a/src/Compiler/Nitpick/PatternMatches.elm b/src/Compiler/Nitpick/PatternMatches.elm index c88d021be..900700c59 100644 --- a/src/Compiler/Nitpick/PatternMatches.elm +++ b/src/Compiler/Nitpick/PatternMatches.elm @@ -339,10 +339,10 @@ checkExpr (A.At region expression) errors = checkExpr record errors Can.Update _ record fields -> - checkExpr record <| Dict.foldr (\_ -> checkField) errors fields + checkExpr record <| Dict.foldr compare (\_ -> checkField) errors fields Can.Record fields -> - Dict.foldr (\_ -> checkExpr) errors fields + Dict.foldr compare (\_ -> checkExpr) errors fields Can.Unit -> errors @@ -442,7 +442,7 @@ isExhaustive matrix n = else let - ctors : Dict Name.Name Can.Union + ctors : Dict String Name.Name Can.Union ctors = collectCtors matrix @@ -477,9 +477,9 @@ isExhaustive matrix n = List.concatMap isAltExhaustive altList -isMissing : Can.Union -> Dict Name.Name a -> Can.Ctor -> Maybe Pattern +isMissing : Can.Union -> Dict String Name.Name a -> Can.Ctor -> Maybe Pattern isMissing union ctors (Can.Ctor name _ arity _) = - if Dict.member name ctors then + if Dict.member identity name ctors then Nothing else @@ -664,7 +664,7 @@ type Complete isComplete : List (List Pattern) -> Complete isComplete matrix = let - ctors : Dict Name.Name Can.Union + ctors : Dict String Name.Name Can.Union ctors = collectCtors matrix @@ -691,16 +691,16 @@ isComplete matrix = -- COLLECT CTORS -collectCtors : List (List Pattern) -> Dict Name.Name Can.Union +collectCtors : List (List Pattern) -> Dict String Name.Name Can.Union collectCtors matrix = List.foldl (\row acc -> collectCtorsHelp acc row) Dict.empty matrix -collectCtorsHelp : Dict Name.Name Can.Union -> List Pattern -> Dict Name.Name Can.Union +collectCtorsHelp : Dict String Name.Name Can.Union -> List Pattern -> Dict String Name.Name Can.Union collectCtorsHelp ctors row = case row of (Ctor union name _) :: _ -> - Dict.insert compare name union ctors + Dict.insert identity name union ctors _ -> ctors diff --git a/src/Compiler/Optimize/Case.elm b/src/Compiler/Optimize/Case.elm index 37b185e16..291d0474c 100644 --- a/src/Compiler/Optimize/Case.elm +++ b/src/Compiler/Optimize/Case.elm @@ -24,7 +24,7 @@ optimize temp root optBranches = decider = treeToDecider (DT.compile patterns) - targetCounts : Dict Int Int + targetCounts : Dict Int Int Int targetCounts = countTargets decider @@ -33,7 +33,7 @@ optimize temp root optBranches = in Opt.Case temp root - (insertChoices (Dict.fromList compare choices) decider) + (insertChoices (Dict.fromList identity choices) decider) (List.filterMap identity maybeJumps) @@ -116,22 +116,22 @@ toChain path test successTree failureTree = -- can be inlined. Whether things are inlined or jumps is called a "choice". -countTargets : Opt.Decider Int -> Dict Int Int +countTargets : Opt.Decider Int -> Dict Int Int Int countTargets decisionTree = case decisionTree of Opt.Leaf target -> - Dict.singleton target 1 + Dict.singleton identity target 1 Opt.Chain _ success failure -> - Utils.mapUnionWith compare (+) (countTargets success) (countTargets failure) + Utils.mapUnionWith identity compare (+) (countTargets success) (countTargets failure) Opt.FanOut _ tests fallback -> - Utils.mapUnionsWith compare (+) (List.map countTargets (fallback :: List.map Tuple.second tests)) + Utils.mapUnionsWith identity compare (+) (List.map countTargets (fallback :: List.map Tuple.second tests)) -createChoices : Dict Int Int -> ( Int, Opt.Expr ) -> ( ( Int, Opt.Choice ), Maybe ( Int, Opt.Expr ) ) +createChoices : Dict Int Int Int -> ( Int, Opt.Expr ) -> ( ( Int, Opt.Choice ), Maybe ( Int, Opt.Expr ) ) createChoices targetCounts ( target, branch ) = - if Dict.get target targetCounts == Just 1 then + if Dict.get identity target targetCounts == Just 1 then ( ( target, Opt.Inline branch ) , Nothing ) @@ -142,7 +142,7 @@ createChoices targetCounts ( target, branch ) = ) -insertChoices : Dict Int Opt.Choice -> Opt.Decider Int -> Opt.Decider Opt.Choice +insertChoices : Dict Int Int Opt.Choice -> Opt.Decider Int -> Opt.Decider Opt.Choice insertChoices choiceDict decider = let go : Opt.Decider Int -> Opt.Decider Opt.Choice @@ -151,7 +151,7 @@ insertChoices choiceDict decider = in case decider of Opt.Leaf target -> - Opt.Leaf (Utils.find target choiceDict) + Opt.Leaf (Utils.find identity target choiceDict) Opt.Chain testChain success failure -> Opt.Chain testChain (go success) (go failure) diff --git a/src/Compiler/Optimize/DecisionTree.elm b/src/Compiler/Optimize/DecisionTree.elm index 95226443e..0bbe81b14 100644 --- a/src/Compiler/Optimize/DecisionTree.elm +++ b/src/Compiler/Optimize/DecisionTree.elm @@ -75,59 +75,6 @@ type Test | IsBool Bool -compareTest : Test -> Test -> Order -compareTest test1 test2 = - case ( test1, test2 ) of - ( IsCtor home1 _ _ _ _, IsCtor home2 _ _ _ _ ) -> - ModuleName.compareCanonical home1 home2 - - ( IsInt value1, IsInt value2 ) -> - compare value1 value2 - - ( IsChr chr1, IsChr chr2 ) -> - compare chr1 chr2 - - ( IsStr str1, IsStr str2 ) -> - compare str1 str2 - - ( IsBool True, IsBool False ) -> - GT - - ( IsBool False, IsBool True ) -> - LT - - _ -> - let - toOrderVal : Test -> Int - toOrderVal t = - case t of - IsCtor _ _ _ _ _ -> - 1 - - IsCons -> - 2 - - IsNil -> - 3 - - IsTuple -> - 4 - - IsInt _ -> - 5 - - IsChr _ -> - 6 - - IsStr _ -> - 7 - - IsBool _ -> - 8 - in - compare (toOrderVal test1) (toOrderVal test2) - - type Path = Index Index.ZeroBased Path | Unbox Path @@ -355,14 +302,14 @@ testsAtPath selectedPath branches = allTests = List.filterMap (testAtPath selectedPath) branches - skipVisited : Test -> ( List Test, EverySet.EverySet Test ) -> ( List Test, EverySet.EverySet Test ) + skipVisited : Test -> ( List Test, EverySet.EverySet String Test ) -> ( List Test, EverySet.EverySet String Test ) skipVisited test (( uniqueTests, visitedTests ) as curr) = - if EverySet.member test visitedTests then + if EverySet.member (Serialize.encodeToString testCodec) test visitedTests then curr else ( test :: uniqueTests - , EverySet.insert compareTest test visitedTests + , EverySet.insert (Serialize.encodeToString testCodec) test visitedTests ) in Tuple.first (List.foldr skipVisited ( [], EverySet.empty ) allTests) diff --git a/src/Compiler/Optimize/Expression.elm b/src/Compiler/Optimize/Expression.elm index 0f633e6f0..3b6652fcb 100644 --- a/src/Compiler/Optimize/Expression.elm +++ b/src/Compiler/Optimize/Expression.elm @@ -23,7 +23,7 @@ import Data.Set as EverySet exposing (EverySet) type alias Cycle = - EverySet Name.Name + EverySet String Name.Name optimize : Cycle -> Can.Expr -> Names.Tracker Opt.Expr @@ -33,7 +33,7 @@ optimize cycle (A.At region expression) = Names.pure (Opt.VarLocal name) Can.VarTopLevel home name -> - if EverySet.member name cycle then + if EverySet.member identity name cycle then Names.pure (Opt.VarCycle home name) else @@ -215,7 +215,7 @@ optimize cycle (A.At region expression) = ) Can.Update _ record updates -> - Names.mapTraverse compare (optimizeUpdate cycle) updates + Names.mapTraverse identity compare (optimizeUpdate cycle) updates |> Names.bind (\optUpdates -> optimize cycle record @@ -226,7 +226,7 @@ optimize cycle (A.At region expression) = ) Can.Record fields -> - Names.mapTraverse compare (optimize cycle) fields + Names.mapTraverse identity compare (optimize cycle) fields |> Names.bind (\optFields -> Names.registerFieldDict fields (Opt.Record optFields) @@ -257,7 +257,7 @@ optimize cycle (A.At region expression) = ) Can.Shader src (Shader.Types attributes uniforms _) -> - Names.pure (Opt.Shader src (EverySet.fromList compare (Dict.keys attributes)) (EverySet.fromList compare (Dict.keys uniforms))) + Names.pure (Opt.Shader src (EverySet.fromList identity (Dict.keys compare attributes)) (EverySet.fromList identity (Dict.keys compare uniforms))) diff --git a/src/Compiler/Optimize/Module.elm b/src/Compiler/Optimize/Module.elm index d54a3ad00..c57930d79 100644 --- a/src/Compiler/Optimize/Module.elm +++ b/src/Compiler/Optimize/Module.elm @@ -28,7 +28,7 @@ type alias MResult i w a = type alias Annotations = - Dict Name.Name Can.Annotation + Dict String Name.Name Can.Annotation optimize : Annotations -> Can.Module -> MResult i (List W.Warning) Opt.LocalGraph @@ -45,12 +45,12 @@ optimize annotations (Can.Module home _ _ decls unions aliases _ effects) = type alias Nodes = - Dict Opt.Global Opt.Node + Dict (List String) Opt.Global Opt.Node -addUnions : IO.Canonical -> Dict Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph +addUnions : IO.Canonical -> Dict String Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph addUnions home unions (Opt.LocalGraph main nodes fields) = - Opt.LocalGraph main (Dict.foldr (\_ -> addUnion home) nodes unions) fields + Opt.LocalGraph main (Dict.foldr compare (\_ -> addUnion home) nodes unions) fields addUnion : IO.Canonical -> Can.Union -> Nodes -> Nodes @@ -73,16 +73,16 @@ addCtorNode home opts (Can.Ctor name index numArgs _) nodes = Can.Enum -> Opt.Enum index in - Dict.insert Opt.compareGlobal (Opt.Global home name) node nodes + Dict.insert Opt.toComparableGlobal (Opt.Global home name) node nodes -- ALIAS -addAliases : IO.Canonical -> Dict Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph +addAliases : IO.Canonical -> Dict String Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph addAliases home aliases graph = - Dict.foldr (addAlias home) graph aliases + Dict.foldr compare (addAlias home) graph aliases addAlias : IO.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph @@ -102,16 +102,16 @@ addAlias home name (Can.Alias _ tipe) ((Opt.LocalGraph main nodes fieldCounts) a in Opt.LocalGraph main - (Dict.insert Opt.compareGlobal (Opt.Global home name) node nodes) - (Dict.foldr addRecordCtorField fieldCounts fields) + (Dict.insert Opt.toComparableGlobal (Opt.Global home name) node nodes) + (Dict.foldr compare addRecordCtorField fieldCounts fields) _ -> graph -addRecordCtorField : Name.Name -> Can.FieldType -> Dict Name.Name Int -> Dict Name.Name Int +addRecordCtorField : Name.Name -> Can.FieldType -> Dict String Name.Name Int -> Dict String Name.Name Int addRecordCtorField name _ fields = - Utils.mapInsertWith compare (+) name 1 fields + Utils.mapInsertWith identity (+) name 1 fields @@ -125,7 +125,7 @@ addEffects home effects ((Opt.LocalGraph main nodes fields) as graph) = graph Can.Ports ports -> - Dict.foldr (addPort home) graph ports + Dict.foldr compare (addPort home) graph ports Can.Manager _ _ _ manager -> let @@ -145,21 +145,21 @@ addEffects home effects ((Opt.LocalGraph main nodes fields) as graph) = link = Opt.Link fx - newNodes : Dict Opt.Global Opt.Node + newNodes : Dict (List String) Opt.Global Opt.Node newNodes = case manager of Can.Cmd _ -> - Dict.insert Opt.compareGlobal cmd link <| - Dict.insert Opt.compareGlobal fx (Opt.Manager Opt.Cmd) nodes + Dict.insert Opt.toComparableGlobal cmd link <| + Dict.insert Opt.toComparableGlobal fx (Opt.Manager Opt.Cmd) nodes Can.Sub _ -> - Dict.insert Opt.compareGlobal sub link <| - Dict.insert Opt.compareGlobal fx (Opt.Manager Opt.Sub) nodes + Dict.insert Opt.toComparableGlobal sub link <| + Dict.insert Opt.toComparableGlobal fx (Opt.Manager Opt.Sub) nodes Can.Fx _ _ -> - Dict.insert Opt.compareGlobal cmd link <| - Dict.insert Opt.compareGlobal sub link <| - Dict.insert Opt.compareGlobal fx (Opt.Manager Opt.Fx) nodes + Dict.insert Opt.toComparableGlobal cmd link <| + Dict.insert Opt.toComparableGlobal sub link <| + Dict.insert Opt.toComparableGlobal fx (Opt.Manager Opt.Fx) nodes in Opt.LocalGraph main newNodes fields @@ -194,12 +194,12 @@ addPort home name port_ graph = -- HELPER -addToGraph : Opt.Global -> Opt.Node -> Dict Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph +addToGraph : Opt.Global -> Opt.Node -> Dict String Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) = Opt.LocalGraph main - (Dict.insert Opt.compareGlobal name node nodes) - (Utils.mapUnionWith compare (+) fields fieldCounts) + (Dict.insert Opt.toComparableGlobal name node nodes) + (Utils.mapUnionWith identity compare (+) fields fieldCounts) @@ -273,7 +273,7 @@ addDef home annotations def graph = Can.Def (A.At region name) args body -> let (Can.Forall _ tipe) = - Utils.find name annotations + Utils.find identity name annotations in addDefHelp region annotations home name args body graph |> R.then_ (R.warn (W.MissingTypeAnnotation region name tipe)) @@ -290,12 +290,12 @@ addDefHelp region annotations home name args body ((Opt.LocalGraph _ nodes field else let (Can.Forall _ tipe) = - Utils.find name annotations + Utils.find identity name annotations - addMain : ( EverySet Opt.Global, Dict Name.Name Int, Opt.Main ) -> Opt.LocalGraph + addMain : ( EverySet (List String) Opt.Global, Dict String Name.Name Int, Opt.Main ) -> Opt.LocalGraph addMain ( deps, fields, main ) = addDefNode home name args body deps <| - Opt.LocalGraph (Just main) nodes (Utils.mapUnionWith compare (+) fields fieldCounts) + Opt.LocalGraph (Just main) nodes (Utils.mapUnionWith identity compare (+) fields fieldCounts) in case Type.deepDealias tipe of Can.TType hm nm [ _ ] -> @@ -321,7 +321,7 @@ addDefHelp region annotations home name args body ((Opt.LocalGraph _ nodes field R.throw (E.BadType region tipe) -addDefNode : IO.Canonical -> Name.Name -> List Can.Pattern -> Can.Expr -> EverySet Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph +addDefNode : IO.Canonical -> Name.Name -> List Can.Pattern -> Can.Expr -> EverySet (List String) Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph addDefNode home name args body mainDeps graph = let ( deps, fields, def ) = @@ -342,7 +342,7 @@ addDefNode home name args body mainDeps graph = ) ) in - addToGraph (Opt.Global home name) (Opt.Define def (EverySet.union Opt.compareGlobal deps mainDeps)) fields graph + addToGraph (Opt.Global home name) (Opt.Define def (EverySet.union deps mainDeps)) fields graph @@ -367,11 +367,11 @@ addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) = cycleName = Opt.Global home (Name.fromManyNames names) - cycle : EverySet Name.Name + cycle : EverySet String Name.Name cycle = List.foldr addValueName EverySet.empty defs - links : Dict Opt.Global Opt.Node + links : Dict (List String) Opt.Global Opt.Node links = List.foldr (addLink home (Opt.Link cycleName)) Dict.empty defs @@ -383,8 +383,8 @@ addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) = in Opt.LocalGraph main - (Dict.insert Opt.compareGlobal cycleName (Opt.Cycle names values functions deps) (Dict.union Opt.compareGlobal links nodes)) - (Utils.mapUnionWith compare (+) fields fieldCounts) + (Dict.insert Opt.toComparableGlobal cycleName (Opt.Cycle names values functions deps) (Dict.union links nodes)) + (Utils.mapUnionWith identity compare (+) fields fieldCounts) toName : Can.Def -> Name.Name @@ -397,39 +397,39 @@ toName def = name -addValueName : Can.Def -> EverySet Name.Name -> EverySet Name.Name +addValueName : Can.Def -> EverySet String Name.Name -> EverySet String Name.Name addValueName def names = case def of Can.Def (A.At _ name) args _ -> if List.isEmpty args then - EverySet.insert compare name names + EverySet.insert identity name names else names Can.TypedDef (A.At _ name) _ args _ _ -> if List.isEmpty args then - EverySet.insert compare name names + EverySet.insert identity name names else names -addLink : IO.Canonical -> Opt.Node -> Can.Def -> Dict Opt.Global Opt.Node -> Dict Opt.Global Opt.Node +addLink : IO.Canonical -> Opt.Node -> Can.Def -> Dict (List String) Opt.Global Opt.Node -> Dict (List String) Opt.Global Opt.Node addLink home link def links = case def of Can.Def (A.At _ name) _ _ -> - Dict.insert Opt.compareGlobal (Opt.Global home name) link links + Dict.insert Opt.toComparableGlobal (Opt.Global home name) link links Can.TypedDef (A.At _ name) _ _ _ _ -> - Dict.insert Opt.compareGlobal (Opt.Global home name) link links + Dict.insert Opt.toComparableGlobal (Opt.Global home name) link links -- ADD RECURSIVE DEFS -addRecDef : EverySet Name.Name -> State -> Can.Def -> Names.Tracker State +addRecDef : EverySet String Name.Name -> State -> Can.Def -> Names.Tracker State addRecDef cycle state def = case def of Can.Def (A.At _ name) args body -> @@ -439,7 +439,7 @@ addRecDef cycle state def = addRecDefHelp cycle state name (List.map Tuple.first args) body -addRecDefHelp : EverySet Name.Name -> State -> Name.Name -> List Can.Pattern -> Can.Expr -> Names.Tracker State +addRecDefHelp : EverySet String Name.Name -> State -> Name.Name -> List Can.Pattern -> Can.Expr -> Names.Tracker State addRecDefHelp cycle (State { values, functions }) name args body = case args of [] -> diff --git a/src/Compiler/Optimize/Names.elm b/src/Compiler/Optimize/Names.elm index 97395924b..5de8f0fce 100644 --- a/src/Compiler/Optimize/Names.elm +++ b/src/Compiler/Optimize/Names.elm @@ -35,17 +35,17 @@ import Utils.Main as Utils type Tracker a = Tracker (Int - -> EverySet Opt.Global - -> Dict Name Int + -> EverySet (List String) Opt.Global + -> Dict String Name Int -> TResult a ) type TResult a - = TResult Int (EverySet Opt.Global) (Dict Name Int) a + = TResult Int (EverySet (List String) Opt.Global) (Dict String Name Int) a -run : Tracker a -> ( EverySet Opt.Global, Dict Name Int, a ) +run : Tracker a -> ( EverySet (List String) Opt.Global, Dict String Name Int, a ) run (Tracker k) = case k 0 EverySet.empty Dict.empty of TResult _ deps fields value -> @@ -63,7 +63,7 @@ registerKernel : Name -> a -> Tracker a registerKernel home value = Tracker <| \uid deps fields -> - TResult uid (EverySet.insert Opt.compareGlobal (Opt.toKernelGlobal home) deps) fields value + TResult uid (EverySet.insert Opt.toComparableGlobal (Opt.toKernelGlobal home) deps) fields value registerGlobal : IO.Canonical -> Name -> Tracker Opt.Expr @@ -75,7 +75,7 @@ registerGlobal home name = global = Opt.Global home name in - TResult uid (EverySet.insert Opt.compareGlobal global deps) fields (Opt.VarGlobal global) + TResult uid (EverySet.insert Opt.toComparableGlobal global deps) fields (Opt.VarGlobal global) registerDebug : Name -> IO.Canonical -> A.Region -> Tracker Opt.Expr @@ -87,7 +87,7 @@ registerDebug name home region = global = Opt.Global ModuleName.debug name in - TResult uid (EverySet.insert Opt.compareGlobal global deps) fields (Opt.VarDebug name home region Nothing) + TResult uid (EverySet.insert Opt.toComparableGlobal global deps) fields (Opt.VarDebug name home region Nothing) registerCtor : IO.Canonical -> Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr @@ -99,9 +99,9 @@ registerCtor home name index opts = global = Opt.Global home name - newDeps : EverySet Opt.Global + newDeps : EverySet (List String) Opt.Global newDeps = - EverySet.insert Opt.compareGlobal global deps + EverySet.insert Opt.toComparableGlobal global deps in case opts of Can.Normal -> @@ -128,7 +128,7 @@ registerCtor home name index opts = Opt.VarEnum global index Can.Unbox -> - TResult uid (EverySet.insert Opt.compareGlobal identity newDeps) fields (Opt.VarBox global) + TResult uid (EverySet.insert Opt.toComparableGlobal identity newDeps) fields (Opt.VarBox global) identity : Opt.Global @@ -140,16 +140,16 @@ registerField : Name -> a -> Tracker a registerField name value = Tracker <| \uid d fields -> - TResult uid d (Utils.mapInsertWith compare (+) name 1 fields) value + TResult uid d (Utils.mapInsertWith Basics.identity (+) name 1 fields) value -registerFieldDict : Dict Name v -> a -> Tracker a +registerFieldDict : Dict String Name v -> a -> Tracker a registerFieldDict newFields value = Tracker <| \uid d fields -> TResult uid d - (Utils.mapUnionWith compare (+) fields (Dict.map (\_ -> toOne) newFields)) + (Utils.mapUnionWith Basics.identity compare (+) fields (Dict.map (\_ -> toOne) newFields)) value @@ -165,9 +165,9 @@ registerFieldList names value = TResult uid deps (List.foldr addOne fields names) value -addOne : Name -> Dict Name Int -> Dict Name Int +addOne : Name -> Dict String Name Int -> Dict String Name Int addOne name fields = - Utils.mapInsertWith compare (+) name 1 fields + Utils.mapInsertWith Basics.identity (+) name 1 fields @@ -204,6 +204,6 @@ traverse func = List.foldl (\a -> bind (\acc -> fmap (\b -> acc ++ [ b ]) (func a))) (pure []) -mapTraverse : (k -> k -> Order) -> (a -> Tracker b) -> Dict k a -> Tracker (Dict k b) -mapTraverse keyComparison func = - Dict.foldl (\k a -> bind (\c -> fmap (\va -> Dict.insert keyComparison k va c) (func a))) (pure Dict.empty) +mapTraverse : (k -> comparable) -> (k -> k -> Order) -> (a -> Tracker b) -> Dict comparable k a -> Tracker (Dict comparable k b) +mapTraverse toComparable keyComparison func = + Dict.foldl keyComparison (\k a -> bind (\c -> fmap (\va -> Dict.insert toComparable k va c) (func a))) (pure Dict.empty) diff --git a/src/Compiler/Optimize/Port.elm b/src/Compiler/Optimize/Port.elm index 197cb4ec1..d49f34ef9 100644 --- a/src/Compiler/Optimize/Port.elm +++ b/src/Compiler/Optimize/Port.elm @@ -95,7 +95,7 @@ toEncoder tipe = encode "object" |> Names.bind (\object -> - Names.traverse encodeField (Dict.toList fields) + Names.traverse encodeField (Dict.toList compare fields) |> Names.bind (\keyValuePairs -> Names.registerFieldDict fields @@ -423,7 +423,7 @@ indexAndThen i tipe decoder = -- DECODE RECORDS -decodeRecord : Dict Name.Name Can.FieldType -> Names.Tracker Opt.Expr +decodeRecord : Dict String Name.Name Can.FieldType -> Names.Tracker Opt.Expr decodeRecord fields = let toFieldExpr : Name -> b -> Opt.Expr @@ -436,7 +436,7 @@ decodeRecord fields = in Names.bind (\succeed -> - Names.registerFieldDict fields (Dict.toList fields) + Names.registerFieldDict fields (Dict.toList compare fields) |> Names.bind (\fieldDecoders -> List.foldl (\fieldDecoder -> Names.bind (\optCall -> fieldAndThen optCall fieldDecoder)) diff --git a/src/Compiler/Parse/Shader.elm b/src/Compiler/Parse/Shader.elm index 15d17562c..1e7cc4423 100644 --- a/src/Compiler/Parse/Shader.elm +++ b/src/Compiler/Parse/Shader.elm @@ -188,13 +188,13 @@ addInput : ( GLS.StorageQualifier, Shader.Type, String ) -> Shader.Types -> Shad addInput ( qual, tipe, name ) (Shader.Types attribute uniform varying) = case qual of GLS.Attribute -> - Shader.Types (Dict.insert compare name tipe attribute) uniform varying + Shader.Types (Dict.insert identity name tipe attribute) uniform varying GLS.Uniform -> - Shader.Types attribute (Dict.insert compare name tipe uniform) varying + Shader.Types attribute (Dict.insert identity name tipe uniform) varying GLS.Varying -> - Shader.Types attribute uniform (Dict.insert compare name tipe varying) + Shader.Types attribute uniform (Dict.insert identity name tipe varying) _ -> Crash.crash "Should never happen due to `extractInputs` function" diff --git a/src/Compiler/Parse/Symbol.elm b/src/Compiler/Parse/Symbol.elm index 87f32069c..1efcfccb9 100644 --- a/src/Compiler/Parse/Symbol.elm +++ b/src/Compiler/Parse/Symbol.elm @@ -67,23 +67,13 @@ operator toExpectation toError = chompOps : String -> Int -> Int -> Int chompOps src pos end = - if pos < end && isBinopChar src pos then + if pos < end && isBinopCharHelp (P.unsafeIndex src pos) then chompOps src (pos + 1) end else pos -isBinopChar : String -> Int -> Bool -isBinopChar src pos = - src - |> String.dropLeft pos - |> String.toList - |> List.head - |> Maybe.map isBinopCharHelp - |> Maybe.withDefault False - - isBinopCharHelp : Char -> Bool isBinopCharHelp char = let @@ -91,12 +81,12 @@ isBinopCharHelp char = code = Char.toCode char in - EverySet.member code binopCharSet + EverySet.member identity code binopCharSet -binopCharSet : EverySet Int +binopCharSet : EverySet Int Int binopCharSet = - EverySet.fromList compare (List.map Char.toCode (String.toList "+-/*=.<>:&|^?%!")) + EverySet.fromList identity (List.map Char.toCode (String.toList "+-/*=.<>:&|^?%!")) diff --git a/src/Compiler/Parse/Variable.elm b/src/Compiler/Parse/Variable.elm index c3047963d..90465326d 100644 --- a/src/Compiler/Parse/Variable.elm +++ b/src/Compiler/Parse/Variable.elm @@ -64,7 +64,7 @@ lower toError = name = Name.fromPtr src pos newPos in - if EverySet.member name reservedWords then + if EverySet.member identity name reservedWords then Err (P.PErr P.Empty row col toError) else @@ -76,9 +76,9 @@ lower toError = Ok (P.POk P.Consumed name newState) -reservedWords : EverySet Name +reservedWords : EverySet String Name reservedWords = - EverySet.fromList compare + EverySet.fromList identity [ "if" , "then" , "else" @@ -247,7 +247,7 @@ foreignAlpha toError = P.State src alphaEnd end indent row newCol in if alphaStart == pos then - if EverySet.member name reservedWords then + if EverySet.member identity name reservedWords then Err (P.PErr P.Empty row col toError) else diff --git a/src/Compiler/Reporting/Error/Canonicalize.elm b/src/Compiler/Reporting/Error/Canonicalize.elm index 89e0287aa..9a71639db 100644 --- a/src/Compiler/Reporting/Error/Canonicalize.elm +++ b/src/Compiler/Reporting/Error/Canonicalize.elm @@ -62,7 +62,7 @@ type Error | NotFoundVar A.Region (Maybe Name) Name PossibleNames | NotFoundType A.Region (Maybe Name) Name PossibleNames | NotFoundVariant A.Region (Maybe Name) Name PossibleNames - | NotFoundBinop A.Region Name (EverySet Name) + | NotFoundBinop A.Region Name (EverySet String Name) | PatternHasRecordCtor A.Region Name | PortPayloadInvalid A.Region Name Can.Type InvalidPayload | PortTypeInvalid A.Region Name PortProblem @@ -104,8 +104,8 @@ type PortProblem type alias PossibleNames = - { locals : EverySet Name - , quals : Dict Name (EverySet Name) + { locals : EverySet String Name + , quals : Dict String Name (EverySet String Name) } @@ -608,7 +608,7 @@ toReport source err = let suggestions : List String suggestions = - List.take 2 <| Suggest.sort op identity (EverySet.toList locals) + List.take 2 <| Suggest.sort op identity (EverySet.toList compare locals) format : D.Doc -> D.Doc format altOp = @@ -1186,11 +1186,11 @@ notFound source region maybePrefix name thing { locals, quals } = possibleNames : List String possibleNames = let - addQuals : Name -> EverySet Name -> List String -> List String + addQuals : Name -> EverySet String Name -> List String -> List String addQuals prefix localSet allNames = - EverySet.foldr (\x xs -> toQualString prefix x :: xs) allNames localSet + EverySet.foldr compare (\x xs -> toQualString prefix x :: xs) allNames localSet in - Dict.foldr addQuals (EverySet.toList locals) quals + Dict.foldr compare addQuals (EverySet.toList compare locals) quals nearbyNames : List String nearbyNames = @@ -1224,7 +1224,7 @@ notFound source region maybePrefix name thing { locals, quals } = "These names seem close though:" Just prefix -> - case Dict.get prefix quals of + case Dict.get identity prefix quals of Nothing -> toDetails ("I cannot find a `" ++ prefix ++ "` module. Is there an `import` for it?") @@ -1488,7 +1488,7 @@ errorCodec = (Serialize.maybe Serialize.string) Serialize.string possibleNamesCodec - |> Serialize.variant3 NotFoundBinop A.regionCodec Serialize.string (S.everySet compare Serialize.string) + |> Serialize.variant3 NotFoundBinop A.regionCodec Serialize.string (S.everySet identity compare Serialize.string) |> Serialize.variant2 PatternHasRecordCtor A.regionCodec Serialize.string |> Serialize.variant4 PortPayloadInvalid A.regionCodec Serialize.string Can.typeCodec invalidPayloadCodec |> Serialize.variant3 PortTypeInvalid A.regionCodec Serialize.string portProblemCodec @@ -1591,8 +1591,8 @@ varKindCodec = possibleNamesCodec : Codec e PossibleNames possibleNamesCodec = Serialize.record PossibleNames - |> Serialize.field .locals (S.everySet compare Serialize.string) - |> Serialize.field .quals (S.assocListDict compare Serialize.string (S.everySet compare Serialize.string)) + |> Serialize.field .locals (S.everySet identity compare Serialize.string) + |> Serialize.field .quals (S.assocListDict identity compare Serialize.string (S.everySet identity compare Serialize.string)) |> Serialize.finishRecord diff --git a/src/Compiler/Reporting/Error/Import.elm b/src/Compiler/Reporting/Error/Import.elm index 337dd2960..1888437a6 100644 --- a/src/Compiler/Reporting/Error/Import.elm +++ b/src/Compiler/Reporting/Error/Import.elm @@ -24,7 +24,7 @@ import Serialize exposing (Codec) type Error - = Error A.Region ModuleName.Raw (EverySet ModuleName.Raw) Problem + = Error A.Region ModuleName.Raw (EverySet String ModuleName.Raw) Problem type Problem @@ -55,7 +55,7 @@ toReport source (Error region name unimportedModules problem) = D.indent 4 <| D.vcat <| List.map D.fromName (toSuggestions name unimportedModules) - , case Dict.get name Pkg.suggestions of + , case Dict.get identity name Pkg.suggestions of Nothing -> D.toSimpleHint "If it is not a typo, check the \"dependencies\" and \"source-directories\" of your elm.json to make sure all the packages you need are listed there!" @@ -172,10 +172,10 @@ toReport source (Error region name unimportedModules problem) = ) -toSuggestions : ModuleName.Raw -> EverySet ModuleName.Raw -> List ModuleName.Raw +toSuggestions : ModuleName.Raw -> EverySet String ModuleName.Raw -> List ModuleName.Raw toSuggestions name unimportedModules = List.take 4 <| - Suggest.sort name identity (EverySet.toList unimportedModules) + Suggest.sort name identity (EverySet.toList compare unimportedModules) @@ -212,5 +212,5 @@ errorCodec = (\errorCodecEncoder (Error region name unimportedModules problem) -> errorCodecEncoder region name unimportedModules problem ) - |> Serialize.variant4 Error A.regionCodec ModuleName.rawCodec (S.everySet compare ModuleName.rawCodec) problemCodec + |> Serialize.variant4 Error A.regionCodec ModuleName.rawCodec (S.everySet identity compare ModuleName.rawCodec) problemCodec |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Error/Type.elm b/src/Compiler/Reporting/Error/Type.elm index 4dc166290..3a9b5dfe5 100644 --- a/src/Compiler/Reporting/Error/Type.elm +++ b/src/Compiler/Reporting/Error/Type.elm @@ -61,7 +61,7 @@ type Context | CallArity MaybeName Int | CallArg MaybeName Index.ZeroBased | RecordAccess A.Region (Maybe Name) A.Region Name - | RecordUpdateKeys Name (Dict Name Can.FieldUpdate) + | RecordUpdateKeys Name (Dict String Name Can.FieldUpdate) | RecordUpdateValue Name | Destructure @@ -1253,7 +1253,7 @@ toExprReport source localizer exprRegion category tipe expected = ++ " record does not have a `" ++ field ++ "` field:" - , case Suggest.sort field Tuple.first (Dict.toList fields) of + , case Suggest.sort field Tuple.first (Dict.toList compare fields) of [] -> D.reflow "In fact, it is a record with NO fields!" @@ -1300,7 +1300,7 @@ toExprReport source localizer exprRegion category tipe expected = RecordUpdateKeys record expectedFields -> case T.iteratedDealias tipe of T.Record actualFields ext -> - case List.sortBy Tuple.first (Dict.toList (Dict.diff expectedFields actualFields)) of + case List.sortBy Tuple.first (Dict.toList compare (Dict.diff expectedFields actualFields)) of [] -> mismatch ( ( Nothing @@ -1331,7 +1331,7 @@ toExprReport source localizer exprRegion category tipe expected = ++ " record does not have a " ++ fStr ++ " field:" - , case Suggest.sort field Tuple.first (Dict.toList actualFields) of + , case Suggest.sort field Tuple.first (Dict.toList compare actualFields) of [] -> D.reflow <| "In fact, " ++ rStr ++ " is a record with NO fields!" @@ -2700,7 +2700,7 @@ contextCodec = (Serialize.maybe Serialize.string) A.regionCodec Serialize.string - |> Serialize.variant2 RecordUpdateKeys Serialize.string (S.assocListDict compare Serialize.string Can.fieldUpdateCodec) + |> Serialize.variant2 RecordUpdateKeys Serialize.string (S.assocListDict identity compare Serialize.string Can.fieldUpdateCodec) |> Serialize.variant1 RecordUpdateValue Serialize.string |> Serialize.variant0 Destructure |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Render/Code.elm b/src/Compiler/Reporting/Render/Code.elm index 33212baef..5ee933b4b 100644 --- a/src/Compiler/Reporting/Render/Code.elm +++ b/src/Compiler/Reporting/Render/Code.elm @@ -271,7 +271,7 @@ detectKeywords c rest = name = String.fromChar c ++ cs in - if EverySet.member name reservedWords then + if EverySet.member identity name reservedWords then Keyword name else @@ -285,7 +285,7 @@ isInner char = isSymbol : Char -> Bool isSymbol char = - EverySet.member (Char.toCode char) binopCharSet + EverySet.member identity (Char.toCode char) binopCharSet startsWithKeyword : String -> String -> Bool diff --git a/src/Compiler/Reporting/Render/Type/Localizer.elm b/src/Compiler/Reporting/Render/Type/Localizer.elm index 2604a03d7..ec2d33a03 100644 --- a/src/Compiler/Reporting/Render/Type/Localizer.elm +++ b/src/Compiler/Reporting/Render/Type/Localizer.elm @@ -25,7 +25,7 @@ import System.TypeCheck.IO as IO type Localizer - = Localizer (Dict Name Import) + = Localizer (Dict String Name Import) type alias Import = @@ -36,7 +36,7 @@ type alias Import = type Exposing = All - | Only (EverySet Name) + | Only (EverySet String Name) empty : Localizer @@ -55,7 +55,7 @@ toDoc localizer home name = toChars : Localizer -> IO.Canonical -> Name -> String toChars (Localizer localizer) ((IO.Canonical _ home) as moduleName) name = - case Dict.get home localizer of + case Dict.get identity home localizer of Nothing -> home ++ "." ++ name @@ -65,7 +65,7 @@ toChars (Localizer localizer) ((IO.Canonical _ home) as moduleName) name = name Only set -> - if EverySet.member name set then + if EverySet.member identity name set then name else if name == Name.list && moduleName == ModuleName.list then @@ -79,7 +79,7 @@ toChars (Localizer localizer) ((IO.Canonical _ home) as moduleName) name = -- FROM NAMES -fromNames : Dict Name a -> Localizer +fromNames : Dict String Name a -> Localizer fromNames names = Localizer (Dict.map (\_ _ -> { alias = Nothing, exposing_ = All }) names) @@ -91,7 +91,7 @@ fromNames names = fromModule : Src.Module -> Localizer fromModule ((Src.Module _ _ _ imports _ _ _ _ _) as modul) = Localizer <| - Dict.fromList compare <| + Dict.fromList identity <| (( Src.getName modul, { alias = Nothing, exposing_ = All } ) :: List.map toPair imports) @@ -112,14 +112,14 @@ toExposing exposing_ = Only (List.foldr addType EverySet.empty exposedList) -addType : Src.Exposed -> EverySet Name -> EverySet Name +addType : Src.Exposed -> EverySet String Name -> EverySet String Name addType exposed types = case exposed of Src.Lower _ -> types Src.Upper (A.At _ name) _ -> - EverySet.insert compare name types + EverySet.insert identity name types Src.Operator _ _ -> types @@ -135,7 +135,7 @@ localizerCodec = (\localizerCodecEncoder (Localizer localizer) -> localizerCodecEncoder localizer ) - |> Serialize.variant1 Localizer (S.assocListDict compare Serialize.string importCodec) + |> Serialize.variant1 Localizer (S.assocListDict identity compare Serialize.string importCodec) |> Serialize.finishCustomType @@ -159,5 +159,5 @@ exposingCodec = onlyEncoder set ) |> Serialize.variant0 All - |> Serialize.variant1 Only (S.everySet compare Serialize.string) + |> Serialize.variant1 Only (S.everySet identity compare Serialize.string) |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Result.elm b/src/Compiler/Reporting/Result.elm index 0f281a5ce..9d6aa54aa 100644 --- a/src/Compiler/Reporting/Result.elm +++ b/src/Compiler/Reporting/Result.elm @@ -142,15 +142,16 @@ traverse func = List.foldr (\a -> bind (\acc -> fmap (\b -> b :: acc) (func a))) (ok []) -mapTraverseWithKey : (k -> k -> Order) -> (k -> a -> RResult i w x b) -> Dict k a -> RResult i w x (Dict k b) -mapTraverseWithKey keyComparison f = - Dict.foldr (\k a -> bind (\c -> fmap (\va -> Dict.insert keyComparison k va c) (f k a))) +mapTraverseWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> RResult i w x b) -> Dict comparable k a -> RResult i w x (Dict comparable k b) +mapTraverseWithKey toComparable keyComparison f = + Dict.foldr keyComparison + (\k a -> bind (\c -> fmap (\va -> Dict.insert toComparable k va c) (f k a))) (pure Dict.empty) -traverseDict : (k -> k -> Order) -> (a -> RResult i w x b) -> Dict k a -> RResult i w x (Dict k b) -traverseDict keyComparison func = - Dict.foldr (\k a -> bind (\acc -> fmap (\b -> Dict.insert keyComparison k b acc) (func a))) (ok Dict.empty) +traverseDict : (k -> comparable) -> (k -> k -> Order) -> (a -> RResult i w x b) -> Dict comparable k a -> RResult i w x (Dict comparable k b) +traverseDict toComparable keyComparison func = + Dict.foldr keyComparison (\k a -> bind (\acc -> fmap (\b -> Dict.insert toComparable k b acc) (func a))) (ok Dict.empty) indexedTraverse : (Index.ZeroBased -> a -> RResult i w error b) -> List a -> RResult i w error (List b) diff --git a/src/Compiler/Serialize.elm b/src/Compiler/Serialize.elm index 0d4ee6878..088970289 100644 --- a/src/Compiler/Serialize.elm +++ b/src/Compiler/Serialize.elm @@ -12,16 +12,16 @@ import Data.Set as EverySet exposing (EverySet) import Serialize as S exposing (Codec) -assocListDict : (k -> k -> Order) -> Codec e k -> Codec e a -> Codec e (Dict k a) -assocListDict keyComparison keyCodec valueCodec = +assocListDict : (k -> comparable) -> (k -> k -> Order) -> Codec e k -> Codec e a -> Codec e (Dict comparable k a) +assocListDict toComparable keyComparison keyCodec valueCodec = S.list (S.tuple keyCodec valueCodec) - |> S.map (Dict.fromList keyComparison) Dict.toList + |> S.map (Dict.fromList toComparable) (Dict.toList keyComparison) -everySet : (a -> a -> Order) -> Codec e a -> Codec e (EverySet a) -everySet keyComparison codec = +everySet : (a -> comparable) -> (a -> a -> Order) -> Codec e a -> Codec e (EverySet comparable a) +everySet toComparable keyComparison codec = S.list codec - |> S.map (EverySet.fromList keyComparison) (List.reverse << EverySet.toList) + |> S.map (EverySet.fromList toComparable) (List.reverse << EverySet.toList keyComparison) nonempty : Codec e a -> Codec (S.Error e) (NE.Nonempty a) diff --git a/src/Compiler/Type/Constrain/Expression.elm b/src/Compiler/Type/Constrain/Expression.elm index 2d317dd73..32f0f902a 100644 --- a/src/Compiler/Type/Constrain/Expression.elm +++ b/src/Compiler/Type/Constrain/Expression.elm @@ -32,7 +32,7 @@ dictionary will hold variables for `a` and `b` -} type alias RTV = - Dict Name.Name Type + Dict String Name.Name Type constrain : RTV -> Can.Expr -> E.Expected Type -> IO Constraint @@ -144,7 +144,7 @@ constrain rtv (A.At region expression) expected = recordType : Type recordType = - RecordN (Dict.singleton field fieldType) extType + RecordN (Dict.singleton identity field fieldType) extType in Type.exists [ fieldVar, extVar ] (CEqual region (Accessor field) (FunN recordType fieldType) expected) ) @@ -168,7 +168,7 @@ constrain rtv (A.At region expression) expected = recordType : Type recordType = - RecordN (Dict.singleton field fieldType) extType + RecordN (Dict.singleton identity field fieldType) extType context : Context context = @@ -558,9 +558,9 @@ constrainCaseBranch rtv (Can.CaseBranch pattern expr) pExpect bExpect = -- CONSTRAIN RECORD -constrainRecord : RTV -> A.Region -> Dict Name.Name Can.Expr -> Expected Type -> IO Constraint +constrainRecord : RTV -> A.Region -> Dict String Name.Name Can.Expr -> Expected Type -> IO Constraint constrainRecord rtv region fields expected = - IO.traverseMap compare (constrainField rtv) fields + IO.traverseMap identity compare (constrainField rtv) fields |> IO.fmap (\dict -> let @@ -578,11 +578,11 @@ constrainRecord rtv region fields expected = vars : List IO.Variable vars = - Dict.foldr (\_ ( v, _, _ ) vs -> v :: vs) [] dict + Dict.foldr compare (\_ ( v, _, _ ) vs -> v :: vs) [] dict cons : List Constraint cons = - Dict.foldr (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] dict + Dict.foldr compare (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] dict in Type.exists vars (CAnd cons) ) @@ -610,12 +610,12 @@ constrainField rtv expr = -- CONSTRAIN RECORD UPDATE -constrainUpdate : RTV -> A.Region -> Name.Name -> Can.Expr -> Dict Name.Name Can.FieldUpdate -> Expected Type -> IO Constraint +constrainUpdate : RTV -> A.Region -> Name.Name -> Can.Expr -> Dict String Name.Name Can.FieldUpdate -> Expected Type -> IO Constraint constrainUpdate rtv region name expr fields expected = Type.mkFlexVar |> IO.bind (\extVar -> - IO.traverseMapWithKey compare (constrainUpdateField rtv region) fields + IO.traverseMapWithKey identity compare (constrainUpdateField rtv region) fields |> IO.bind (\fieldDict -> Type.mkFlexVar @@ -641,11 +641,11 @@ constrainUpdate rtv region name expr fields expected = vars : List IO.Variable vars = - Dict.foldr (\_ ( v, _, _ ) vs -> v :: vs) [ recordVar, extVar ] fieldDict + Dict.foldr compare (\_ ( v, _, _ ) vs -> v :: vs) [ recordVar, extVar ] fieldDict cons : List Constraint cons = - Dict.foldr (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] fieldDict + Dict.foldr compare (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] fieldDict in constrain rtv expr (FromContext region (RecordUpdateKeys name fields) recordType) |> IO.fmap (\con -> Type.exists vars (CAnd (fieldsCon :: con :: cons))) @@ -774,7 +774,7 @@ constrainShader region (Shader.Types attributes uniforms varyings) expected = ) -toShaderRecord : Dict Name.Name Shader.Type -> Type -> Type +toShaderRecord : Dict String Name.Name Shader.Type -> Type -> Type toShaderRecord types baseRecType = if Dict.isEmpty types then baseRecType @@ -850,7 +850,7 @@ constrainDef rtv def bodyCon = (\exprCon -> CLet [] vars - (Dict.singleton name (A.At region tipe)) + (Dict.singleton identity name (A.At region tipe)) (CLet [] pvars headers @@ -863,17 +863,17 @@ constrainDef rtv def bodyCon = Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> let - newNames : Dict Name () + newNames : Dict String Name () newNames = Dict.diff freeVars rtv in - IO.traverseMapWithKey compare (\n _ -> Type.nameToRigid n) newNames + IO.traverseMapWithKey identity compare (\n _ -> Type.nameToRigid n) newNames |> IO.bind (\newRigids -> let - newRtv : Dict Name Type + newRtv : Dict String Name Type newRtv = - Dict.union compare rtv (Dict.map (\_ -> VarN) newRigids) + Dict.union rtv (Dict.map (\_ -> VarN) newRigids) in constrainTypedArgs newRtv name typedArgs srcResultType |> IO.bind @@ -886,9 +886,9 @@ constrainDef rtv def bodyCon = constrain newRtv expr expected |> IO.fmap (\exprCon -> - CLet (Dict.values newRigids) + CLet (Dict.values compare newRigids) [] - (Dict.singleton name (A.At region tipe)) + (Dict.singleton identity name (A.At region tipe)) (CLet [] pvars headers @@ -906,7 +906,7 @@ constrainDef rtv def bodyCon = type Info - = Info (List IO.Variable) (List Constraint) (Dict Name (A.Located Type)) + = Info (List IO.Variable) (List Constraint) (Dict String Name (A.Located Type)) emptyInfo : Info @@ -960,23 +960,23 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo = recDefsHelp rtv otherDefs bodyCon rigidInfo <| Info newFlexVars (defCon :: flexCons) - (Dict.insert compare name (A.At region tipe) flexHeaders) + (Dict.insert identity name (A.At region tipe) flexHeaders) ) ) Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> let - newNames : Dict Name () + newNames : Dict String Name () newNames = Dict.diff freeVars rtv in - IO.traverseMapWithKey compare (\n _ -> Type.nameToRigid n) newNames + IO.traverseMapWithKey identity compare (\n _ -> Type.nameToRigid n) newNames |> IO.bind (\newRigids -> let - newRtv : Dict Name Type + newRtv : Dict String Name Type newRtv = - Dict.union compare rtv (Dict.map (\_ -> VarN) newRigids) + Dict.union rtv (Dict.map (\_ -> VarN) newRigids) in constrainTypedArgs newRtv name typedArgs srcResultType |> IO.bind @@ -1000,9 +1000,9 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo = otherDefs bodyCon (Info - (Dict.foldr (\_ -> (::)) rigidVars newRigids) - (CLet (Dict.values newRigids) [] Dict.empty defCon CTrue :: rigidCons) - (Dict.insert compare name (A.At region tipe) rigidHeaders) + (Dict.foldr compare (\_ -> (::)) rigidVars newRigids) + (CLet (Dict.values compare newRigids) [] Dict.empty defCon CTrue :: rigidCons) + (Dict.insert identity name (A.At region tipe) rigidHeaders) ) flexInfo ) @@ -1064,12 +1064,12 @@ type TypedArgs = TypedArgs Type Type Pattern.State -constrainTypedArgs : Dict Name.Name Type -> Name.Name -> List ( Can.Pattern, Can.Type ) -> Can.Type -> IO TypedArgs +constrainTypedArgs : Dict String Name.Name Type -> Name.Name -> List ( Can.Pattern, Can.Type ) -> Can.Type -> IO TypedArgs constrainTypedArgs rtv name args srcResultType = typedArgsHelp rtv name Index.first args srcResultType Pattern.emptyState -typedArgsHelp : Dict Name.Name Type -> Name.Name -> Index.ZeroBased -> List ( Can.Pattern, Can.Type ) -> Can.Type -> Pattern.State -> IO TypedArgs +typedArgsHelp : Dict String Name.Name Type -> Name.Name -> Index.ZeroBased -> List ( Can.Pattern, Can.Type ) -> Can.Type -> Pattern.State -> IO TypedArgs typedArgsHelp rtv name index args srcResultType state = case args of [] -> diff --git a/src/Compiler/Type/Constrain/Module.elm b/src/Compiler/Type/Constrain/Module.elm index b6497d327..f664c24a9 100644 --- a/src/Compiler/Type/Constrain/Module.elm +++ b/src/Compiler/Type/Constrain/Module.elm @@ -23,7 +23,7 @@ constrain (Can.Module home _ _ decls _ _ _ effects) = constrainDecls decls CSaveTheEnvironment Can.Ports ports -> - Dict.foldr letPort (constrainDecls decls CSaveTheEnvironment) ports + Dict.foldr compare letPort (constrainDecls decls CSaveTheEnvironment) ports Can.Manager r0 r1 r2 manager -> case manager of @@ -69,34 +69,34 @@ letPort : Name -> Can.Port -> IO Constraint -> IO Constraint letPort name port_ makeConstraint = case port_ of Can.Incoming { freeVars, func } -> - IO.traverseMapWithKey compare (\k _ -> nameToRigid k) freeVars + IO.traverseMapWithKey identity compare (\k _ -> nameToRigid k) freeVars |> IO.bind (\vars -> Instantiate.fromSrcType (Dict.map (\_ v -> VarN v) vars) func |> IO.bind (\tipe -> let - header : Dict Name (A.Located Type) + header : Dict String Name (A.Located Type) header = - Dict.singleton name (A.At A.zero tipe) + Dict.singleton identity name (A.At A.zero tipe) in - IO.fmap (CLet (Dict.values vars) [] header CTrue) makeConstraint + IO.fmap (CLet (Dict.values compare vars) [] header CTrue) makeConstraint ) ) Can.Outgoing { freeVars, func } -> - IO.traverseMapWithKey compare (\k _ -> nameToRigid k) freeVars + IO.traverseMapWithKey identity compare (\k _ -> nameToRigid k) freeVars |> IO.bind (\vars -> Instantiate.fromSrcType (Dict.map (\_ v -> VarN v) vars) func |> IO.bind (\tipe -> let - header : Dict Name (A.Located Type) + header : Dict String Name (A.Located Type) header = - Dict.singleton name (A.At A.zero tipe) + Dict.singleton identity name (A.At A.zero tipe) in - IO.fmap (CLet (Dict.values vars) [] header CTrue) makeConstraint + IO.fmap (CLet (Dict.values compare vars) [] header CTrue) makeConstraint ) ) @@ -119,9 +119,9 @@ letCmd home tipe constraint = cmdType = FunN (AppN home tipe [ msg ]) (AppN ModuleName.cmd Name.cmd [ msg ]) - header : Dict Name (A.Located Type) + header : Dict String Name (A.Located Type) header = - Dict.singleton "command" (A.At A.zero cmdType) + Dict.singleton identity "command" (A.At A.zero cmdType) in CLet [ msgVar ] [] header CTrue constraint ) @@ -141,9 +141,9 @@ letSub home tipe constraint = subType = FunN (AppN home tipe [ msg ]) (AppN ModuleName.sub Name.sub [ msg ]) - header : Dict Name (A.Located Type) + header : Dict String Name (A.Located Type) header = - Dict.singleton "subscription" (A.At A.zero subType) + Dict.singleton identity "subscription" (A.At A.zero subType) in CLet [ msgVar ] [] header CTrue constraint ) diff --git a/src/Compiler/Type/Constrain/Pattern.elm b/src/Compiler/Type/Constrain/Pattern.elm index 43f583c43..257e2818d 100644 --- a/src/Compiler/Type/Constrain/Pattern.elm +++ b/src/Compiler/Type/Constrain/Pattern.elm @@ -28,7 +28,7 @@ type State type alias Header = - Dict Name.Name (A.Located Type) + Dict String Name.Name (A.Located Type) add : Can.Pattern -> E.PExpected Type -> State -> IO State @@ -136,9 +136,9 @@ add (A.At region pattern) expectation state = |> IO.fmap (\fieldVars -> let - fieldTypes : Dict Name.Name Type + fieldTypes : Dict String Name.Name Type fieldTypes = - Dict.fromList compare (List.map (Tuple.mapSecond Type.VarN) fieldVars) + Dict.fromList identity (List.map (Tuple.mapSecond Type.VarN) fieldVars) recordType : Type recordType = @@ -152,7 +152,7 @@ add (A.At region pattern) expectation state = Type.CPattern region E.PRecord recordType expectation in State - (Dict.union compare headers (Dict.map (\_ v -> A.At region v) fieldTypes)) + (Dict.union headers (Dict.map (\_ v -> A.At region v) fieldTypes)) (List.map Tuple.second fieldVars ++ extVar :: vars) (recordCon :: revCons) ) @@ -219,9 +219,9 @@ addToHeaders region name expectation (State headers vars revCons) = tipe = getType expectation - newHeaders : Dict Name.Name (A.Located Type) + newHeaders : Dict String Name.Name (A.Located Type) newHeaders = - Dict.insert compare name (A.At region tipe) headers + Dict.insert identity name (A.At region tipe) headers in State newHeaders vars revCons @@ -330,9 +330,9 @@ addCtor region home typeName typeVarNames ctorName args expectation state = typePairs = List.map (Tuple.mapSecond Type.VarN) varPairs - freeVarDict : Dict Name.Name Type + freeVarDict : Dict String Name.Name Type freeVarDict = - Dict.fromList compare typePairs + Dict.fromList identity typePairs in IO.foldM (addCtorArg region ctorName freeVarDict) state args |> IO.bind @@ -354,7 +354,7 @@ addCtor region home typeName typeVarNames ctorName args expectation state = ) -addCtorArg : A.Region -> Name.Name -> Dict Name.Name Type -> State -> Can.PatternCtorArg -> IO State +addCtorArg : A.Region -> Name.Name -> Dict String Name.Name Type -> State -> Can.PatternCtorArg -> IO State addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) = Instantiate.fromSrcType freeVarDict srcType |> IO.bind diff --git a/src/Compiler/Type/Error.elm b/src/Compiler/Type/Error.elm index 566a6df22..2f2bfdf8a 100644 --- a/src/Compiler/Type/Error.elm +++ b/src/Compiler/Type/Error.elm @@ -42,7 +42,7 @@ type Type | RigidVar Name | RigidSuper Super Name | Type IO.Canonical Name (List Type) - | Record (Dict Name Type) Extension + | Record (Dict String Name Type) Extension | Unit | Tuple Type Type (Maybe Type) | Alias IO.Canonical Name (List ( Name, Type )) Type @@ -130,9 +130,9 @@ aliasToDoc localizer ctx home name args = (List.map (toDoc localizer RT.App << Tuple.second) args) -fieldsToDocs : L.Localizer -> Dict Name Type -> List ( D.Doc, D.Doc ) +fieldsToDocs : L.Localizer -> Dict String Name Type -> List ( D.Doc, D.Doc ) fieldsToDocs localizer fields = - Dict.foldr (addField localizer) [] fields + Dict.foldr compare (addField localizer) [] fields addField : L.Localizer -> Name -> Type -> List ( D.Doc, D.Doc ) -> List ( D.Doc, D.Doc ) @@ -644,7 +644,7 @@ diffAliasedRecord localizer t1 t2 = -- RECORD DIFFS -diffRecord : L.Localizer -> Dict Name Type -> Extension -> Dict Name Type -> Extension -> Diff D.Doc +diffRecord : L.Localizer -> Dict String Name Type -> Extension -> Dict String Name Type -> Extension -> Diff D.Doc diffRecord localizer fields1 ext1 fields2 ext2 = let toUnknownDocs : Name -> Type -> ( D.Doc, D.Doc ) @@ -655,42 +655,43 @@ diffRecord localizer fields1 ext1 fields2 ext2 = toOverlapDocs field t1 t2 = fmapDiff (Tuple.pair (D.fromName field)) <| toDiff localizer RT.None t1 t2 - left : Dict Name ( D.Doc, D.Doc ) + left : Dict String Name ( D.Doc, D.Doc ) left = Dict.map toUnknownDocs (Dict.diff fields1 fields2) - right : Dict Name ( D.Doc, D.Doc ) + right : Dict String Name ( D.Doc, D.Doc ) right = Dict.map toUnknownDocs (Dict.diff fields2 fields1) fieldsDiff : Diff (List ( D.Doc, D.Doc )) fieldsDiff = let - fieldsDiffDict : Diff (Dict Name ( D.Doc, D.Doc )) + fieldsDiffDict : Diff (Dict String Name ( D.Doc, D.Doc )) fieldsDiffDict = let - both : Dict Name (Diff ( D.Doc, D.Doc )) + both : Dict String Name (Diff ( D.Doc, D.Doc )) both = - Dict.merge (\_ _ acc -> acc) - (\field t1 t2 acc -> Dict.insert compare field (toOverlapDocs field t1 t2) acc) + Dict.merge compare + (\_ _ acc -> acc) + (\field t1 t2 acc -> Dict.insert identity field (toOverlapDocs field t1 t2) acc) (\_ _ acc -> acc) fields1 fields2 Dict.empty - sequenceA : Dict Name (Diff ( D.Doc, D.Doc )) -> Diff (Dict Name ( D.Doc, D.Doc )) + sequenceA : Dict String Name (Diff ( D.Doc, D.Doc )) -> Diff (Dict String Name ( D.Doc, D.Doc )) sequenceA = - Dict.foldr (\k x acc -> applyDiff acc (fmapDiff (Dict.insert compare k) x)) (pureDiff Dict.empty) + Dict.foldr compare (\k x acc -> applyDiff acc (fmapDiff (Dict.insert identity k) x)) (pureDiff Dict.empty) in if Dict.isEmpty left && Dict.isEmpty right then sequenceA both else - liftA2 (Dict.union compare) + liftA2 Dict.union (sequenceA both) (Diff left right (Different Bag.empty)) in - fmapDiff Dict.values fieldsDiffDict + fmapDiff (Dict.values compare) fieldsDiffDict (Diff doc1 doc2 status) = fieldsDiff @@ -704,32 +705,32 @@ diffRecord localizer fields1 ext1 fields2 ext2 = let minView : Maybe ( Name, ( D.Doc, D.Doc ) ) minView = - Dict.toList left + Dict.toList compare left |> List.sortBy Tuple.first |> List.head in case minView of Just ( f, _ ) -> - Different (Bag.one (FieldTypo f (Dict.keys fields2))) + Different (Bag.one (FieldTypo f (Dict.keys compare fields2))) Nothing -> if Dict.isEmpty right then Similar else - Different (Bag.one (FieldsMissing (Dict.keys right))) + Different (Bag.one (FieldsMissing (Dict.keys compare right))) ( False, True ) -> let minView : Maybe ( Name, ( D.Doc, D.Doc ) ) minView = - Dict.toList left + Dict.toList compare left |> List.sortBy Tuple.first |> List.head in case minView of Just ( f, _ ) -> - Different (Bag.one (FieldTypo f (Dict.keys fields2))) + Different (Bag.one (FieldTypo f (Dict.keys compare fields2))) Nothing -> Similar @@ -738,13 +739,13 @@ diffRecord localizer fields1 ext1 fields2 ext2 = let minView : Maybe ( Name, ( D.Doc, D.Doc ) ) minView = - Dict.toList right + Dict.toList compare right |> List.sortBy Tuple.first |> List.head in case minView of Just ( f, _ ) -> - Different (Bag.one (FieldTypo f (Dict.keys fields1))) + Different (Bag.one (FieldTypo f (Dict.keys compare fields1))) Nothing -> Similar @@ -887,7 +888,7 @@ typeCodec = ModuleName.canonicalCodec Serialize.string (Serialize.list (Serialize.lazy (\() -> typeCodec))) - |> Serialize.variant2 Record (S.assocListDict compare Serialize.string (Serialize.lazy (\() -> typeCodec))) extensionCodec + |> Serialize.variant2 Record (S.assocListDict identity compare Serialize.string (Serialize.lazy (\() -> typeCodec))) extensionCodec |> Serialize.variant0 Unit |> Serialize.variant3 Tuple diff --git a/src/Compiler/Type/Instantiate.elm b/src/Compiler/Type/Instantiate.elm index 83d07273d..acd485c49 100644 --- a/src/Compiler/Type/Instantiate.elm +++ b/src/Compiler/Type/Instantiate.elm @@ -16,7 +16,7 @@ import Utils.Main as Utils type alias FreeVars = - Dict Name Type + Dict String Name Type @@ -32,7 +32,7 @@ fromSrcType freeVars sourceType = |> IO.apply (fromSrcType freeVars result) Can.TVar name -> - IO.pure (Utils.find name freeVars) + IO.pure (Utils.find identity name freeVars) Can.TType home name args -> IO.fmap (AppN home name) @@ -48,7 +48,7 @@ fromSrcType freeVars sourceType = fromSrcType freeVars realType Can.Holey realType -> - fromSrcType (Dict.fromList compare targs) realType + fromSrcType (Dict.fromList identity targs) realType ) ) @@ -63,17 +63,17 @@ fromSrcType freeVars sourceType = Can.TRecord fields maybeExt -> IO.pure RecordN - |> IO.apply (IO.traverseMap compare (fromSrcFieldType freeVars) fields) + |> IO.apply (IO.traverseMap identity compare (fromSrcFieldType freeVars) fields) |> IO.apply (case maybeExt of Nothing -> IO.pure EmptyRecordN Just ext -> - IO.pure (Utils.find ext freeVars) + IO.pure (Utils.find identity ext freeVars) ) -fromSrcFieldType : Dict Name Type -> Can.FieldType -> IO Type +fromSrcFieldType : Dict String Name Type -> Can.FieldType -> IO Type fromSrcFieldType freeVars (Can.FieldType _ tipe) = fromSrcType freeVars tipe diff --git a/src/Compiler/Type/Occurs.elm b/src/Compiler/Type/Occurs.elm index a39825a25..10af7f803 100644 --- a/src/Compiler/Type/Occurs.elm +++ b/src/Compiler/Type/Occurs.elm @@ -55,7 +55,7 @@ occursHelp seen var foundCycle = IO.Record1 fields ext -> IO.bind (occursHelp newSeen ext) <| - IO.foldrM (occursHelp newSeen) foundCycle (Dict.values fields) + IO.foldrM (occursHelp newSeen) foundCycle (Dict.values compare fields) IO.Unit1 -> IO.pure foundCycle diff --git a/src/Compiler/Type/Solve.elm b/src/Compiler/Type/Solve.elm index 0b4841e91..114775aa2 100644 --- a/src/Compiler/Type/Solve.elm +++ b/src/Compiler/Type/Solve.elm @@ -27,7 +27,7 @@ import Utils.Main as Utils -- RUN SOLVER -run : Constraint -> IO (Result (NE.Nonempty Error.Error) (Dict Name.Name Can.Annotation)) +run : Constraint -> IO (Result (NE.Nonempty Error.Error) (Dict String Name.Name Can.Annotation)) run constraint = MVector.replicate 8 [] |> IO.bind @@ -37,7 +37,7 @@ run constraint = (\(State env _ errors) -> case errors of [] -> - IO.traverseMap compare Type.toAnnotation env + IO.traverseMap identity compare Type.toAnnotation env |> IO.fmap Ok e :: es -> @@ -56,7 +56,7 @@ emptyState = type alias Env = - Dict Name.Name Variable + Dict String Name.Name Variable type alias Pools = @@ -104,7 +104,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = ) CLocal region name expectation -> - makeCopy rank pools (Utils.find name env) + makeCopy rank pools (Utils.find identity name env) |> IO.bind (\actual -> expectedToVariable rank pools expectation @@ -197,18 +197,18 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = solve env rank pools state headerCon |> IO.bind (\state1 -> - IO.traverseMap compare (A.traverse (typeToVariable rank pools)) header + IO.traverseMap identity compare (A.traverse (typeToVariable rank pools)) header |> IO.bind (\locals -> let newEnv : Env newEnv = - Dict.union compare env (Dict.map (\_ -> A.toValue) locals) + Dict.union env (Dict.map (\_ -> A.toValue) locals) in solve newEnv rank pools state1 subCon |> IO.bind (\state2 -> - IO.foldM occurs state2 (Dict.toList locals) + IO.foldM occurs state2 (Dict.toList compare locals) ) ) ) @@ -249,7 +249,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = |> IO.bind (\_ -> -- run solver in next pool - IO.traverseMap compare (A.traverse (typeToVariable nextRank nextPools)) header + IO.traverseMap identity compare (A.traverse (typeToVariable nextRank nextPools)) header |> IO.bind (\locals -> solve env nextRank nextPools state headerCon @@ -282,7 +282,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = let newEnv : Env newEnv = - Dict.union compare env (Dict.map (\_ -> A.toValue) locals) + Dict.union env (Dict.map (\_ -> A.toValue) locals) tempState : State tempState = @@ -291,7 +291,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = solve newEnv rank nextPools tempState subCon |> IO.bind (\newState -> - IO.foldM occurs newState (Dict.toList locals) + IO.foldM occurs newState (Dict.toList compare locals) ) ) ) @@ -577,7 +577,7 @@ adjustRankContent youngMark visitMark groupRank content = go extension |> IO.bind (\extRank -> - IO.foldMDict (\rank field -> IO.fmap (max rank) (go field)) extRank fields + IO.foldMDict compare (\rank field -> IO.fmap (max rank) (go field)) extRank fields ) IO.Unit1 -> @@ -648,7 +648,7 @@ typeToVariable rank pools tipe = -- -typeToVar : Int -> Pools -> Dict Name.Name Variable -> Type -> IO Variable +typeToVar : Int -> Pools -> Dict String Name.Name Variable -> Type -> IO Variable typeToVar rank pools aliasDict tipe = let go : Type -> IO Variable @@ -681,7 +681,7 @@ typeToVar rank pools aliasDict tipe = IO.traverseList (IO.traverseTuple go) args |> IO.bind (\argVars -> - typeToVar rank pools (Dict.fromList compare argVars) aliasType + typeToVar rank pools (Dict.fromList identity argVars) aliasType |> IO.bind (\aliasVar -> register rank pools (IO.Alias home name argVars aliasVar) @@ -689,10 +689,10 @@ typeToVar rank pools aliasDict tipe = ) Type.PlaceHolder name -> - IO.pure (Utils.find name aliasDict) + IO.pure (Utils.find identity name aliasDict) Type.RecordN fields ext -> - IO.traverseMap compare go fields + IO.traverseMap identity compare go fields |> IO.bind (\fieldVars -> go ext @@ -748,7 +748,7 @@ unit1 = -- SOURCE TYPE TO VARIABLE -srcTypeToVariable : Int -> Pools -> Dict Name.Name () -> Can.Type -> IO Variable +srcTypeToVariable : Int -> Pools -> Dict String Name.Name () -> Can.Type -> IO Variable srcTypeToVariable rank pools freeVars srcType = let nameToContent : Name.Name -> Content @@ -772,15 +772,15 @@ srcTypeToVariable rank pools freeVars srcType = makeVar name _ = UF.fresh (Descriptor (nameToContent name) rank Type.noMark Nothing) in - IO.traverseMapWithKey compare makeVar freeVars + IO.traverseMapWithKey identity compare makeVar freeVars |> IO.bind (\flexVars -> - MVector.modify pools (\a -> Dict.values flexVars ++ a) rank + MVector.modify pools (\a -> Dict.values compare flexVars ++ a) rank |> IO.bind (\_ -> srcTypeToVar rank pools flexVars srcType) ) -srcTypeToVar : Int -> Pools -> Dict Name.Name Variable -> Can.Type -> IO Variable +srcTypeToVar : Int -> Pools -> Dict String Name.Name Variable -> Can.Type -> IO Variable srcTypeToVar rank pools flexVars srcType = let go : Can.Type -> IO Variable @@ -800,7 +800,7 @@ srcTypeToVar rank pools flexVars srcType = ) Can.TVar name -> - IO.pure (Utils.find name flexVars) + IO.pure (Utils.find identity name flexVars) Can.TType home name args -> IO.traverseList go args @@ -810,7 +810,7 @@ srcTypeToVar rank pools flexVars srcType = ) Can.TRecord fields maybeExt -> - IO.traverseMap compare (srcFieldTypeToVar rank pools flexVars) fields + IO.traverseMap identity compare (srcFieldTypeToVar rank pools flexVars) fields |> IO.bind (\fieldVars -> (case maybeExt of @@ -818,7 +818,7 @@ srcTypeToVar rank pools flexVars srcType = register rank pools emptyRecord1 Just ext -> - IO.pure (Utils.find ext flexVars) + IO.pure (Utils.find identity ext flexVars) ) |> IO.bind (\extVar -> @@ -850,7 +850,7 @@ srcTypeToVar rank pools flexVars srcType = (\argVars -> (case aliasType of Can.Holey tipe -> - srcTypeToVar rank pools (Dict.fromList compare argVars) tipe + srcTypeToVar rank pools (Dict.fromList identity argVars) tipe Can.Filled tipe -> go tipe @@ -862,7 +862,7 @@ srcTypeToVar rank pools flexVars srcType = ) -srcFieldTypeToVar : Int -> Pools -> Dict Name.Name Variable -> Can.FieldType -> IO Variable +srcFieldTypeToVar : Int -> Pools -> Dict String Name.Name Variable -> Can.FieldType -> IO Variable srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) = srcTypeToVar rank pools flexVars srcTipe @@ -1006,7 +1006,7 @@ restoreContent content = IO.pure () IO.Record1 fields ext -> - IO.mapM_ restore (Dict.values fields) + IO.mapM_ restore (Dict.values compare fields) |> IO.bind (\_ -> restore ext) IO.Unit1 -> @@ -1053,7 +1053,7 @@ traverseFlatType f flatType = IO.Record1 fields ext -> IO.pure IO.Record1 - |> IO.apply (IO.traverseMap compare f fields) + |> IO.apply (IO.traverseMap identity compare f fields) |> IO.apply (f ext) IO.Unit1 -> diff --git a/src/Compiler/Type/Type.elm b/src/Compiler/Type/Type.elm index f4d76aa83..f421d3f81 100644 --- a/src/Compiler/Type/Type.elm +++ b/src/Compiler/Type/Type.elm @@ -55,7 +55,7 @@ type Constraint | CForeign A.Region Name Can.Annotation (E.Expected Type) | CPattern A.Region E.PCategory Type (E.PExpected Type) | CAnd (List Constraint) - | CLet (List Variable) (List Variable) (Dict Name (A.Located Type)) Constraint Constraint + | CLet (List Variable) (List Variable) (Dict String Name (A.Located Type)) Constraint Constraint exists : List Variable -> Constraint -> Constraint @@ -74,7 +74,7 @@ type Type | AppN IO.Canonical Name (List Type) | FunN Type Type | EmptyRecordN - | RecordN (Dict Name Type) Type + | RecordN (Dict String Name Type) Type | UnitN | TupleN Type Type (Maybe Type) @@ -372,7 +372,7 @@ termToCanType term = State.pure (Can.TRecord Dict.empty Nothing) Record1 fields extension -> - State.traverseMap compare fieldToCanType fields + State.traverseMap compare identity fieldToCanType fields |> State.bind (\canFields -> variableToCanType extension @@ -381,7 +381,7 @@ termToCanType term = (\canExt -> case canExt of Can.TRecord subFields subExt -> - Can.TRecord (Dict.union compare subFields canFields) subExt + Can.TRecord (Dict.union subFields canFields) subExt Can.TVar name -> Can.TRecord canFields (Just name) @@ -548,7 +548,7 @@ termToErrorType term = State.pure (ET.Record Dict.empty ET.Closed) Record1 fields extension -> - State.traverseMap compare variableToErrorType fields + State.traverseMap compare identity variableToErrorType fields |> State.bind (\errFields -> variableToErrorType extension @@ -557,7 +557,7 @@ termToErrorType term = (\errExt -> case errExt of ET.Record subFields subExt -> - ET.Record (Dict.union compare subFields errFields) subExt + ET.Record (Dict.union subFields errFields) subExt ET.FlexVar ext -> ET.Record errFields (ET.FlexOpen ext) @@ -585,10 +585,10 @@ termToErrorType term = type NameState - = NameState (Dict Name ()) Int Int Int Int Int + = NameState (Dict String Name ()) Int Int Int Int Int -makeNameState : Dict Name Variable -> NameState +makeNameState : Dict String Name Variable -> NameState makeNameState taken = NameState (Dict.map (\_ _ -> ()) taken) 0 0 0 0 0 @@ -618,18 +618,18 @@ getFreshVarName = ) -getFreshVarNameHelp : Int -> Dict Name () -> ( Name, Int, Dict Name () ) +getFreshVarNameHelp : Int -> Dict String Name () -> ( Name, Int, Dict String Name () ) getFreshVarNameHelp index taken = let name : Name name = Name.fromTypeVariableScheme index in - if Dict.member name taken then + if Dict.member identity name taken then getFreshVarNameHelp (index + 1) taken else - ( name, index + 1, Dict.insert compare name () taken ) + ( name, index + 1, Dict.insert identity name () taken ) @@ -689,25 +689,25 @@ getFreshSuper prefix getter setter = ) -getFreshSuperHelp : Name -> Int -> Dict Name () -> ( Name, Int, Dict Name () ) +getFreshSuperHelp : Name -> Int -> Dict String Name () -> ( Name, Int, Dict String Name () ) getFreshSuperHelp prefix index taken = let name : Name name = Name.fromTypeVariable prefix index in - if Dict.member name taken then + if Dict.member identity name taken then getFreshSuperHelp prefix (index + 1) taken else - ( name, index + 1, Dict.insert compare name () taken ) + ( name, index + 1, Dict.insert identity name () taken ) -- GET ALL VARIABLE NAMES -getVarNames : Variable -> Dict Name Variable -> IO (Dict Name Variable) +getVarNames : Variable -> Dict String Name Variable -> IO (Dict String Name Variable) getVarNames var takenNames = UF.get var |> IO.bind @@ -761,7 +761,7 @@ getVarNames var takenNames = Record1 fields extension -> IO.bind (getVarNames extension) - (IO.foldrM getVarNames takenNames (Dict.values fields)) + (IO.foldrM getVarNames takenNames (Dict.values compare fields)) Unit1 -> IO.pure takenNames @@ -781,14 +781,14 @@ getVarNames var takenNames = -- REGISTER NAME / RENAME DUPLICATES -addName : Int -> Name -> Variable -> (Name -> Content) -> Dict Name Variable -> IO (Dict Name Variable) +addName : Int -> Name -> Variable -> (Name -> Content) -> Dict String Name Variable -> IO (Dict String Name Variable) addName index givenName var makeContent takenNames = let indexedName : Name indexedName = Name.fromTypeVariable givenName index in - case Dict.get indexedName takenNames of + case Dict.get identity indexedName takenNames of Nothing -> (if indexedName == givenName then IO.pure () @@ -799,7 +799,7 @@ addName index givenName var makeContent takenNames = Descriptor (makeContent indexedName) rank mark copy ) ) - |> IO.fmap (\_ -> Dict.insert compare indexedName var takenNames) + |> IO.fmap (\_ -> Dict.insert identity indexedName var takenNames) Just otherVar -> UF.equivalent var otherVar diff --git a/src/Compiler/Type/Unify.elm b/src/Compiler/Type/Unify.elm index df2d5d8dd..b08f8051d 100644 --- a/src/Compiler/Type/Unify.elm +++ b/src/Compiler/Type/Unify.elm @@ -748,15 +748,15 @@ unifyArgs vars args1 args2 = unifyRecord : Context -> RecordStructure -> RecordStructure -> Unify () unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) = let - sharedFields : Dict Name.Name ( IO.Variable, IO.Variable ) + sharedFields : Dict String Name.Name ( IO.Variable, IO.Variable ) sharedFields = - Utils.mapIntersectionWith compare Tuple.pair fields1 fields2 + Utils.mapIntersectionWith identity compare Tuple.pair fields1 fields2 - uniqueFields1 : Dict Name.Name IO.Variable + uniqueFields1 : Dict String Name.Name IO.Variable uniqueFields1 = Dict.diff fields1 fields2 - uniqueFields2 : Dict Name.Name IO.Variable + uniqueFields2 : Dict String Name.Name IO.Variable uniqueFields2 = Dict.diff fields2 fields1 in @@ -783,9 +783,9 @@ unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2 else let - otherFields : Dict Name.Name IO.Variable + otherFields : Dict String Name.Name IO.Variable otherFields = - Dict.union compare uniqueFields1 uniqueFields2 + Dict.union uniqueFields1 uniqueFields2 in fresh context Type.unnamedFlexVar |> bind @@ -804,29 +804,29 @@ unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2 ) -unifySharedFields : Context -> Dict Name.Name ( IO.Variable, IO.Variable ) -> Dict Name.Name IO.Variable -> IO.Variable -> Unify () +unifySharedFields : Context -> Dict String Name.Name ( IO.Variable, IO.Variable ) -> Dict String Name.Name IO.Variable -> IO.Variable -> Unify () unifySharedFields context sharedFields otherFields ext = - traverseMaybe compare unifyField sharedFields + traverseMaybe identity compare unifyField sharedFields |> bind (\matchingFields -> if Dict.size sharedFields == Dict.size matchingFields then - merge context (IO.Structure (IO.Record1 (Dict.union compare matchingFields otherFields) ext)) + merge context (IO.Structure (IO.Record1 (Dict.union matchingFields otherFields) ext)) else mismatch ) -traverseMaybe : (a -> a -> Order) -> (a -> b -> Unify (Maybe c)) -> Dict a b -> Unify (Dict a c) -traverseMaybe keyComparison func = - Dict.foldl +traverseMaybe : (a -> comparable) -> (a -> a -> Order) -> (a -> b -> Unify (Maybe c)) -> Dict comparable a b -> Unify (Dict comparable a c) +traverseMaybe toComparable keyComparison func = + Dict.foldl keyComparison (\a b -> bind (\acc -> fmap (\maybeC -> maybeC - |> Maybe.map (\c -> Dict.insert keyComparison a c acc) + |> Maybe.map (\c -> Dict.insert toComparable a c acc) |> Maybe.withDefault acc ) (func a b) @@ -859,17 +859,17 @@ unifyField _ ( actual, expected ) = type RecordStructure - = RecordStructure (Dict Name.Name IO.Variable) IO.Variable + = RecordStructure (Dict String Name.Name IO.Variable) IO.Variable -gatherFields : Dict Name.Name IO.Variable -> IO.Variable -> IO RecordStructure +gatherFields : Dict String Name.Name IO.Variable -> IO.Variable -> IO RecordStructure gatherFields fields variable = UF.get variable |> IO.bind (\(IO.Descriptor content _ _ _) -> case content of IO.Structure (IO.Record1 subFields subExt) -> - gatherFields (Dict.union compare fields subFields) subExt + gatherFields (Dict.union fields subFields) subExt IO.Alias _ _ _ var -> -- TODO may be dropping useful alias info here diff --git a/src/Control/Monad/State/TypeCheck/Strict.elm b/src/Control/Monad/State/TypeCheck/Strict.elm index adb271f66..103033d36 100644 --- a/src/Control/Monad/State/TypeCheck/Strict.elm +++ b/src/Control/Monad/State/TypeCheck/Strict.elm @@ -111,14 +111,15 @@ traverseTuple f ( a, b ) = fmap (Tuple.pair a) (f b) -traverseMap : (k -> k -> Order) -> (a -> StateT s b) -> Dict k a -> StateT s (Dict k b) -traverseMap keyComparison f = - traverseMapWithKey keyComparison (\_ -> f) +traverseMap : (k -> k -> Order) -> (k -> comparable) -> (a -> StateT s b) -> Dict comparable k a -> StateT s (Dict comparable k b) +traverseMap keyComparison toComparable f = + traverseMapWithKey keyComparison toComparable (\_ -> f) -traverseMapWithKey : (k -> k -> Order) -> (k -> a -> StateT s b) -> Dict k a -> StateT s (Dict k b) -traverseMapWithKey keyComparison f = - Dict.foldl (\k a -> bind (\c -> fmap (\va -> Dict.insert keyComparison k va c) (f k a))) +traverseMapWithKey : (k -> k -> Order) -> (k -> comparable) -> (k -> a -> StateT s b) -> Dict comparable k a -> StateT s (Dict comparable k b) +traverseMapWithKey keyComparison toComparable f = + Dict.foldl keyComparison + (\k a -> bind (\c -> fmap (\va -> Dict.insert toComparable k va c) (f k a))) (pure Dict.empty) diff --git a/src/Data/Map.elm b/src/Data/Map.elm index e560deb46..af2e0f30e 100644 --- a/src/Data/Map.elm +++ b/src/Data/Map.elm @@ -52,6 +52,8 @@ for more information about this topic. -} +import Dict + {-| A dictionary of keys and values. So a `Dict String User` is a dictionary that lets you look up a `String` (such as user names) and find the associated @@ -74,15 +76,15 @@ that lets you look up a `String` (such as user names) and find the associated } -} -type Dict a b - = D (List ( a, b )) +type Dict c k v + = D (Dict.Dict c ( k, v )) {-| Create an empty dictionary. -} -empty : Dict k v +empty : Dict c k v empty = - D [] + D Dict.empty {-| Get the value associated with a key. If the key is not found, return @@ -106,30 +108,17 @@ dictionary. --> Nothing -} -get : k -> Dict k v -> Maybe v -get targetKey (D alist) = - case alist of - [] -> - Nothing - - ( key, value ) :: rest -> - if key == targetKey then - Just value - - else - get targetKey (D rest) +get : (k -> comparable) -> k -> Dict comparable k v -> Maybe v +get toComparable targetKey (D dict) = + Dict.get (toComparable targetKey) dict + |> Maybe.map Tuple.second {-| Determine if a key is in a dictionary. -} -member : k -> Dict k v -> Bool -member targetKey dict = - case get targetKey dict of - Just _ -> - True - - Nothing -> - False +member : (k -> comparable) -> k -> Dict comparable k v -> Bool +member toComparable targetKey (D dict) = + Dict.member (toComparable targetKey) dict {-| Determine the number of key-value pairs in the dictionary. @@ -141,9 +130,9 @@ member targetKey dict = --> 1 -} -size : Dict k v -> Int -size (D alist) = - List.length alist +size : Dict c k v -> Int +size (D dict) = + Dict.size dict {-| Determine if a dictionary is empty. @@ -152,9 +141,9 @@ size (D alist) = --> True -} -isEmpty : Dict k v -> Bool -isEmpty dict = - dict == D [] +isEmpty : Dict c k v -> Bool +isEmpty (D dict) = + Dict.isEmpty dict {-| Compare two dictionaries for equality, ignoring insertion order. @@ -170,9 +159,9 @@ dictionaries from this module since association lists have no canonical form. --> True -} -eq : Dict k v -> Dict k v -> Bool +eq : Dict comparable k v -> Dict comparable k v -> Bool eq leftDict rightDict = - merge + merge (\_ _ -> EQ) (\_ _ _ -> False) (\_ a b result -> result && a == b) (\_ _ _ -> False) @@ -184,24 +173,17 @@ eq leftDict rightDict = {-| Insert a key-value pair into a dictionary. Replaces value when there is a collision. -} -insert : (k -> k -> Order) -> k -> v -> Dict k v -> Dict k v -insert keyComparison key value dict = - let - (D alteredAlist) = - remove key dict - in - D - (List.sortWith (\( ka, _ ) ( kb, _ ) -> keyComparison ka kb) - (( key, value ) :: alteredAlist) - ) +insert : (k -> comparable) -> k -> v -> Dict comparable k v -> Dict comparable k v +insert toComparable key value (D dict) = + D (Dict.insert (toComparable key) ( key, value ) dict) {-| Remove a key-value pair from a dictionary. If the key is not found, no changes are made. -} -remove : k -> Dict k v -> Dict k v -remove targetKey (D alist) = - D (List.filter (\( key, _ ) -> key /= targetKey) alist) +remove : (k -> comparable) -> k -> Dict comparable k v -> Dict comparable k v +remove toComparable targetKey (D dict) = + D (Dict.remove (toComparable targetKey) dict) {-| Update the value of a dictionary for a specific key with a given function. @@ -212,46 +194,23 @@ is in the insertion order. (If you do want to change the insertion order, consider using `get` in conjunction with `insert` instead.) -} -update : (k -> k -> Order) -> k -> (Maybe v -> Maybe v) -> Dict k v -> Dict k v -update keyComparison targetKey alter ((D alist) as dict) = - let - maybeValue : Maybe v - maybeValue = - get targetKey dict - in - case maybeValue of - Just _ -> - case alter maybeValue of - Just alteredValue -> - D - (List.map - (\(( key, _ ) as entry) -> - if key == targetKey then - ( targetKey, alteredValue ) - - else - entry - ) - alist - ) - - Nothing -> - remove targetKey dict - - Nothing -> - case alter Nothing of - Just alteredValue -> - insert keyComparison targetKey alteredValue dict - - Nothing -> - dict +update : (k -> comparable) -> k -> (Maybe v -> Maybe v) -> Dict comparable k v -> Dict comparable k v +update toComparable targetKey alter (D dict) = + D + (Dict.update (toComparable targetKey) + (Maybe.map Tuple.second + >> alter + >> Maybe.map (Tuple.pair targetKey) + ) + dict + ) {-| Create a dictionary with one key-value pair. -} -singleton : k -> v -> Dict k v -singleton key value = - D [ ( key, value ) ] +singleton : (k -> comparable) -> k -> v -> Dict comparable k v +singleton toComparable key value = + D (Dict.singleton (toComparable key) ( key, value )) @@ -267,34 +226,29 @@ recently inserted to least recently inserted) followed by all the entries of the second dictionary (from most recently inserted to least recently inserted). -} -union : (k -> k -> Order) -> Dict k v -> Dict k v -> Dict k v -union keyComparison (D leftAlist) rightDict = - List.foldr - (\( lKey, lValue ) result -> - insert keyComparison lKey lValue result - ) - rightDict - leftAlist +union : Dict comparable k v -> Dict comparable k v -> Dict comparable k v +union (D leftDict) (D rightDict) = + D (Dict.union leftDict rightDict) {-| Keep a key-value pair when its key appears in the second dictionary. Preference is given to values in the first dictionary. -} -intersection : Dict k a -> Dict k b -> Dict k a -intersection dict1 dict2 = +intersection : (k -> k -> Order) -> Dict comparable k a -> Dict comparable k b -> Dict comparable k a +intersection keyComparison dict1 dict2 = let keys2 : List k keys2 = - keys dict2 + keys keyComparison dict2 in filter (\k _ -> List.member k keys2) dict1 {-| Keep a key-value pair when its key does not appear in the second dictionary. -} -diff : Dict k a -> Dict k b -> Dict k a -diff (D leftAlist) rightDict = - D (List.filter (\( key, _ ) -> not (member key rightDict)) leftAlist) +diff : Dict comparable k a -> Dict comparable k b -> Dict comparable k a +diff (D leftDict) (D rightDict) = + D (Dict.diff leftDict rightDict) {-| The most general way of combining two dictionaries. You provide three @@ -315,42 +269,22 @@ you want: -} merge : - (k -> a -> result -> result) + (k -> k -> Order) + -> (k -> a -> result -> result) -> (k -> a -> b -> result -> result) -> (k -> b -> result -> result) - -> Dict k a - -> Dict k b + -> Dict comparable k a + -> Dict comparable k b -> result -> result -merge leftStep bothStep rightStep ((D leftAlist) as leftDict) (D rightAlist) initialResult = - let - ( inBothAlist, inRightOnlyAlist ) = - List.partition - (\( key, _ ) -> - member key leftDict - ) - rightAlist - - intermediateResult : result - intermediateResult = - List.foldr - (\( rKey, rValue ) result -> - rightStep rKey rValue result - ) - initialResult - inRightOnlyAlist - in - List.foldr - (\( lKey, lValue ) result -> - case get lKey (D inBothAlist) of - Just rValue -> - bothStep lKey lValue rValue result - - Nothing -> - leftStep lKey lValue result - ) - intermediateResult - leftAlist +merge keyComparison leftStep bothStep rightStep (D leftDict) (D rightDict) initialResult = + Dict.merge + (\_ ( k, a ) -> leftStep k a) + (\_ ( k, a ) ( _, b ) -> bothStep k a b) + (\_ ( k, b ) -> rightStep k b) + leftDict + rightDict + initialResult @@ -359,9 +293,9 @@ merge leftStep bothStep rightStep ((D leftAlist) as leftDict) (D rightAlist) ini {-| Apply a function to all values in a dictionary. -} -map : (k -> a -> b) -> Dict k a -> Dict k b -map alter (D alist) = - D (List.map (\( key, value ) -> ( key, alter key value )) alist) +map : (k -> a -> b) -> Dict c k a -> Dict c k b +map alter (D dict) = + D (Dict.map (\_ ( key, value ) -> ( key, alter key value )) dict) {-| Fold over the key-value pairs in a dictionary from most recently inserted @@ -378,14 +312,14 @@ to least recently inserted. --> [28,19,33] -} -foldl : (k -> v -> b -> b) -> b -> Dict k v -> b -foldl func initialResult (D alist) = +foldl : (k -> k -> Order) -> (k -> v -> b -> b) -> b -> Dict c k v -> b +foldl keyComparison func initialResult dict = List.foldl (\( key, value ) result -> func key value result ) initialResult - alist + (toList keyComparison dict) {-| Fold over the key-value pairs in a dictionary from least recently inserted @@ -402,32 +336,32 @@ to most recently insered. --> [33,19,28] -} -foldr : (k -> v -> b -> b) -> b -> Dict k v -> b -foldr func initialResult (D alist) = +foldr : (k -> k -> Order) -> (k -> v -> b -> b) -> b -> Dict c k v -> b +foldr keyComparison func initialResult dict = List.foldr (\( key, value ) result -> func key value result ) initialResult - alist + (toList keyComparison dict) {-| Keep only the key-value pairs that pass the given test. -} -filter : (k -> v -> Bool) -> Dict k v -> Dict k v -filter isGood (D alist) = - D (List.filter (\( key, value ) -> isGood key value) alist) +filter : (k -> v -> Bool) -> Dict comparable k v -> Dict comparable k v +filter isGood (D dict) = + D (Dict.filter (\_ ( key, value ) -> isGood key value) dict) {-| Partition a dictionary according to some test. The first dictionary contains all key-value pairs which passed the test, and the second contains the pairs that did not. -} -partition : (k -> v -> Bool) -> Dict k v -> ( Dict k v, Dict k v ) -partition isGood (D alist) = +partition : (k -> v -> Bool) -> Dict comparable k v -> ( Dict comparable k v, Dict comparable k v ) +partition isGood (D dict) = let ( good, bad ) = - List.partition (\( key, value ) -> isGood key value) alist + Dict.partition (\_ ( key, value ) -> isGood key value) dict in ( D good, D bad ) @@ -443,9 +377,11 @@ with the most recently inserted key at the head of the list. --> [ 1, 0 ] -} -keys : Dict k v -> List k -keys (D alist) = - List.map Tuple.first alist +keys : (k -> k -> Order) -> Dict c k v -> List k +keys keyComparison (D dict) = + Dict.values dict + |> List.sortWith (\( k1, _ ) ( k2, _ ) -> keyComparison k1 k2) + |> List.map Tuple.first {-| Get all of the values in a dictionary, in the order that they were inserted @@ -455,29 +391,28 @@ with the most recently inserted value at the head of the list. --> [ "Bob", "Alice" ] -} -values : Dict k v -> List v -values (D alist) = - List.map Tuple.second alist +values : (k -> k -> Order) -> Dict c k v -> List v +values keyComparison (D dict) = + Dict.values dict + |> List.sortWith (\( k1, _ ) ( k2, _ ) -> keyComparison k1 k2) + |> List.map Tuple.second {-| Convert a dictionary into an association list of key-value pairs, in the order that they were inserted with the most recently inserted entry at the head of the list. -} -toList : Dict k v -> List ( k, v ) -toList (D alist) = - alist +toList : (k -> k -> Order) -> Dict c k v -> List ( k, v ) +toList keyComparison (D dict) = + Dict.values dict + |> List.sortWith (\( k1, _ ) ( k2, _ ) -> keyComparison k1 k2) {-| Convert an association list into a dictionary. The elements are inserted from left to right. (If you want to insert the elements from right to left, you can simply call `List.reverse` on the input before passing it to `fromList`.) -} -fromList : (k -> k -> Order) -> List ( k, v ) -> Dict k v -fromList keyComparison alist = - List.foldl - (\( key, value ) result -> - insert keyComparison key value result - ) - (D []) - alist +fromList : (k -> comparable) -> List ( k, v ) -> Dict comparable k v +fromList toComparable = + List.foldl (\( key, value ) -> Dict.insert (toComparable key) ( key, value )) Dict.empty + >> D diff --git a/src/Data/Set.elm b/src/Data/Set.elm index 4dfc38954..dddb65a29 100644 --- a/src/Data/Set.elm +++ b/src/Data/Set.elm @@ -50,119 +50,119 @@ import Data.Map as Dict exposing (Dict) {-| Represents a set of unique values. So `(Set Int)` is a set of integers and `(Set String)` is a set of strings. -} -type EverySet a - = EverySet (Dict a ()) +type EverySet c a + = EverySet (Dict c a ()) {-| Create an empty set. -} -empty : EverySet a +empty : EverySet c a empty = EverySet Dict.empty {-| Create a set with one value. -} -singleton : a -> EverySet a -singleton k = - EverySet <| Dict.singleton k () +singleton : (a -> comparable) -> a -> EverySet comparable a +singleton toComparable k = + EverySet <| Dict.singleton toComparable k () {-| Insert a value into a set. -} -insert : (a -> a -> Order) -> a -> EverySet a -> EverySet a -insert keyComparison k (EverySet d) = - EverySet <| Dict.insert keyComparison k () d +insert : (a -> comparable) -> a -> EverySet comparable a -> EverySet comparable a +insert toComparable k (EverySet d) = + EverySet <| Dict.insert toComparable k () d {-| Remove a value from a set. If the value is not found, no changes are made. -} -remove : a -> EverySet a -> EverySet a -remove k (EverySet d) = - EverySet <| Dict.remove k d +remove : (a -> comparable) -> a -> EverySet comparable a -> EverySet comparable a +remove toComparable k (EverySet d) = + EverySet <| Dict.remove toComparable k d {-| Determine if a set is empty. -} -isEmpty : EverySet a -> Bool +isEmpty : EverySet c a -> Bool isEmpty (EverySet d) = Dict.isEmpty d {-| Determine if a value is in a set. -} -member : a -> EverySet a -> Bool -member k (EverySet d) = - Dict.member k d +member : (a -> comparable) -> a -> EverySet comparable a -> Bool +member toComparable k (EverySet d) = + Dict.member toComparable k d {-| Determine the number of elements in a set. -} -size : EverySet a -> Int +size : EverySet c a -> Int size (EverySet d) = Dict.size d {-| Get the union of two sets. Keep all values. -} -union : (a -> a -> Order) -> EverySet a -> EverySet a -> EverySet a -union keyComparison (EverySet d1) (EverySet d2) = - EverySet <| Dict.union keyComparison d1 d2 +union : EverySet comparable a -> EverySet comparable a -> EverySet comparable a +union (EverySet d1) (EverySet d2) = + EverySet <| Dict.union d1 d2 {-| Get the intersection of two sets. Keeps values that appear in both sets. -} -intersect : EverySet a -> EverySet a -> EverySet a -intersect (EverySet d1) (EverySet d2) = - EverySet <| Dict.intersection d1 d2 +intersect : (a -> a -> Order) -> EverySet comparable a -> EverySet comparable a -> EverySet comparable a +intersect keyComparison (EverySet d1) (EverySet d2) = + EverySet <| Dict.intersection keyComparison d1 d2 {-| Get the difference between the first set and the second. Keeps values that do not appear in the second set. -} -diff : EverySet a -> EverySet a -> EverySet a +diff : EverySet comparable a -> EverySet comparable a -> EverySet comparable a diff (EverySet d1) (EverySet d2) = EverySet <| Dict.diff d1 d2 {-| Convert a set into a list, sorted from lowest to highest. -} -toList : EverySet a -> List a -toList (EverySet d) = - Dict.keys d +toList : (a -> a -> Order) -> EverySet c a -> List a +toList keyComparison (EverySet d) = + Dict.keys keyComparison d {-| Convert a list into a set, removing any duplicates. -} -fromList : (a -> a -> Order) -> List a -> EverySet a -fromList keyComparison xs = - List.foldl (insert keyComparison) empty xs +fromList : (a -> comparable) -> List a -> EverySet comparable a +fromList toComparable xs = + List.foldl (insert toComparable) empty xs {-| Fold over the values in a set, in order from lowest to highest. -} -foldl : (a -> b -> b) -> b -> EverySet a -> b -foldl f b (EverySet d) = - Dict.foldl (\k _ result -> f k result) b d +foldl : (a -> a -> Order) -> (a -> b -> b) -> b -> EverySet c a -> b +foldl keyComparison f b (EverySet d) = + Dict.foldl keyComparison (\k _ result -> f k result) b d {-| Fold over the values in a set, in order from highest to lowest. -} -foldr : (a -> b -> b) -> b -> EverySet a -> b -foldr f b (EverySet d) = - Dict.foldr (\k _ result -> f k result) b d +foldr : (a -> a -> Order) -> (a -> b -> b) -> b -> EverySet c a -> b +foldr keyComparison f b (EverySet d) = + Dict.foldr keyComparison (\k _ result -> f k result) b d {-| Map a function onto a set, creating a new set with no duplicates. -} -map : (a2 -> a2 -> Order) -> (a -> a2) -> EverySet a -> EverySet a2 -map keyComparison f s = - fromList keyComparison (List.map f (toList s)) +map : (a -> a -> Order) -> (a2 -> comparable) -> (a -> a2) -> EverySet comparable a -> EverySet comparable a2 +map keyComparison toString f s = + fromList toString (List.map f (toList keyComparison s)) {-| Create a new set consisting only of elements which satisfy a predicate. -} -filter : (a -> Bool) -> EverySet a -> EverySet a +filter : (a -> Bool) -> EverySet comparable a -> EverySet comparable a filter p (EverySet d) = EverySet <| Dict.filter (\k _ -> p k) d @@ -170,7 +170,7 @@ filter p (EverySet d) = {-| Create two new sets; the first consisting of elements which satisfy a predicate, the second consisting of elements which do not. -} -partition : (a -> Bool) -> EverySet a -> ( EverySet a, EverySet a ) +partition : (a -> Bool) -> EverySet comparable a -> ( EverySet comparable a, EverySet comparable a ) partition p (EverySet d) = let ( p1, p2 ) = diff --git a/src/System/IO.elm b/src/System/IO.elm index a90b3c2b6..acda3e0dc 100644 --- a/src/System/IO.elm +++ b/src/System/IO.elm @@ -75,7 +75,7 @@ port module System.IO exposing -} import Codec.Archive.Zip as Zip -import Data.Map as Dict exposing (Dict) +import Dict exposing (Dict) import Json.Encode as Encode import Utils.Crash exposing (crash) @@ -102,7 +102,7 @@ run app = { realWorld = { args = flags.args , currentDirectory = flags.currentDirectory - , envVars = Dict.fromList compare flags.envVars + , envVars = Dict.fromList flags.envVars , homedir = flags.homedir , progName = flags.progName , state = initialReplState @@ -240,31 +240,31 @@ update msg model = |> Tuple.mapSecond (\cmd -> Cmd.batch [ updatedCmd, cmd ]) ( newRealWorld, GetLine next ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (GetLineNext next) model.next }, sendGetLine index ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (GetLineNext next) model.next }, sendGetLine index ) ( newRealWorld, HPutStr next (Handle fd) content ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HPutLineNext next) model.next }, sendHPutStr { index = index, fd = fd, content = content } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (HPutLineNext next) model.next }, sendHPutStr { index = index, fd = fd, content = content } ) ( newRealWorld, WriteString next path content ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (WriteStringNext next) model.next }, sendWriteString { index = index, path = path, content = content } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (WriteStringNext next) model.next }, sendWriteString { index = index, path = path, content = content } ) ( newRealWorld, Read next fd ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ReadNext next) model.next }, sendRead { index = index, fd = fd } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (ReadNext next) model.next }, sendRead { index = index, fd = fd } ) ( newRealWorld, HttpFetch next method urlStr headers ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HttpFetchNext next) model.next }, sendHttpFetch { index = index, method = method, urlStr = urlStr, headers = headers } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (HttpFetchNext next) model.next }, sendHttpFetch { index = index, method = method, urlStr = urlStr, headers = headers } ) ( newRealWorld, GetArchive next method url ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (GetArchiveNext next) model.next }, sendGetArchive { index = index, method = method, url = url } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (GetArchiveNext next) model.next }, sendGetArchive { index = index, method = method, url = url } ) ( newRealWorld, HttpUpload next urlStr headers parts ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HttpUploadNext next) model.next }, sendHttpUpload { index = index, urlStr = urlStr, headers = headers, parts = parts } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (HttpUploadNext next) model.next }, sendHttpUpload { index = index, urlStr = urlStr, headers = headers, parts = parts } ) ( newRealWorld, HFlush next (Handle fd) ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HFlushNext next) model.next }, sendHFlush { index = index, fd = fd } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (HFlushNext next) model.next }, sendHFlush { index = index, fd = fd } ) ( newRealWorld, WithFile next path mode ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (WithFileNext next) model.next } + ( { model | realWorld = newRealWorld, next = Dict.insert index (WithFileNext next) model.next } , sendWithFile { index = index , path = path @@ -285,76 +285,76 @@ update msg model = ) ( newRealWorld, HFileSize next (Handle fd) ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HFileSizeNext next) model.next }, sendHFileSize { index = index, fd = fd } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (HFileSizeNext next) model.next }, sendHFileSize { index = index, fd = fd } ) ( newRealWorld, ProcWithCreateProcess next createProcess ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ProcWithCreateProcessNext next) model.next }, sendProcWithCreateProcess { index = index, createProcess = createProcess } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (ProcWithCreateProcessNext next) model.next }, sendProcWithCreateProcess { index = index, createProcess = createProcess } ) ( newRealWorld, HClose next (Handle fd) ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HCloseNext next) model.next }, sendHClose { index = index, fd = fd } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (HCloseNext next) model.next }, sendHClose { index = index, fd = fd } ) ( newRealWorld, ProcWaitForProcess next ph ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ProcWaitForProcessNext next) model.next }, sendProcWaitForProcess { index = index, ph = ph } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (ProcWaitForProcessNext next) model.next }, sendProcWaitForProcess { index = index, ph = ph } ) ( newRealWorld, ExitWith next code ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ExitWithNext next) model.next }, sendExitWith code ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (ExitWithNext next) model.next }, sendExitWith code ) ( newRealWorld, DirFindExecutable next name ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirFindExecutableNext next) model.next }, sendDirFindExecutable { index = index, name = name } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirFindExecutableNext next) model.next }, sendDirFindExecutable { index = index, name = name } ) ( newRealWorld, ReplGetInputLine next prompt ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ReplGetInputLineNext next) model.next }, sendReplGetInputLine { index = index, prompt = prompt } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (ReplGetInputLineNext next) model.next }, sendReplGetInputLine { index = index, prompt = prompt } ) ( newRealWorld, DirDoesFileExist next filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirDoesFileExistNext next) model.next }, sendDirDoesFileExist { index = index, filename = filename } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirDoesFileExistNext next) model.next }, sendDirDoesFileExist { index = index, filename = filename } ) ( newRealWorld, DirCreateDirectoryIfMissing next createParents filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirCreateDirectoryIfMissingNext next) model.next }, sendDirCreateDirectoryIfMissing { index = index, createParents = createParents, filename = filename } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirCreateDirectoryIfMissingNext next) model.next }, sendDirCreateDirectoryIfMissing { index = index, createParents = createParents, filename = filename } ) ( newRealWorld, LockFile next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (LockFileNext next) model.next }, sendLockFile { index = index, path = path } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (LockFileNext next) model.next }, sendLockFile { index = index, path = path } ) ( newRealWorld, UnlockFile next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (UnlockFileNext next) model.next }, sendUnlockFile { index = index, path = path } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (UnlockFileNext next) model.next }, sendUnlockFile { index = index, path = path } ) ( newRealWorld, DirGetModificationTime next filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirGetModificationTimeNext next) model.next }, sendDirGetModificationTime { index = index, filename = filename } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirGetModificationTimeNext next) model.next }, sendDirGetModificationTime { index = index, filename = filename } ) ( newRealWorld, DirDoesDirectoryExist next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirDoesDirectoryExistNext next) model.next }, sendDirDoesDirectoryExist { index = index, path = path } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirDoesDirectoryExistNext next) model.next }, sendDirDoesDirectoryExist { index = index, path = path } ) ( newRealWorld, DirCanonicalizePath next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirCanonicalizePathNext next) model.next }, sendDirCanonicalizePath { index = index, path = path } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirCanonicalizePathNext next) model.next }, sendDirCanonicalizePath { index = index, path = path } ) ( newRealWorld, BinaryDecodeFileOrFail next filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (BinaryDecodeFileOrFailNext next) model.next }, sendBinaryDecodeFileOrFail { index = index, filename = filename } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (BinaryDecodeFileOrFailNext next) model.next }, sendBinaryDecodeFileOrFail { index = index, filename = filename } ) ( newRealWorld, Write next fd content ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (WriteNext next) model.next }, sendWrite { index = index, fd = fd, content = content } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (WriteNext next) model.next }, sendWrite { index = index, fd = fd, content = content } ) ( newRealWorld, DirRemoveFile next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirRemoveFileNext next) model.next }, sendDirRemoveFile { index = index, path = path } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirRemoveFileNext next) model.next }, sendDirRemoveFile { index = index, path = path } ) ( newRealWorld, DirRemoveDirectoryRecursive next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirRemoveDirectoryRecursiveNext next) model.next }, sendDirRemoveDirectoryRecursive { index = index, path = path } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirRemoveDirectoryRecursiveNext next) model.next }, sendDirRemoveDirectoryRecursive { index = index, path = path } ) ( newRealWorld, DirWithCurrentDirectory next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (DirWithCurrentDirectoryNext next) model.next }, sendDirWithCurrentDirectory { index = index, path = path } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (DirWithCurrentDirectoryNext next) model.next }, sendDirWithCurrentDirectory { index = index, path = path } ) ( newRealWorld, ReplGetInputLineWithInitial next prompt left right ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ReplGetInputLineWithInitialNext next) model.next }, sendReplGetInputLineWithInitial { index = index, prompt = prompt, left = left, right = right } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (ReplGetInputLineWithInitialNext next) model.next }, sendReplGetInputLineWithInitial { index = index, prompt = prompt, left = left, right = right } ) ( newRealWorld, NewEmptyMVar next ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (NewEmptyMVarNext next) model.next }, sendNewEmptyMVar index ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (NewEmptyMVarNext next) model.next }, sendNewEmptyMVar index ) ( newRealWorld, ReadMVar next id ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ReadMVarNext next) model.next }, sendReadMVar { index = index, id = id } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (ReadMVarNext next) model.next }, sendReadMVar { index = index, id = id } ) ( newRealWorld, TakeMVar next id ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (TakeMVarNext next) model.next }, sendTakeMVar { index = index, id = id } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (TakeMVarNext next) model.next }, sendTakeMVar { index = index, id = id } ) ( newRealWorld, PutMVar next id value ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert compare index (PutMVarNext next) model.next }, sendPutMVar { index = index, id = id, value = value } ) + ( { model | realWorld = newRealWorld, next = Dict.insert index (PutMVarNext next) model.next }, sendPutMVar { index = index, id = id, value = value } ) GetLineMsg index input -> case Dict.get index model.next of diff --git a/src/System/TypeCheck/IO.elm b/src/System/TypeCheck/IO.elm index a9ea9a1ea..ba24cfc74 100644 --- a/src/System/TypeCheck/IO.elm +++ b/src/System/TypeCheck/IO.elm @@ -105,14 +105,15 @@ foldM f b = List.foldl (\a -> bind (\acc -> f acc a)) (pure b) -traverseMap : (k -> k -> Order) -> (a -> IO b) -> Dict k a -> IO (Dict k b) -traverseMap keyComparison f = - traverseMapWithKey keyComparison (\_ -> f) +traverseMap : (k -> comparable) -> (k -> k -> Order) -> (a -> IO b) -> Dict comparable k a -> IO (Dict comparable k b) +traverseMap toComparable keyComparison f = + traverseMapWithKey toComparable keyComparison (\_ -> f) -traverseMapWithKey : (k -> k -> Order) -> (k -> a -> IO b) -> Dict k a -> IO (Dict k b) -traverseMapWithKey keyComparison f = - Dict.foldl (\k a -> bind (\c -> fmap (\va -> Dict.insert keyComparison k va c) (f k a))) +traverseMapWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> IO b) -> Dict comparable k a -> IO (Dict comparable k b) +traverseMapWithKey toComparable keyComparison f = + Dict.foldl keyComparison + (\k a -> bind (\c -> fmap (\va -> Dict.insert toComparable k va c) (f k a))) (pure Dict.empty) @@ -131,9 +132,9 @@ forM_ list f = mapM_ f list -foldMDict : (b -> a -> IO b) -> b -> Dict k a -> IO b -foldMDict f b = - Dict.foldl (\_ a -> bind (\acc -> f acc a)) (pure b) +foldMDict : (k -> k -> Order) -> (b -> a -> IO b) -> b -> Dict c k a -> IO b +foldMDict keyComparison f b = + Dict.foldl keyComparison (\_ a -> bind (\acc -> f acc a)) (pure b) traverseList : (a -> IO b) -> List a -> IO (List b) @@ -251,7 +252,7 @@ type FlatType = App1 Canonical String (List Variable) | Fun1 Variable Variable | EmptyRecord1 - | Record1 (Dict String Variable) Variable + | Record1 (Dict String String Variable) Variable | Unit1 | Tuple1 Variable Variable (Maybe Variable) diff --git a/src/Terminal/Diff.elm b/src/Terminal/Diff.elm index 3c8e3c5fc..b5ae5bc36 100644 --- a/src/Terminal/Diff.elm +++ b/src/Terminal/Diff.elm @@ -233,7 +233,7 @@ writeDiff oldDocs newDocs = localizer : L.Localizer localizer = - L.fromNames (Dict.union compare oldDocs newDocs) + L.fromNames (Dict.union oldDocs newDocs) in Task.io (Help.toStdout (toDoc localizer changes |> D.a (D.fromChars "\n"))) @@ -285,7 +285,7 @@ toDoc localizer ((PackageChanges added changed removed) as changes) = chunks : List Chunk chunks = - addedChunk ++ removedChunk ++ List.map (changesToChunk localizer) (Dict.toList changed) + addedChunk ++ removedChunk ++ List.map (changesToChunk localizer) (Dict.toList compare changed) in D.vcat (header :: D.fromChars "" :: List.map chunkToDoc chunks) @@ -322,16 +322,16 @@ changesToChunk localizer ( name, (ModuleChanges unions aliases values binops) as DD.moduleChangeMagnitude changes ( unionAdd, unionChange, unionRemove ) = - changesToDocTriple (unionToDoc localizer) unions + changesToDocTriple compare (unionToDoc localizer) unions ( aliasAdd, aliasChange, aliasRemove ) = - changesToDocTriple (aliasToDoc localizer) aliases + changesToDocTriple compare (aliasToDoc localizer) aliases ( valueAdd, valueChange, valueRemove ) = - changesToDocTriple (valueToDoc localizer) values + changesToDocTriple compare (valueToDoc localizer) values ( binopAdd, binopChange, binopRemove ) = - changesToDocTriple (binopToDoc localizer) binops + changesToDocTriple compare (binopToDoc localizer) binops in Chunk name magnitude <| D.vcat <| @@ -343,8 +343,8 @@ changesToChunk localizer ( name, (ModuleChanges unions aliases values binops) as ] -changesToDocTriple : (k -> v -> D.Doc) -> Changes k v -> ( List D.Doc, List D.Doc, List D.Doc ) -changesToDocTriple entryToDoc (Changes added changed removed) = +changesToDocTriple : (k -> k -> Order) -> (k -> v -> D.Doc) -> Changes comparable k v -> ( List D.Doc, List D.Doc, List D.Doc ) +changesToDocTriple keyComparison entryToDoc (Changes added changed removed) = let indented : ( k, v ) -> D.Doc indented ( name, value ) = @@ -358,9 +358,9 @@ changesToDocTriple entryToDoc (Changes added changed removed) = , D.fromChars "" ] in - ( List.map indented (Dict.toList added) - , List.map diffed (Dict.toList changed) - , List.map indented (Dict.toList removed) + ( List.map indented (Dict.toList keyComparison added) + , List.map diffed (Dict.toList keyComparison changed) + , List.map indented (Dict.toList keyComparison removed) ) diff --git a/src/Terminal/Init.elm b/src/Terminal/Init.elm index d1ec6e312..bc42936d7 100644 --- a/src/Terminal/Init.elm +++ b/src/Terminal/Init.elm @@ -96,22 +96,22 @@ init = IO.pure (Err (Exit.InitSolverProblem exit)) Solver.NoSolution -> - IO.pure (Err (Exit.InitNoSolution (Dict.keys defaults))) + IO.pure (Err (Exit.InitNoSolution (Dict.keys compare defaults))) Solver.NoOfflineSolution -> - IO.pure (Err (Exit.InitNoOfflineSolution (Dict.keys defaults))) + IO.pure (Err (Exit.InitNoOfflineSolution (Dict.keys compare defaults))) Solver.SolverOk details -> let - solution : Dict Pkg.Name V.Version + solution : Dict ( String, String ) Pkg.Name V.Version solution = Dict.map (\_ (Solver.Details vsn _) -> vsn) details - directs : Dict Pkg.Name V.Version + directs : Dict ( String, String ) Pkg.Name V.Version directs = - Dict.intersection solution defaults + Dict.intersection compare solution defaults - indirects : Dict Pkg.Name V.Version + indirects : Dict ( String, String ) Pkg.Name V.Version indirects = Dict.diff solution defaults in @@ -128,9 +128,9 @@ init = ) -defaults : Dict Pkg.Name Con.Constraint +defaults : Dict ( String, String ) Pkg.Name Con.Constraint defaults = - Dict.fromList Pkg.compareName + Dict.fromList identity [ ( Pkg.core, Con.anything ) , ( Pkg.browser, Con.anything ) , ( Pkg.html, Con.anything ) diff --git a/src/Terminal/Install.elm b/src/Terminal/Install.elm index 92a1d63b5..1207137e8 100644 --- a/src/Terminal/Install.elm +++ b/src/Terminal/Install.elm @@ -77,7 +77,7 @@ type Changes vsn = AlreadyInstalled | PromoteTest Outline.Outline | PromoteIndirect Outline.Outline - | Changes (Dict Pkg.Name (Change vsn)) Outline.Outline + | Changes (Dict ( String, String ) Pkg.Name (Change vsn)) Outline.Outline type alias Task a = @@ -159,11 +159,11 @@ attemptChanges root env oldOutline toChars changes = let widths : Widths widths = - Dict.foldr (widen toChars) (Widths 0 0 0) changeDict + Dict.foldr compare (widen toChars) (Widths 0 0 0) changeDict changeDocs : ChangeDocs changeDocs = - Dict.foldr (addChange toChars widths) (Docs [] [] []) changeDict + Dict.foldr compare (addChange toChars widths) (Docs [] [] []) changeDict in attemptChangesHelp root env oldOutline newOutline <| D.vcat @@ -210,50 +210,50 @@ attemptChangesHelp root env oldOutline newOutline question = makeAppPlan : Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version) makeAppPlan (Solver.Env cache _ connection registry) pkg ((Outline.AppOutline elmVersion sourceDirs direct indirect testDirect testIndirect) as outline) = - if Dict.member pkg direct then + if Dict.member identity pkg direct then Task.pure AlreadyInstalled else -- is it already indirect? - case Dict.get pkg indirect of + case Dict.get identity pkg indirect of Just vsn -> Task.pure <| PromoteIndirect <| Outline.App <| Outline.AppOutline elmVersion sourceDirs - (Dict.insert Pkg.compareName pkg vsn direct) - (Dict.remove pkg indirect) + (Dict.insert identity pkg vsn direct) + (Dict.remove identity pkg indirect) testDirect testIndirect Nothing -> -- is it already a test dependency? - case Dict.get pkg testDirect of + case Dict.get identity pkg testDirect of Just vsn -> Task.pure <| PromoteTest <| Outline.App <| Outline.AppOutline elmVersion sourceDirs - (Dict.insert Pkg.compareName pkg vsn direct) + (Dict.insert identity pkg vsn direct) indirect - (Dict.remove pkg testDirect) + (Dict.remove identity pkg testDirect) testIndirect Nothing -> -- is it already an indirect test dependency? - case Dict.get pkg testIndirect of + case Dict.get identity pkg testIndirect of Just vsn -> Task.pure <| PromoteTest <| Outline.App <| Outline.AppOutline elmVersion sourceDirs - (Dict.insert Pkg.compareName pkg vsn direct) + (Dict.insert identity pkg vsn direct) indirect testDirect - (Dict.remove pkg testIndirect) + (Dict.remove identity pkg testIndirect) Nothing -> -- finally try to add it from scratch @@ -291,12 +291,12 @@ makeAppPlan (Solver.Env cache _ connection registry) pkg ((Outline.AppOutline el makePkgPlan : Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint) makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline name summary license version exposed deps test elmVersion) = - if Dict.member pkg deps then + if Dict.member identity pkg deps then Task.pure AlreadyInstalled else -- is already in test dependencies? - case Dict.get pkg test of + case Dict.get identity pkg test of Just con -> Task.pure <| PromoteTest <| @@ -306,8 +306,8 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline nam license version exposed - (Dict.insert Pkg.compareName pkg con deps) - (Dict.remove pkg test) + (Dict.insert identity pkg con deps) + (Dict.remove identity pkg test) elmVersion Nothing -> @@ -323,13 +323,13 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline nam Ok (Registry.KnownVersions _ _) -> let - old : Dict Pkg.Name C.Constraint + old : Dict ( String, String ) Pkg.Name C.Constraint old = - Dict.union Pkg.compareName deps test + Dict.union deps test - cons : Dict Pkg.Name C.Constraint + cons : Dict ( String, String ) Pkg.Name C.Constraint cons = - Dict.insert Pkg.compareName pkg C.anything old + Dict.insert identity pkg C.anything old in Task.io (Solver.verify cache connection registry cons) |> Task.bind @@ -338,23 +338,23 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline nam Solver.SolverOk solution -> let (Solver.Details vsn _) = - Utils.find pkg solution + Utils.find identity pkg solution con : C.Constraint con = C.untilNextMajor vsn - new : Dict Pkg.Name C.Constraint + new : Dict ( String, String ) Pkg.Name C.Constraint new = - Dict.insert Pkg.compareName pkg con old + Dict.insert identity pkg con old - changes : Dict Pkg.Name (Change C.Constraint) + changes : Dict ( String, String ) Pkg.Name (Change C.Constraint) changes = detectChanges old new - news : Dict Pkg.Name C.Constraint + news : Dict ( String, String ) Pkg.Name C.Constraint news = - Utils.mapMapMaybe Pkg.compareName keepNew changes + Utils.mapMapMaybe identity Pkg.compareName keepNew changes in Task.pure <| Changes changes <| @@ -379,14 +379,14 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline nam ) -addNews : Maybe Pkg.Name -> Dict Pkg.Name C.Constraint -> Dict Pkg.Name C.Constraint -> Dict Pkg.Name C.Constraint +addNews : Maybe Pkg.Name -> Dict ( String, String ) Pkg.Name C.Constraint -> Dict ( String, String ) Pkg.Name C.Constraint -> Dict ( String, String ) Pkg.Name C.Constraint addNews pkg new old = - Dict.merge - (Dict.insert Pkg.compareName) - (\k _ n -> Dict.insert Pkg.compareName k n) + Dict.merge compare + (Dict.insert identity) + (\k _ n -> Dict.insert identity k n) (\k c acc -> if Just k == pkg then - Dict.insert Pkg.compareName k c acc + Dict.insert identity k c acc else acc @@ -406,19 +406,19 @@ type Change a | Remove a -detectChanges : Dict Pkg.Name a -> Dict Pkg.Name a -> Dict Pkg.Name (Change a) +detectChanges : Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name (Change a) detectChanges old new = - Dict.merge - (\k v -> Dict.insert Pkg.compareName k (Remove v)) + Dict.merge compare + (\k v -> Dict.insert identity k (Remove v)) (\k oldElem newElem acc -> case keepChange k oldElem newElem of Just change -> - Dict.insert Pkg.compareName k change acc + Dict.insert identity k change acc Nothing -> acc ) - (\k v -> Dict.insert Pkg.compareName k (Insert v)) + (\k v -> Dict.insert identity k (Insert v)) old new Dict.empty diff --git a/src/Terminal/Repl.elm b/src/Terminal/Repl.elm index 29ab58d55..9c4eff8f3 100644 --- a/src/Terminal/Repl.elm +++ b/src/Terminal/Repl.elm @@ -37,7 +37,8 @@ import Compiler.Reporting.Error.Syntax as ES import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Report as Report import Control.Monad.State.Strict as State -import Data.Map as Dict exposing (Dict) +import Data.Map as Map exposing (Dict) +import Dict import List.Extra as List import Maybe.Extra as Maybe import Prelude @@ -544,7 +545,7 @@ eval env ((IO.ReplState imports types decls) as state) input = let newState : IO.ReplState newState = - IO.ReplState (Dict.insert compare name src imports) types decls + IO.ReplState (Dict.insert name src imports) types decls in IO.fmap Loop (attemptEval env state newState OutputNothing) @@ -552,7 +553,7 @@ eval env ((IO.ReplState imports types decls) as state) input = let newState : IO.ReplState newState = - IO.ReplState imports (Dict.insert compare name src types) decls + IO.ReplState imports (Dict.insert name src types) decls in IO.fmap Loop (attemptEval env state newState OutputNothing) @@ -564,7 +565,7 @@ eval env ((IO.ReplState imports types decls) as state) input = let newState : IO.ReplState newState = - IO.ReplState imports types (Dict.insert compare name src decls) + IO.ReplState imports types (Dict.insert name src decls) in IO.fmap Loop (attemptEval env state newState (OutputDecl name)) @@ -749,7 +750,7 @@ getRoot = V.one (Outline.ExposedList []) defaultDeps - Dict.empty + Map.empty C.defaultElm ) |> IO.fmap (\_ -> root) @@ -757,9 +758,9 @@ getRoot = ) -defaultDeps : Dict Pkg.Name C.Constraint +defaultDeps : Dict ( String, String ) Pkg.Name C.Constraint defaultDeps = - Dict.fromList Pkg.compareName + Map.fromList identity [ ( Pkg.core, C.anything ) , ( Pkg.json, C.anything ) , ( Pkg.html, C.anything ) @@ -841,9 +842,9 @@ lookupCompletions string = ) -commands : Dict N.Name () +commands : Dict.Dict N.Name () commands = - Dict.fromList compare + Dict.fromList [ ( ":exit", () ) , ( ":quit", () ) , ( ":reset", () ) @@ -851,7 +852,7 @@ commands = ] -addMatches : String -> Bool -> Dict N.Name v -> List Utils.ReplCompletion -> List Utils.ReplCompletion +addMatches : String -> Bool -> Dict.Dict N.Name v -> List Utils.ReplCompletion -> List Utils.ReplCompletion addMatches string isFinished dict completions = Dict.foldr (addMatch string isFinished) completions dict diff --git a/src/Terminal/Terminal/Helpers.elm b/src/Terminal/Terminal/Helpers.elm index 1e21361c6..011062bb2 100644 --- a/src/Terminal/Terminal/Helpers.elm +++ b/src/Terminal/Terminal/Helpers.elm @@ -143,7 +143,7 @@ suggestPackages given = Just (Registry.Registry _ versions) -> List.filter (String.startsWith given) <| - List.map Pkg.toChars (Dict.keys versions) + List.map Pkg.toChars (Dict.keys compare versions) ) ) @@ -166,6 +166,6 @@ examplePackages given = Just (Registry.Registry _ versions) -> List.map Pkg.toChars <| List.take 4 <| - Suggest.sort given Pkg.toChars (Dict.keys versions) + Suggest.sort given Pkg.toChars (Dict.keys compare versions) ) ) diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index f9df21df5..0baebe3e2 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -129,12 +129,14 @@ import Basics.Extra exposing (flip) import Builder.Reporting.Task as Task exposing (Task) import Compiler.Data.Index as Index import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Version exposing (toComparable) import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Reporting.Result as R import Control.Monad.State.Strict as State -import Data.Map as Dict exposing (Dict) +import Data.Map as Map exposing (Dict) import Data.Set as EverySet exposing (EverySet) +import Dict import Json.Decode as Decode import Json.Encode as Encode import Maybe.Extra as Maybe @@ -185,13 +187,13 @@ fpAddExtension path extension = path ++ "." ++ extension -mapFromListWith : (k -> k -> Order) -> (a -> a -> a) -> List ( k, a ) -> Dict k a -mapFromListWith keyComparison f = +mapFromListWith : (k -> comparable) -> (a -> a -> a) -> List ( k, a ) -> Dict comparable k a +mapFromListWith toComparable f = List.foldl (\( k, a ) -> - Dict.update keyComparison k (Maybe.map (flip f a)) + Map.update toComparable k (Maybe.map (flip f a)) ) - Dict.empty + Map.empty maybeEncoder : (a -> Encode.Value) -> Maybe a -> Encode.Value @@ -217,10 +219,10 @@ eitherLefts = ) -mapFromKeys : (k -> k -> Order) -> (k -> v) -> List k -> Dict k v -mapFromKeys keyComparison f = +mapFromKeys : (k -> comparable) -> (k -> v) -> List k -> Dict comparable k v +mapFromKeys toComparable f = List.map (\k -> ( k, f k )) - >> Dict.fromList keyComparison + >> Map.fromList toComparable filterM : (a -> IO Bool) -> List a -> IO (List a) @@ -242,9 +244,9 @@ filterM p = (IO.pure []) -find : k -> Dict k a -> a -find k items = - case Dict.get k items of +find : (k -> comparable) -> k -> Dict comparable k a -> a +find toComparable k items = + case Map.get toComparable k items of Just item -> item @@ -252,9 +254,9 @@ find k items = crash "Map.!: given key is not an element in the map" -mapLookupMin : Dict comparable a -> Maybe ( comparable, a ) +mapLookupMin : Dict comparable comparable a -> Maybe ( comparable, a ) mapLookupMin dict = - case List.sortBy Tuple.first (Dict.toList dict) of + case List.sortBy Tuple.first (Map.toList compare dict) of firstElem :: _ -> Just firstElem @@ -262,9 +264,9 @@ mapLookupMin dict = Nothing -mapFindMin : Dict comparable a -> ( comparable, a ) +mapFindMin : Dict comparable comparable a -> ( comparable, a ) mapFindMin dict = - case List.sortBy Tuple.first (Dict.toList dict) of + case List.sortBy Tuple.first (Map.toList compare dict) of firstElem :: _ -> firstElem @@ -272,34 +274,34 @@ mapFindMin dict = crash "Error: empty map has no minimal element" -mapInsertWith : (k -> k -> Order) -> (a -> a -> a) -> k -> a -> Dict k a -> Dict k a -mapInsertWith keyComparison f k a = - Dict.update keyComparison k (Maybe.map (f a) >> Maybe.withDefault a >> Just) +mapInsertWith : (k -> comparable) -> (a -> a -> a) -> k -> a -> Dict comparable k a -> Dict comparable k a +mapInsertWith toComparable f k a = + Map.update toComparable k (Maybe.map (f a) >> Maybe.withDefault a >> Just) -mapIntersectionWith : (k -> k -> Order) -> (a -> b -> c) -> Dict k a -> Dict k b -> Dict k c -mapIntersectionWith keyComparison func = - mapIntersectionWithKey keyComparison (\_ -> func) +mapIntersectionWith : (k -> comparable) -> (k -> k -> Order) -> (a -> b -> c) -> Dict comparable k a -> Dict comparable k b -> Dict comparable k c +mapIntersectionWith toComparable keyComparison func = + mapIntersectionWithKey toComparable keyComparison (\_ -> func) -mapIntersectionWithKey : (k -> k -> Order) -> (k -> a -> b -> c) -> Dict k a -> Dict k b -> Dict k c -mapIntersectionWithKey keyComparison func dict1 dict2 = - Dict.merge (\_ _ -> identity) (\k v1 v2 -> Dict.insert keyComparison k (func k v1 v2)) (\_ _ -> identity) dict1 dict2 Dict.empty +mapIntersectionWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> b -> c) -> Dict comparable k a -> Dict comparable k b -> Dict comparable k c +mapIntersectionWithKey toComparable keyComparison func dict1 dict2 = + Map.merge keyComparison (\_ _ -> identity) (\k v1 v2 -> Map.insert toComparable k (func k v1 v2)) (\_ _ -> identity) dict1 dict2 Map.empty -mapUnionWith : (k -> k -> Order) -> (a -> a -> a) -> Dict k a -> Dict k a -> Dict k a -mapUnionWith keyComparison f a b = - Dict.merge (Dict.insert keyComparison) (\k va vb -> Dict.insert keyComparison k (f va vb)) (Dict.insert keyComparison) a b Dict.empty +mapUnionWith : (k -> comparable) -> (k -> k -> Order) -> (a -> a -> a) -> Dict comparable k a -> Dict comparable k a -> Dict comparable k a +mapUnionWith toComparable keyComparison f a b = + Map.merge keyComparison (Map.insert toComparable) (\k va vb -> Map.insert toComparable k (f va vb)) (Map.insert toComparable) a b Map.empty -mapUnionsWith : (k -> k -> Order) -> (a -> a -> a) -> List (Dict k a) -> Dict k a -mapUnionsWith keyComparison f = - List.foldl (mapUnionWith keyComparison f) Dict.empty +mapUnionsWith : (k -> comparable) -> (k -> k -> Order) -> (a -> a -> a) -> List (Dict comparable k a) -> Dict comparable k a +mapUnionsWith toComparable keyComparison f = + List.foldl (mapUnionWith toComparable keyComparison f) Map.empty -mapUnions : (k -> k -> Order) -> List (Dict k a) -> Dict k a -mapUnions keyComparison = - List.foldr (Dict.union keyComparison) Dict.empty +mapUnions : List (Dict comparable k a) -> Dict comparable k a +mapUnions = + List.foldr Map.union Map.empty foldM : (b -> a -> R.RResult info warnings error b) -> b -> List a -> R.RResult info warnings error b @@ -318,9 +320,9 @@ indexedZipWithA func listX listY = R.pure (Index.LengthMismatch x y) -sequenceADict : (k -> k -> Order) -> Dict k (R.RResult i w e v) -> R.RResult i w e (Dict k v) -sequenceADict keyComparison = - Dict.foldr (\k x acc -> R.apply acc (R.fmap (Dict.insert keyComparison k) x)) (R.pure Dict.empty) +sequenceADict : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (R.RResult i w e v) -> R.RResult i w e (Dict comparable k v) +sequenceADict toComparable keyComparison = + Map.foldr keyComparison (\k x acc -> R.apply acc (R.fmap (Map.insert toComparable k) x)) (R.pure Map.empty) sequenceAList : List (R.RResult i w e v) -> R.RResult i w e (List v) @@ -328,19 +330,19 @@ sequenceAList = List.foldr (\x acc -> R.apply acc (R.fmap (::) x)) (R.pure []) -sequenceDictMaybe : (k -> k -> Order) -> Dict k (Maybe a) -> Maybe (Dict k a) -sequenceDictMaybe keyComparison = - Dict.foldr (\k -> Maybe.map2 (Dict.insert keyComparison k)) (Just Dict.empty) +sequenceDictMaybe : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (Maybe a) -> Maybe (Dict comparable k a) +sequenceDictMaybe toComparable keyComparison = + Map.foldr keyComparison (\k -> Maybe.map2 (Map.insert toComparable k)) (Just Map.empty) -sequenceDictResult : (k -> k -> Order) -> Dict k (Result e v) -> Result e (Dict k v) -sequenceDictResult keyComparison = - Dict.foldr (\k -> Result.map2 (Dict.insert keyComparison k)) (Ok Dict.empty) +sequenceDictResult : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (Result e v) -> Result e (Dict comparable k v) +sequenceDictResult toComparable keyComparison = + Map.foldr keyComparison (\k -> Result.map2 (Map.insert toComparable k)) (Ok Map.empty) -sequenceDictResult_ : (k -> k -> Order) -> Dict k (Result e a) -> Result e () -sequenceDictResult_ keyComparison = - sequenceDictResult keyComparison >> Result.map (\_ -> ()) +sequenceDictResult_ : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (Result e a) -> Result e () +sequenceDictResult_ toComparable keyComparison = + sequenceDictResult toComparable keyComparison >> Result.map (\_ -> ()) sequenceListMaybe : List (Maybe a) -> Maybe (List a) @@ -353,9 +355,9 @@ sequenceNonemptyListResult (NE.Nonempty x xs) = List.foldr (\a acc -> Result.map2 NE.cons a acc) (Result.map NE.singleton x) xs -keysSet : (k -> k -> Order) -> Dict k a -> EverySet k -keysSet keyComparison = - Dict.keys >> EverySet.fromList keyComparison +keysSet : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k a -> EverySet comparable k +keysSet toComparable keyComparison = + Map.keys keyComparison >> EverySet.fromList toComparable unzip3 : List ( a, b, c ) -> ( List a, List b, List c ) @@ -378,14 +380,14 @@ mapM_ f = List.foldr c (IO.pure ()) -dictMapM_ : (a -> IO b) -> Dict k a -> IO () -dictMapM_ f = +dictMapM_ : (k -> k -> Order) -> (a -> IO b) -> Dict c k a -> IO () +dictMapM_ keyComparison f = let c : k -> a -> IO () -> IO () c _ x k = IO.bind (\_ -> k) (f x) in - Dict.foldl c (IO.pure ()) + Map.foldl keyComparison c (IO.pure ()) maybeMapM : (a -> Maybe b) -> List a -> Maybe (List b) @@ -393,43 +395,45 @@ maybeMapM = listMaybeTraverse -mapMinViewWithKey : (k -> k -> Order) -> (( k, a ) -> comparable) -> Dict k a -> Maybe ( ( k, a ), Dict k a ) -mapMinViewWithKey keyComparison compare dict = - case List.sortBy compare (Dict.toList dict) of +mapMinViewWithKey : (k -> comparable) -> (k -> k -> Order) -> (( k, a ) -> comparable) -> Dict comparable k a -> Maybe ( ( k, a ), Dict comparable k a ) +mapMinViewWithKey toComparable keyComparison compare dict = + case List.sortBy compare (Map.toList keyComparison dict) of first :: tail -> - Just ( first, Dict.fromList keyComparison tail ) + Just ( first, Map.fromList toComparable tail ) _ -> Nothing -mapMapMaybe : (k -> k -> Order) -> (a -> Maybe b) -> Dict k a -> Dict k b -mapMapMaybe keyComparison func = - Dict.toList +mapMapMaybe : (k -> comparable) -> (k -> k -> Order) -> (a -> Maybe b) -> Dict comparable k a -> Dict comparable k b +mapMapMaybe toComparable keyComparison func = + Map.toList keyComparison >> List.filterMap (\( k, a ) -> Maybe.map (Tuple.pair k) (func a)) - >> Dict.fromList keyComparison + >> Map.fromList toComparable -mapTraverse : (k -> k -> Order) -> (a -> IO b) -> Dict k a -> IO (Dict k b) -mapTraverse keyComparison f = - mapTraverseWithKey keyComparison (\_ -> f) +mapTraverse : (k -> comparable) -> (k -> k -> Order) -> (a -> IO b) -> Dict comparable k a -> IO (Dict comparable k b) +mapTraverse toComparable keyComparison f = + mapTraverseWithKey toComparable keyComparison (\_ -> f) -mapTraverseWithKey : (k -> k -> Order) -> (k -> a -> IO b) -> Dict k a -> IO (Dict k b) -mapTraverseWithKey keyComparison f = - Dict.foldl (\k a -> IO.bind (\c -> IO.fmap (\va -> Dict.insert keyComparison k va c) (f k a))) - (IO.pure Dict.empty) +mapTraverseWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> IO b) -> Dict comparable k a -> IO (Dict comparable k b) +mapTraverseWithKey toComparable keyComparison f = + Map.foldl keyComparison + (\k a -> IO.bind (\c -> IO.fmap (\va -> Map.insert toComparable k va c) (f k a))) + (IO.pure Map.empty) -mapTraverseResult : (k -> k -> Order) -> (a -> Result e b) -> Dict k a -> Result e (Dict k b) -mapTraverseResult keyComparison f = - mapTraverseWithKeyResult keyComparison (\_ -> f) +mapTraverseResult : (k -> comparable) -> (k -> k -> Order) -> (a -> Result e b) -> Dict comparable k a -> Result e (Dict comparable k b) +mapTraverseResult toComparable keyComparison f = + mapTraverseWithKeyResult toComparable keyComparison (\_ -> f) -mapTraverseWithKeyResult : (k -> k -> Order) -> (k -> a -> Result e b) -> Dict k a -> Result e (Dict k b) -mapTraverseWithKeyResult keyComparison f = - Dict.foldl (\k a -> Result.map2 (Dict.insert keyComparison k) (f k a)) - (Ok Dict.empty) +mapTraverseWithKeyResult : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> Result e b) -> Dict comparable k a -> Result e (Dict comparable k b) +mapTraverseWithKeyResult toComparable keyComparison f = + Map.foldl keyComparison + (\k a -> Result.map2 (Map.insert toComparable k) (f k a)) + (Ok Map.empty) listTraverse : (a -> IO b) -> List a -> IO (List b)