From a13975a4bbe7d71502c27663d6c5ecc4145b818f Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Sat, 9 Nov 2024 00:26:53 +0000 Subject: [PATCH 1/7] WIP elm-serialize --- bin/index.js | 8 +- elm.json | 5 +- review/src/ReviewConfig.elm | 7 +- src/Builder/BackgroundWriter.elm | 17 +- src/Builder/Build.elm | 203 +++++---- src/Builder/Deps/Registry.elm | 28 +- src/Builder/Deps/Solver.elm | 4 +- src/Builder/Elm/Details.elm | 270 +++++++----- src/Builder/Elm/Outline.elm | 18 + src/Builder/File.elm | 19 +- src/Builder/Generate.elm | 24 +- src/Builder/Http.elm | 7 + src/Builder/Reporting.elm | 202 +++------ src/Builder/Reporting/Exit.elm | 30 ++ src/Builder/Stuff.elm | 8 +- src/Compiler/AST/Canonical.elm | 156 ++++++- src/Compiler/AST/Optimized.elm | 327 ++++++++++++++ src/Compiler/AST/Utils/Binop.elm | 28 ++ src/Compiler/AST/Utils/Shader.elm | 7 + src/Compiler/Data/Index.elm | 7 + src/Compiler/Elm/Compiler/Type/Extract.elm | 7 + src/Compiler/Elm/Docs.elm | 7 + src/Compiler/Elm/Interface.elm | 81 ++++ src/Compiler/Elm/Kernel.elm | 42 ++ src/Compiler/Elm/ModuleName.elm | 18 + src/Compiler/Elm/Package.elm | 12 + src/Compiler/Elm/Version.elm | 35 +- src/Compiler/Optimize/DecisionTree.elm | 71 +++ src/Compiler/Reporting/Annotation.elm | 22 + src/Compiler/Reporting/Error.elm | 18 + src/Compiler/Serialize.elm | 34 ++ src/Compiler/Type/Solve.elm | 40 +- src/Compiler/Type/UnionFind.elm | 478 +++++++-------------- src/Data/IO.elm | 153 +++---- src/Terminal/Bump.elm | 2 +- src/Terminal/Diff.elm | 2 +- src/Terminal/Make.elm | 5 +- src/Terminal/Publish.elm | 4 +- src/Utils/Main.elm | 110 +++-- 39 files changed, 1637 insertions(+), 879 deletions(-) create mode 100644 src/Compiler/Serialize.elm diff --git a/bin/index.js b/bin/index.js index ac863c6dd..e5f636059 100755 --- a/bin/index.js +++ b/bin/index.js @@ -389,13 +389,13 @@ const io = { this.send({ index, value: which.sync(name, { nothrow: true }) }); }, replGetInputLine: function (index, prompt) { - rl.question(prompt, (answer) => { - this.send({ index, value: answer }); + rl.question(prompt, (value) => { + this.send({ index, value }); }); }, replGetInputLineWithInitial: function (index, prompt, left, right) { - rl.question(prompt + left + right, (answer) => { - this.send({ index, value: answer }); + rl.question(prompt + left + right, (value) => { + this.send({ index, value }); }); }, procWithCreateProcess: function (index, createProcess) { diff --git a/elm.json b/elm.json index 46c07ce3a..97501f22c 100644 --- a/elm.json +++ b/elm.json @@ -6,6 +6,7 @@ "elm-version": "0.19.1", "dependencies": { "direct": { + "MartinSStewart/elm-serialize": "1.3.1", "dasch/levenshtein": "1.0.3", "elm/core": "1.0.5", "elm/json": "1.1.3", @@ -23,6 +24,9 @@ }, "indirect": { "andre-dietrich/parser-combinators": "4.1.0", + "bburdette/toop": "1.2.0", + "danfishgold/base64-bytes": "1.1.0", + "elm/bytes": "1.0.8", "elm/parser": "1.1.0", "elm/regex": "1.0.0", "fredcy/elm-parseint": "2.0.1", @@ -35,7 +39,6 @@ "elm-explorations/test": "2.2.0" }, "indirect": { - "elm/bytes": "1.0.8", "elm/html": "1.0.0", "elm/random": "1.0.0", "elm/virtual-dom": "1.0.3" diff --git a/review/src/ReviewConfig.elm b/review/src/ReviewConfig.elm index a6ca4c0a7..344bcadd3 100644 --- a/review/src/ReviewConfig.elm +++ b/review/src/ReviewConfig.elm @@ -54,8 +54,9 @@ config = , NoUnused.Dependencies.rule -- , NoUnused.Exports.rule - -- , NoUnused.Parameters.rule - -- , NoUnused.Patterns.rule - -- , NoUnused.Variables.rule + , NoUnused.Parameters.rule + |> Rule.ignoreErrorsForFiles [ "src/Utils/Crash.elm" ] + , NoUnused.Patterns.rule + , NoUnused.Variables.rule , Simplify.rule Simplify.defaults ] diff --git a/src/Builder/BackgroundWriter.elm b/src/Builder/BackgroundWriter.elm index 94f4b0bf0..eb8de170a 100644 --- a/src/Builder/BackgroundWriter.elm +++ b/src/Builder/BackgroundWriter.elm @@ -8,6 +8,7 @@ import Builder.File as File import Data.IO as IO exposing (IO) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Main as Utils @@ -21,31 +22,31 @@ type Scope withScope : (Scope -> IO a) -> IO a withScope callback = - Utils.newMVar (Encode.list (\_ -> Encode.null)) [] + Utils.newMVar (Serialize.list Utils.mVarCodec) [] |> IO.bind (\workList -> callback (Scope workList) |> IO.bind (\result -> - Utils.takeMVar (Decode.list Utils.mVarDecoder) workList + Utils.takeMVar (Serialize.list Utils.mVarCodec) workList |> IO.bind (\mvars -> - Utils.listTraverse_ (Utils.takeMVar (Decode.succeed ())) mvars + Utils.listTraverse_ (Utils.takeMVar Serialize.unit) mvars |> IO.fmap (\_ -> result) ) ) ) -writeBinary : (a -> Encode.Value) -> Scope -> String -> a -> IO () -writeBinary encoder (Scope workList) path value = +writeBinary : Codec e a -> Scope -> String -> a -> IO () +writeBinary codec (Scope workList) path value = Utils.newEmptyMVar |> IO.bind (\mvar -> - Utils.forkIO (File.writeBinary encoder path value |> IO.bind (\_ -> Utils.putMVar (\_ -> Encode.object []) mvar ())) + Utils.forkIO (File.writeBinary codec path value |> IO.bind (\_ -> Utils.putMVar Serialize.unit mvar ())) |> IO.bind (\_ -> - Utils.takeMVar (Decode.list Utils.mVarDecoder) workList + Utils.takeMVar (Serialize.list Utils.mVarCodec) workList |> IO.bind (\oldWork -> let @@ -53,7 +54,7 @@ writeBinary encoder (Scope workList) path value = newWork = mvar :: oldWork in - Utils.putMVar (Encode.list Utils.mVarEncoder) workList newWork + Utils.putMVar (Serialize.list Utils.mVarCodec) workList newWork ) ) ) diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm index 3b0d7372b..bca6be70b 100644 --- a/src/Builder/Build.elm +++ b/src/Builder/Build.elm @@ -7,6 +7,7 @@ module Builder.Build exposing , Module(..) , ReplArtifacts(..) , Root(..) + , cachedInterfaceCodec , cachedInterfaceDecoder , fromExposed , fromPaths @@ -45,12 +46,14 @@ import Compiler.Reporting.Error.Docs as EDocs import Compiler.Reporting.Error.Import as Import import Compiler.Reporting.Error.Syntax as Syntax import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Serialize as S import Data.Graph as Graph import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) import Data.Set as EverySet import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils exposing (FilePath, MVar(..)) @@ -110,28 +113,28 @@ addRelative (AbsoluteSrcDir srcDir) path = described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow -} -fork : (a -> Encode.Value) -> IO a -> IO (MVar a) -fork encoder work = +fork : Codec e a -> IO a -> IO (MVar a) +fork codec work = Utils.newEmptyMVar |> IO.bind (\mvar -> - Utils.forkIO (IO.bind (Utils.putMVar encoder mvar) work) + Utils.forkIO (IO.bind (Utils.putMVar codec mvar) work) |> IO.fmap (\_ -> mvar) ) -forkWithKey : (k -> k -> Order) -> (b -> Encode.Value) -> (k -> a -> IO b) -> Dict k a -> IO (Dict k (MVar b)) -forkWithKey keyComparison encoder func dict = - Utils.mapTraverseWithKey keyComparison (\k v -> fork encoder (func k v)) dict +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 -- FROM EXPOSED -fromExposed : Decode.Decoder docs -> (docs -> Encode.Value) -> Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> IO (Result Exit.BuildProblem docs) -fromExposed docsDecoder docsEncoder style root details docsGoal ((NE.Nonempty e es) as exposed) = - Reporting.trackBuild docsDecoder docsEncoder style <| +fromExposed : Codec e docs -> Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> IO (Result Exit.BuildProblem docs) +fromExposed docsCodec style root details docsGoal ((NE.Nonempty e es) as exposed) = + Reporting.trackBuild docsCodec style <| \key -> makeEnv key root details |> IO.bind @@ -148,16 +151,16 @@ fromExposed docsDecoder docsEncoder style root details docsGoal ((NE.Nonempty e docsNeed = toDocsNeed docsGoal in - Map.fromKeysA compare (fork statusEncoder << crawlModule env mvar docsNeed) (e :: es) + Map.fromKeysA compare (fork statusCodec << crawlModule env mvar docsNeed) (e :: es) |> IO.bind (\roots -> - Utils.putMVar statusDictEncoder mvar roots + Utils.putMVar statusDictCodec mvar roots |> IO.bind (\_ -> - Utils.dictMapM_ (Utils.readMVar statusDecoder) roots + Utils.dictMapM_ (Utils.readMVar statusCodec) roots |> IO.bind (\_ -> - IO.bind (Utils.mapTraverse compare (Utils.readMVar statusDecoder)) (Utils.readMVar statusDictDecoder mvar) + IO.bind (Utils.mapTraverse compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec mvar) |> IO.bind (\statuses -> -- compile @@ -172,13 +175,13 @@ fromExposed docsDecoder docsEncoder style root details docsGoal ((NE.Nonempty e Utils.newEmptyMVar |> IO.bind (\rmvar -> - forkWithKey compare bResultEncoder (checkModule env foreigns rmvar) statuses + forkWithKey compare bResultCodec (checkModule env foreigns rmvar) statuses |> IO.bind (\resultMVars -> - Utils.putMVar dictRawMVarBResultEncoder rmvar resultMVars + Utils.putMVar dictRawMVarBResultCodec rmvar resultMVars |> IO.bind (\_ -> - Utils.mapTraverse compare (Utils.readMVar bResultDecoder) resultMVars + Utils.mapTraverse compare (Utils.readMVar bResultCodec) resultMVars |> IO.bind (\results -> writeDetails root details results @@ -219,7 +222,7 @@ type alias Dependencies = fromPaths : Reporting.Style -> FilePath -> Details.Details -> NE.Nonempty FilePath -> IO (Result Exit.BuildProblem Artifacts) fromPaths style root details paths = - Reporting.trackBuild artifactsDecoder artifactsEncoder style <| + Reporting.trackBuild artifactsCodec style <| \key -> makeEnv key root details |> IO.bind @@ -236,16 +239,16 @@ fromPaths style root details paths = Details.loadInterfaces root details |> IO.bind (\dmvar -> - Utils.newMVar statusDictEncoder Dict.empty + Utils.newMVar statusDictCodec Dict.empty |> IO.bind (\smvar -> - Utils.nonEmptyListTraverse (fork rootStatusEncoder << crawlRoot env smvar) lroots + Utils.nonEmptyListTraverse (fork rootStatusCodec << crawlRoot env smvar) lroots |> IO.bind (\srootMVars -> - Utils.nonEmptyListTraverse (Utils.readMVar rootStatusDecoder) srootMVars + Utils.nonEmptyListTraverse (Utils.readMVar rootStatusCodec) srootMVars |> IO.bind (\sroots -> - IO.bind (Utils.mapTraverse compare (Utils.readMVar statusDecoder)) (Utils.readMVar statusDictDecoder smvar) + IO.bind (Utils.mapTraverse compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec smvar) |> IO.bind (\statuses -> checkMidpointAndRoots dmvar statuses sroots @@ -260,22 +263,22 @@ fromPaths style root details paths = Utils.newEmptyMVar |> IO.bind (\rmvar -> - forkWithKey compare bResultEncoder (checkModule env foreigns rmvar) statuses + forkWithKey compare bResultCodec (checkModule env foreigns rmvar) statuses |> IO.bind (\resultsMVars -> - Utils.putMVar resultDictEncoder rmvar resultsMVars + Utils.putMVar resultDictCodec rmvar resultsMVars |> IO.bind (\_ -> - Utils.nonEmptyListTraverse (fork rootResultEncoder << checkRoot env resultsMVars) sroots + Utils.nonEmptyListTraverse (fork rootResultCodec << checkRoot env resultsMVars) sroots |> IO.bind (\rrootMVars -> - Utils.mapTraverse compare (Utils.readMVar bResultDecoder) resultsMVars + Utils.mapTraverse compare (Utils.readMVar bResultCodec) resultsMVars |> IO.bind (\results -> writeDetails root details results |> IO.bind (\_ -> - IO.fmap (toArtifacts env foreigns results) (Utils.nonEmptyListTraverse (Utils.readMVar rootResultDecoder) rrootMVars) + IO.fmap (toArtifacts env foreigns results) (Utils.nonEmptyListTraverse (Utils.readMVar rootResultCodec) rrootMVars) ) ) ) @@ -333,9 +336,9 @@ crawlDeps env mvar deps blockedValue = let crawlNew : ModuleName.Raw -> () -> IO (MVar Status) crawlNew name () = - fork statusEncoder (crawlModule env mvar (DocsNeed False) name) + fork statusCodec (crawlModule env mvar (DocsNeed False) name) in - Utils.takeMVar statusDictDecoder mvar + Utils.takeMVar statusDictCodec mvar |> IO.bind (\statusDict -> let @@ -350,10 +353,10 @@ crawlDeps env mvar deps blockedValue = Utils.mapTraverseWithKey compare crawlNew newsDict |> IO.bind (\statuses -> - Utils.putMVar statusDictEncoder mvar (Dict.union compare statuses statusDict) + Utils.putMVar statusDictCodec mvar (Dict.union compare statuses statusDict) |> IO.bind (\_ -> - Utils.dictMapM_ (Utils.readMVar statusDecoder) statuses + Utils.dictMapM_ (Utils.readMVar statusCodec) statuses |> IO.fmap (\_ -> blockedValue) ) ) @@ -488,7 +491,7 @@ checkModule : Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status checkModule ((Env _ root projectType _ _ _ _) as env) foreigns resultsMVar name status = case status of SCached ((Details.Local path time deps hasMain lastChange lastCompile) as local) -> - Utils.readMVar resultDictDecoder resultsMVar + Utils.readMVar resultDictCodec resultsMVar |> IO.bind (\results -> checkDeps root results deps lastCompile @@ -510,7 +513,7 @@ checkModule ((Env _ root projectType _ _ _ _) as env) foreigns resultsMVar name ) DepsSame _ _ -> - Utils.newMVar cachedInterfaceEncoder Unneeded + Utils.newMVar cachedInterfaceCodec Unneeded |> IO.fmap (\mvar -> RCached hasMain lastChange mvar @@ -537,7 +540,7 @@ checkModule ((Env _ root projectType _ _ _ _) as env) foreigns resultsMVar name ) SChanged ((Details.Local path time deps _ _ lastCompile) as local) source ((Src.Module _ _ _ imports _ _ _ _ _) as modul) docsNeed -> - Utils.readMVar resultDictDecoder resultsMVar + Utils.readMVar resultDictCodec resultsMVar |> IO.bind (\results -> checkDeps root results deps lastCompile @@ -619,7 +622,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 bResultDecoder (Utils.find dep results) + Utils.readMVar bResultCodec (Utils.find dep results) |> IO.bind (\result -> case result of @@ -711,10 +714,10 @@ toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems = loadInterfaces : FilePath -> List Dep -> List CDep -> IO (Maybe (Dict ModuleName.Raw I.Interface)) loadInterfaces root same cached = - Utils.listTraverse (fork maybeDepEncoder << loadInterface root) cached + Utils.listTraverse (fork maybeDepCodec << loadInterface root) cached |> IO.bind (\loading -> - Utils.listTraverse (Utils.readMVar maybeDepDecoder) loading + Utils.listTraverse (Utils.readMVar maybeDepCodec) loading |> IO.bind (\maybeLoaded -> case Utils.sequenceListMaybe maybeLoaded of @@ -729,29 +732,29 @@ loadInterfaces root same cached = loadInterface : FilePath -> CDep -> IO (Maybe Dep) loadInterface root ( name, ciMvar ) = - Utils.takeMVar cachedInterfaceDecoder ciMvar + Utils.takeMVar cachedInterfaceCodec ciMvar |> IO.bind (\cachedInterface -> case cachedInterface of Corrupted -> - Utils.putMVar cachedInterfaceEncoder ciMvar cachedInterface + Utils.putMVar cachedInterfaceCodec ciMvar cachedInterface |> IO.fmap (\_ -> Nothing) Loaded iface -> - Utils.putMVar cachedInterfaceEncoder ciMvar cachedInterface + Utils.putMVar cachedInterfaceCodec ciMvar cachedInterface |> IO.fmap (\_ -> Just ( name, iface )) Unneeded -> - File.readBinary I.interfaceDecoder (Stuff.elmi root name) + File.readBinary I.interfaceCodec (Stuff.elmi root name) |> IO.bind (\maybeIface -> case maybeIface of Nothing -> - Utils.putMVar cachedInterfaceEncoder ciMvar Corrupted + Utils.putMVar cachedInterfaceCodec ciMvar Corrupted |> IO.fmap (\_ -> Nothing) Just iface -> - Utils.putMVar cachedInterfaceEncoder ciMvar (Loaded iface) + Utils.putMVar cachedInterfaceCodec ciMvar (Loaded iface) |> IO.fmap (\_ -> Just ( name, iface )) ) ) @@ -765,7 +768,7 @@ checkMidpoint : MVar (Maybe Dependencies) -> Dict ModuleName.Raw Status -> IO (R checkMidpoint dmvar statuses = case checkForCycles statuses of Nothing -> - Utils.readMVar maybeDependenciesDecoder dmvar + Utils.readMVar maybeDependenciesCodec dmvar |> IO.fmap (\maybeForeigns -> case maybeForeigns of @@ -777,7 +780,7 @@ checkMidpoint dmvar statuses = ) Just (NE.Nonempty name names) -> - Utils.readMVar maybeDependenciesDecoder dmvar + Utils.readMVar maybeDependenciesCodec dmvar |> IO.fmap (\_ -> Err (Exit.BP_Cycle name names)) @@ -787,7 +790,7 @@ checkMidpointAndRoots dmvar statuses sroots = Nothing -> case checkUniqueRoots statuses sroots of Nothing -> - Utils.readMVar maybeDependenciesDecoder dmvar + Utils.readMVar maybeDependenciesCodec dmvar |> IO.bind (\maybeForeigns -> case maybeForeigns of @@ -799,11 +802,11 @@ checkMidpointAndRoots dmvar statuses sroots = ) Just problem -> - Utils.readMVar maybeDependenciesDecoder dmvar + Utils.readMVar maybeDependenciesCodec dmvar |> IO.fmap (\_ -> Err problem) Just (NE.Nonempty name names) -> - Utils.readMVar maybeDependenciesDecoder dmvar + Utils.readMVar maybeDependenciesCodec dmvar |> IO.fmap (\_ -> Err (Exit.BP_Cycle name names)) @@ -979,10 +982,10 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti elmi = Stuff.elmi root name in - File.writeBinary Opt.localGraphEncoder (Stuff.elmo root name) objects + File.writeBinary Opt.localGraphCodec (Stuff.elmo root name) objects |> IO.bind (\_ -> - File.readBinary I.interfaceDecoder elmi + File.readBinary I.interfaceCodec elmi |> IO.bind (\maybeOldi -> case maybeOldi of @@ -1001,7 +1004,7 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti ) else - File.writeBinary I.interfaceEncoder elmi iface + File.writeBinary I.interfaceCodec elmi iface |> IO.bind (\_ -> Reporting.report key Reporting.BDone @@ -1018,7 +1021,7 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti _ -> -- iface may be lazy still - File.writeBinary I.interfaceEncoder elmi iface + File.writeBinary I.interfaceCodec elmi iface |> IO.bind (\_ -> Reporting.report key Reporting.BDone @@ -1058,7 +1061,7 @@ projectTypeToPkg projectType = writeDetails : FilePath -> Details.Details -> Dict ModuleName.Raw BResult -> IO () writeDetails root (Details.Details time outline buildID locals foreigns extras) results = - File.writeBinary Details.detailsEncoder (Stuff.details root) <| + File.writeBinary Details.detailsCodec (Stuff.details root) <| Details.Details time outline buildID (Dict.foldr addNewLocal locals results) foreigns extras @@ -1291,13 +1294,13 @@ fromRepl root details source = deps = List.map Src.getImportName imports in - Utils.newMVar statusDictEncoder Dict.empty + Utils.newMVar statusDictCodec Dict.empty |> IO.bind (\mvar -> crawlDeps env mvar deps () |> IO.bind (\_ -> - IO.bind (Utils.mapTraverse compare (Utils.readMVar statusDecoder)) (Utils.readMVar statusDictDecoder mvar) + IO.bind (Utils.mapTraverse compare (Utils.readMVar statusCodec)) (Utils.readMVar statusDictCodec mvar) |> IO.bind (\statuses -> checkMidpoint dmvar statuses @@ -1311,13 +1314,13 @@ fromRepl root details source = Utils.newEmptyMVar |> IO.bind (\rmvar -> - forkWithKey compare bResultEncoder (checkModule env foreigns rmvar) statuses + forkWithKey compare bResultCodec (checkModule env foreigns rmvar) statuses |> IO.bind (\resultMVars -> - Utils.putMVar resultDictEncoder rmvar resultMVars + Utils.putMVar resultDictCodec rmvar resultMVars |> IO.bind (\_ -> - Utils.mapTraverse compare (Utils.readMVar bResultDecoder) resultMVars + Utils.mapTraverse compare (Utils.readMVar bResultCodec) resultMVars |> IO.bind (\results -> writeDetails root details results @@ -1422,10 +1425,10 @@ type RootLocation findRoots : Env -> NE.Nonempty FilePath -> IO (Result Exit.BuildProjectProblem (NE.Nonempty RootLocation)) findRoots env paths = - Utils.nonEmptyListTraverse (fork resultBuildProjectProblemRootInfoEncoder << getRootInfo env) paths + Utils.nonEmptyListTraverse (fork resultBuildProjectProblemRootInfoCodec << getRootInfo env) paths |> IO.bind (\mvars -> - Utils.nonEmptyListTraverse (Utils.readMVar resultBuildProjectProblemRootInfoDecoder) mvars + Utils.nonEmptyListTraverse (Utils.readMVar resultBuildProjectProblemRootInfoCodec) mvars |> IO.bind (\einfos -> IO.pure (Result.andThen checkRoots (Utils.sequenceNonemptyListResult einfos)) @@ -1599,13 +1602,13 @@ crawlRoot ((Env _ _ projectType _ buildID _ _) as env) mvar root = Utils.newEmptyMVar |> IO.bind (\statusMVar -> - Utils.takeMVar statusDictDecoder mvar + Utils.takeMVar statusDictCodec mvar |> IO.bind (\statusDict -> - Utils.putMVar statusDictEncoder mvar (Dict.insert compare name statusMVar statusDict) + Utils.putMVar statusDictCodec mvar (Dict.insert compare name statusMVar statusDict) |> IO.bind (\_ -> - IO.bind (Utils.putMVar statusEncoder statusMVar) (crawlModule env mvar (DocsNeed False) name) + IO.bind (Utils.putMVar statusCodec statusMVar) (crawlModule env mvar (DocsNeed False) name) |> IO.fmap (\_ -> SInside name) ) ) @@ -1833,9 +1836,9 @@ addOutside root modules = -- ENCODERS and DECODERS -dictRawMVarBResultEncoder : Dict ModuleName.Raw (MVar BResult) -> Encode.Value -dictRawMVarBResultEncoder = - E.assocListDict ModuleName.rawEncoder Utils.mVarEncoder +dictRawMVarBResultCodec : Codec e (Dict ModuleName.Raw (MVar BResult)) +dictRawMVarBResultCodec = + S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec bResultEncoder : BResult -> Encode.Value @@ -1945,14 +1948,14 @@ bResultDecoder = ) -statusDictEncoder : StatusDict -> Encode.Value -statusDictEncoder statusDict = - E.assocListDict ModuleName.rawEncoder Utils.mVarEncoder statusDict +bResultCodec : Codec e BResult +bResultCodec = + Debug.todo "bResultCodec" -statusDictDecoder : Decode.Decoder StatusDict -statusDictDecoder = - D.assocListDict compare ModuleName.rawDecoder Utils.mVarDecoder +statusDictCodec : Codec e StatusDict +statusDictCodec = + S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec statusEncoder : Status -> Encode.Value @@ -2037,6 +2040,11 @@ statusDecoder = ) +statusCodec : Codec e Status +statusCodec = + Debug.todo "statusCodec" + + rootStatusEncoder : RootStatus -> Encode.Value rootStatusEncoder rootStatus = case rootStatus of @@ -2084,14 +2092,14 @@ rootStatusDecoder = ) -resultDictEncoder : ResultDict -> Encode.Value -resultDictEncoder = - E.assocListDict ModuleName.rawEncoder Utils.mVarEncoder +rootStatusCodec : Codec e RootStatus +rootStatusCodec = + Debug.todo "rootStatusCodec" -resultDictDecoder : Decode.Decoder ResultDict -resultDictDecoder = - D.assocListDict compare ModuleName.rawDecoder Utils.mVarDecoder +resultDictCodec : Codec e ResultDict +resultDictCodec = + S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec rootResultEncoder : RootResult -> Encode.Value @@ -2149,6 +2157,11 @@ rootResultDecoder = ) +rootResultCodec : Codec e RootResult +rootResultCodec = + Debug.todo "rootResultCodec" + + maybeDepEncoder : Maybe Dep -> Encode.Value maybeDepEncoder = E.maybe depEncoder @@ -2159,6 +2172,11 @@ maybeDepDecoder = Decode.maybe depDecoder +maybeDepCodec : Codec e (Maybe Dep) +maybeDepCodec = + Serialize.maybe depCodec + + depEncoder : Dep -> Encode.Value depEncoder = E.jsonPair ModuleName.rawEncoder I.interfaceEncoder @@ -2169,9 +2187,14 @@ depDecoder = D.jsonPair ModuleName.rawDecoder I.interfaceDecoder -maybeDependenciesDecoder : Decode.Decoder (Maybe Dependencies) -maybeDependenciesDecoder = - Decode.maybe (D.assocListDict ModuleName.compareCanonical ModuleName.canonicalDecoder I.dependencyInterfaceDecoder) +depCodec : Codec e Dep +depCodec = + Debug.todo "depCodec" + + +maybeDependenciesCodec : Codec e (Maybe Dependencies) +maybeDependenciesCodec = + Serialize.maybe (S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec) resultBuildProjectProblemRootInfoEncoder : Result Exit.BuildProjectProblem RootInfo -> Encode.Value @@ -2184,6 +2207,11 @@ resultBuildProjectProblemRootInfoDecoder = D.result Exit.buildProjectProblemDecoder rootInfoDecoder +resultBuildProjectProblemRootInfoCodec : Codec e (Result Exit.BuildProjectProblem RootInfo) +resultBuildProjectProblemRootInfoCodec = + Serialize.result Exit.buildProjectProblemCodec rootInfoCodec + + cachedInterfaceEncoder : CachedInterface -> Encode.Value cachedInterfaceEncoder cachedInterface = case cachedInterface of @@ -2224,6 +2252,11 @@ cachedInterfaceDecoder = ) +cachedInterfaceCodec : Codec e CachedInterface +cachedInterfaceCodec = + Debug.todo "cachedInterfaceCodec" + + docsNeedEncoder : DocsNeed -> Encode.Value docsNeedEncoder (DocsNeed isNeeded) = Encode.bool isNeeded @@ -2254,6 +2287,11 @@ artifactsDecoder = (Decode.field "modules" (Decode.list moduleDecoder)) +artifactsCodec : Codec e Artifacts +artifactsCodec = + Debug.todo "artifactsCodec" + + dependenciesEncoder : Dependencies -> Encode.Value dependenciesEncoder = E.assocListDict ModuleName.canonicalEncoder I.dependencyInterfaceEncoder @@ -2363,6 +2401,11 @@ rootInfoDecoder = (Decode.field "location" rootLocationDecoder) +rootInfoCodec : Codec e RootInfo +rootInfoCodec = + Debug.todo "rootInfoCodec" + + rootLocationEncoder : RootLocation -> Encode.Value rootLocationEncoder rootLocation = case rootLocation of diff --git a/src/Builder/Deps/Registry.elm b/src/Builder/Deps/Registry.elm index b76af11bc..0d8e09640 100644 --- a/src/Builder/Deps/Registry.elm +++ b/src/Builder/Deps/Registry.elm @@ -23,10 +23,12 @@ import Compiler.Elm.Version as V import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P +import Compiler.Serialize as S import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -56,13 +58,23 @@ knownVersionsEncoder (KnownVersions version versions) = ] +knownVersionsCodec : Codec e KnownVersions +knownVersionsCodec = + Serialize.customType + (\knownVersionsCodecEncoder (KnownVersions version versions) -> + knownVersionsCodecEncoder version versions + ) + |> Serialize.variant2 KnownVersions V.jsonCodec (Serialize.list V.jsonCodec) + |> Serialize.finishCustomType + + -- READ read : Stuff.PackageCache -> IO (Maybe Registry) read cache = - File.readBinary registryDecoder (Stuff.registry cache) + File.readBinary registryCodec (Stuff.registry cache) @@ -86,7 +98,7 @@ fetch manager cache = path = Stuff.registry cache in - File.writeBinary registryEncoder path registry + File.writeBinary registryCodec path registry |> IO.fmap (\_ -> registry) @@ -144,7 +156,7 @@ update manager cache ((Registry size packages) as oldRegistry) = newRegistry = Registry newSize newPkgs in - File.writeBinary registryEncoder (Stuff.registry cache) newRegistry + File.writeBinary registryCodec (Stuff.registry cache) newRegistry |> IO.fmap (\_ -> newRegistry) @@ -263,3 +275,13 @@ registryEncoder (Registry size versions) = [ ( "size", Encode.int size ) , ( "packages", E.assocListDict Pkg.nameEncoder knownVersionsEncoder versions ) ] + + +registryCodec : Codec e Registry +registryCodec = + Serialize.customType + (\registryCodecEncoder (Registry size packages) -> + registryCodecEncoder size packages + ) + |> Serialize.variant2 Registry Serialize.int (S.assocListDict Pkg.compareName Pkg.nameCodec knownVersionsCodec) + |> Serialize.finishCustomType diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index 19ed2c638..3be35ef61 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -457,7 +457,7 @@ initEnv = Utils.newEmptyMVar |> IO.bind (\mvar -> - Utils.forkIO (IO.bind (Utils.putMVar Http.managerEncoder mvar) Http.getManager) + Utils.forkIO (IO.bind (Utils.putMVar Http.managerCodec mvar) Http.getManager) |> IO.bind (\_ -> Stuff.getPackageCache @@ -467,7 +467,7 @@ initEnv = (Registry.read cache |> IO.bind (\maybeRegistry -> - Utils.readMVar Http.managerDecoder mvar + Utils.readMVar Http.managerCodec mvar |> IO.bind (\manager -> case maybeRegistry of diff --git a/src/Builder/Elm/Details.elm b/src/Builder/Elm/Details.elm index 70a48c418..df3b6b463 100644 --- a/src/Builder/Elm/Details.elm +++ b/src/Builder/Elm/Details.elm @@ -7,6 +7,7 @@ module Builder.Elm.Details exposing , Local(..) , Status , ValidOutline(..) + , detailsCodec , detailsEncoder , load , loadInterfaces @@ -45,11 +46,13 @@ import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Parse.Module as Parse import Compiler.Reporting.Annotation as A +import Compiler.Serialize as S import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils exposing (FilePath, MVar) @@ -112,20 +115,20 @@ loadObjects : FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph)) loadObjects root (Details _ _ _ _ _ extras) = case extras of ArtifactsFresh _ o -> - Utils.newMVar (Utils.maybeEncoder Opt.globalGraphEncoder) (Just o) + Utils.newMVar (Serialize.maybe Opt.globalGraphCodec) (Just o) ArtifactsCached -> - fork (Utils.maybeEncoder Opt.globalGraphEncoder) (File.readBinary Opt.globalGraphDecoder (Stuff.objects root)) + fork (Serialize.maybe Opt.globalGraphCodec) (File.readBinary Opt.globalGraphCodec (Stuff.objects root)) loadInterfaces : FilePath -> Details -> IO (MVar (Maybe Interfaces)) loadInterfaces root (Details _ _ _ _ _ extras) = case extras of ArtifactsFresh i _ -> - Utils.newMVar (Utils.maybeEncoder interfacesEncoder) (Just i) + Utils.newMVar (Serialize.maybe interfacesCodec) (Just i) ArtifactsCached -> - fork (Utils.maybeEncoder interfacesEncoder) (File.readBinary interfacesDecoder (Stuff.interfaces root)) + fork (Serialize.maybe interfacesCodec) (File.readBinary interfacesCodec (Stuff.interfaces root)) @@ -164,7 +167,7 @@ load style scope root = File.getTime (root ++ "/elm.json") |> IO.bind (\newTime -> - File.readBinary detailsDecoder (Stuff.details root) + File.readBinary detailsCodec (Stuff.details root) |> IO.bind (\maybeDetails -> case maybeDetails of @@ -217,7 +220,7 @@ type Env initEnv : Reporting.DKey -> BW.Scope -> FilePath -> IO (Result Exit.Details ( Env, Outline.Outline )) initEnv key scope root = - fork resultRegistryProblemEnvEncoder Solver.initEnv + fork resultRegistryProblemEnvCodec Solver.initEnv |> IO.bind (\mvar -> Outline.read root @@ -228,7 +231,7 @@ initEnv key scope root = IO.pure (Err (Exit.DetailsBadOutline problem)) Ok outline -> - Utils.readMVar resultRegistryProblemEnvDecoder mvar + Utils.readMVar resultRegistryProblemEnvCodec mvar |> IO.fmap (\maybeEnv -> case maybeEnv of @@ -366,12 +369,12 @@ allowEqualDups _ v1 v2 = -- FORK -fork : (a -> Encode.Value) -> IO a -> IO (MVar a) -fork encoder work = +fork : Codec e a -> IO a -> IO (MVar a) +fork codec work = Utils.newEmptyMVar |> IO.bind (\mvar -> - Utils.forkIO (IO.bind (Utils.putMVar encoder mvar) work) + Utils.forkIO (IO.bind (Utils.putMVar codec mvar) work) |> IO.fmap (\_ -> mvar) ) @@ -388,13 +391,13 @@ verifyDependencies ((Env key scope root cache _ _ _) as env) time outline soluti |> IO.bind (\mvar -> Stuff.withRegistryLock cache - (Utils.mapTraverseWithKey Pkg.compareName (\k v -> fork depEncoder (verifyDep env mvar solution k v)) solution) + (Utils.mapTraverseWithKey Pkg.compareName (\k v -> fork depCodec (verifyDep env mvar solution k v)) solution) |> IO.bind (\mvars -> - Utils.putMVar dictNameMVarDepEncoder mvar mvars + Utils.putMVar dictNameMVarDepCodec mvar mvars |> IO.bind (\_ -> - Utils.mapTraverse Pkg.compareName (Utils.readMVar depDecoder) mvars + Utils.mapTraverse Pkg.compareName (Utils.readMVar depCodec) mvars |> IO.bind (\deps -> case Utils.sequenceDictResult Pkg.compareName deps of @@ -426,9 +429,9 @@ verifyDependencies ((Env key scope root cache _ _ _) as env) time outline soluti details = Details time outline 0 Dict.empty foreigns (ArtifactsFresh ifaces objs) in - BW.writeBinary Opt.globalGraphEncoder scope (Stuff.objects root) objs - |> IO.bind (\_ -> BW.writeBinary interfacesEncoder scope (Stuff.interfaces root) ifaces) - |> IO.bind (\_ -> BW.writeBinary detailsEncoder scope (Stuff.details root) details) + BW.writeBinary Opt.globalGraphCodec scope (Stuff.objects root) objs + |> IO.bind (\_ -> BW.writeBinary interfacesCodec scope (Stuff.interfaces root) ifaces) + |> IO.bind (\_ -> BW.writeBinary detailsCodec scope (Stuff.details root) details) |> IO.fmap (\_ -> Ok details) ) ) @@ -501,7 +504,7 @@ verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg ((Solver.Details Reporting.report key Reporting.DCached |> IO.bind (\_ -> - File.readBinary artifactCacheDecoder (Stuff.package cache pkg vsn ++ "/artifacts.json") + File.readBinary artifactCacheCodec (Stuff.package cache pkg vsn ++ "/artifacts.json") |> IO.bind (\maybeCache -> case maybeCache of @@ -568,10 +571,10 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = |> IO.fmap (\_ -> Err (Just (Exit.BD_BadBuild pkg vsn f))) Ok (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) -> - Utils.readMVar dictPkgNameMVarDepDecoder depsMVar + Utils.readMVar dictPkgNameMVarDepCodec depsMVar |> IO.bind (\allDeps -> - Utils.mapTraverse Pkg.compareName (Utils.readMVar depDecoder) (Dict.intersection allDeps deps) + Utils.mapTraverse Pkg.compareName (Utils.readMVar depCodec) (Dict.intersection allDeps deps) |> IO.bind (\directDeps -> case Utils.sequenceDictResult Pkg.compareName directDeps of @@ -599,12 +602,12 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = Utils.newEmptyMVar |> IO.bind (\mvar -> - Utils.mapTraverseWithKey compare (always << fork (E.maybe statusEncoder) << crawlModule foreignDeps mvar pkg src docsStatus) exposedDict + Utils.mapTraverseWithKey compare (always << fork (Serialize.maybe statusCodec) << crawlModule foreignDeps mvar pkg src docsStatus) exposedDict |> IO.bind (\mvars -> - Utils.putMVar statusDictEncoder mvar mvars - |> IO.bind (\_ -> Utils.dictMapM_ (Utils.readMVar (Decode.maybe statusDecoder)) mvars) - |> IO.bind (\_ -> IO.bind (Utils.mapTraverse compare (Utils.readMVar (Decode.maybe statusDecoder))) (Utils.readMVar statusDictDecoder mvar)) + 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 (\maybeStatuses -> case Utils.sequenceDictMaybe compare maybeStatuses of @@ -616,11 +619,11 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = Utils.newEmptyMVar |> IO.bind (\rmvar -> - Utils.mapTraverse compare (fork (E.maybe dResultEncoder) << compile pkg rmvar) statuses + Utils.mapTraverse compare (fork (Serialize.maybe dResultCodec) << compile pkg rmvar) statuses |> IO.bind (\rmvars -> - Utils.putMVar dictRawMVarMaybeDResultEncoder rmvar rmvars - |> IO.bind (\_ -> Utils.mapTraverse compare (Utils.readMVar (Decode.maybe dResultDecoder)) rmvars) + Utils.putMVar dictRawMVarMaybeDResultCodec rmvar rmvars + |> IO.bind (\_ -> Utils.mapTraverse compare (Utils.readMVar (Serialize.maybe dResultCodec)) rmvars) |> IO.bind (\maybeResults -> case Utils.sequenceDictMaybe compare maybeResults of @@ -651,7 +654,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = EverySet.insert (\_ _ -> EQ) f fs in writeDocs cache pkg vsn docsStatus results - |> IO.bind (\_ -> File.writeBinary artifactCacheEncoder path (ArtifactCache fingerprints artifacts)) + |> IO.bind (\_ -> File.writeBinary artifactCacheCodec path (ArtifactCache fingerprints artifacts)) |> IO.bind (\_ -> Reporting.report key Reporting.DBuilt) |> IO.fmap (\_ -> Ok artifacts) ) @@ -836,7 +839,7 @@ 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 foreignDeps mvar pkg src imports = - Utils.takeMVar statusDictDecoder mvar + Utils.takeMVar statusDictCodec mvar |> IO.bind (\statusDict -> let @@ -848,11 +851,11 @@ crawlImports foreignDeps mvar pkg src imports = news = Dict.diff deps statusDict in - Utils.mapTraverseWithKey compare (always << fork (E.maybe statusEncoder) << crawlModule foreignDeps mvar pkg src DocsNotNeeded) news + Utils.mapTraverseWithKey compare (always << fork (Serialize.maybe statusCodec) << crawlModule foreignDeps mvar pkg src DocsNotNeeded) news |> IO.bind (\mvars -> - Utils.putMVar statusDictEncoder mvar (Dict.union compare mvars statusDict) - |> IO.bind (\_ -> Utils.dictMapM_ (Utils.readMVar (Decode.maybe statusDecoder)) mvars) + Utils.putMVar statusDictCodec mvar (Dict.union compare mvars statusDict) + |> IO.bind (\_ -> Utils.dictMapM_ (Utils.readMVar (Serialize.maybe statusCodec)) mvars) |> IO.fmap (\_ -> deps) ) ) @@ -911,10 +914,10 @@ compile : Pkg.Name -> MVar (Dict ModuleName.Raw (MVar (Maybe DResult))) -> Statu compile pkg mvar status = case status of SLocal docsStatus deps modul -> - Utils.readMVar moduleNameRawMVarMaybeDResultDecoder mvar + Utils.readMVar moduleNameRawMVarMaybeDResultCodec mvar |> IO.bind (\resultsDict -> - Utils.mapTraverse compare (Utils.readMVar (Decode.maybe dResultDecoder)) (Dict.intersection resultsDict deps) + Utils.mapTraverse compare (Utils.readMVar (Serialize.maybe dResultCodec)) (Dict.intersection resultsDict deps) |> IO.bind (\maybeResults -> case Utils.sequenceDictMaybe compare maybeResults of @@ -1095,15 +1098,20 @@ detailsEncoder (Details oldTime outline buildID locals foreigns extras) = ] -detailsDecoder : Decode.Decoder Details -detailsDecoder = - Decode.map6 Details - (Decode.field "oldTime" File.timeDecoder) - (Decode.field "outline" validOutlineDecoder) - (Decode.field "buildID" Decode.int) - (Decode.field "locals" (D.assocListDict compare ModuleName.rawDecoder localDecoder)) - (Decode.field "foreigns" (D.assocListDict compare ModuleName.rawDecoder foreignDecoder)) - (Decode.field "extras" extrasDecoder) +detailsCodec : Codec (Serialize.Error e) Details +detailsCodec = + Serialize.customType + (\detailsCodecEncoder (Details oldTime outline buildID locals foreigns extras) -> + detailsCodecEncoder oldTime outline buildID locals foreigns extras + ) + |> Serialize.variant6 Details + File.timeCodec + validOutlineCodec + Serialize.int + (S.assocListDict compare ModuleName.rawCodec localCodec) + (S.assocListDict compare ModuleName.rawCodec foreignCodec) + extrasCodec + |> Serialize.finishCustomType interfacesEncoder : Interfaces -> Encode.Value @@ -1111,9 +1119,9 @@ interfacesEncoder = E.assocListDict ModuleName.canonicalEncoder I.dependencyInterfaceEncoder -interfacesDecoder : Decode.Decoder Interfaces -interfacesDecoder = - D.assocListDict ModuleName.compareCanonical ModuleName.canonicalDecoder I.dependencyInterfaceDecoder +interfacesCodec : Codec e Interfaces +interfacesCodec = + S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec resultRegistryProblemEnvEncoder : Result Exit.RegistryProblem Solver.Env -> Encode.Value @@ -1126,9 +1134,9 @@ resultRegistryProblemEnvDecoder = D.result Exit.registryProblemDecoder Solver.envDecoder -depEncoder : Dep -> Encode.Value -depEncoder dep = - E.result (E.maybe Exit.detailsBadDepEncoder) artifactsEncoder dep +resultRegistryProblemEnvCodec : Codec e (Result Exit.RegistryProblem Solver.Env) +resultRegistryProblemEnvCodec = + Debug.todo "resultRegistryProblemEnvCodec" depDecoder : Decode.Decoder Dep @@ -1136,13 +1144,9 @@ depDecoder = D.result (Decode.maybe Exit.detailsBadDepDecoder) artifactsDecoder -artifactsEncoder : Artifacts -> Encode.Value -artifactsEncoder (Artifacts ifaces objects) = - Encode.object - [ ( "type", Encode.string "Artifacts" ) - , ( "ifaces", E.assocListDict ModuleName.rawEncoder I.dependencyInterfaceEncoder ifaces ) - , ( "objects", Opt.globalGraphEncoder objects ) - ] +depCodec : Codec e Dep +depCodec = + Serialize.result (Serialize.maybe Exit.detailsBadDepCodec) artifactsCodec artifactsDecoder : Decode.Decoder Artifacts @@ -1152,25 +1156,34 @@ artifactsDecoder = (Decode.field "objects" Opt.globalGraphDecoder) +artifactsCodec : Codec e Artifacts +artifactsCodec = + Serialize.customType + (\artifactsCodecEncoder (Artifacts ifaces objects) -> + artifactsCodecEncoder ifaces objects + ) + |> Serialize.variant2 Artifacts (S.assocListDict compare ModuleName.rawCodec I.dependencyInterfaceCodec) Opt.globalGraphCodec + |> Serialize.finishCustomType + + dictNameMVarDepEncoder : Dict Pkg.Name (MVar Dep) -> Encode.Value dictNameMVarDepEncoder = E.assocListDict Pkg.nameEncoder Utils.mVarEncoder -artifactCacheEncoder : ArtifactCache -> Encode.Value -artifactCacheEncoder (ArtifactCache fingerprints artifacts) = - Encode.object - [ ( "type", Encode.string "ArtifactCache" ) - , ( "fingerprints", E.everySet fingerprintEncoder fingerprints ) - , ( "artifacts", artifactsEncoder artifacts ) - ] +dictNameMVarDepCodec : Codec e (Dict Pkg.Name (MVar Dep)) +dictNameMVarDepCodec = + Debug.todo "dictNameMVarDepCodec" -artifactCacheDecoder : Decode.Decoder ArtifactCache -artifactCacheDecoder = - Decode.map2 ArtifactCache - (Decode.field "fingerprints" (D.everySet (\_ _ -> EQ) fingerprintDecoder)) - (Decode.field "artifacts" artifactsDecoder) +artifactCacheCodec : Codec e ArtifactCache +artifactCacheCodec = + Serialize.customType + (\artifactCacheCodecEncoder (ArtifactCache fingerprints artifacts) -> + artifactCacheCodecEncoder fingerprints artifacts + ) + |> Serialize.variant2 ArtifactCache (S.everySet (\_ _ -> EQ) fingerprintCodec) artifactsCodec + |> Serialize.finishCustomType dictPkgNameMVarDepDecoder : Decode.Decoder (Dict Pkg.Name (MVar Dep)) @@ -1178,6 +1191,11 @@ dictPkgNameMVarDepDecoder = D.assocListDict Pkg.compareName Pkg.nameDecoder Utils.mVarDecoder +dictPkgNameMVarDepCodec : Codec e (Dict Pkg.Name (MVar Dep)) +dictPkgNameMVarDepCodec = + Debug.todo "dictPkgNameMVarDepCodec" + + statusEncoder : Status -> Encode.Value statusEncoder status = case status of @@ -1233,16 +1251,31 @@ statusDecoder = ) +statusCodec : Codec e Status +statusCodec = + Debug.todo "statusCodec" + + dictRawMVarMaybeDResultEncoder : Dict ModuleName.Raw (MVar (Maybe DResult)) -> Encode.Value dictRawMVarMaybeDResultEncoder = E.assocListDict ModuleName.rawEncoder Utils.mVarEncoder +dictRawMVarMaybeDResultCodec : Codec e (Dict ModuleName.Raw (MVar (Maybe DResult))) +dictRawMVarMaybeDResultCodec = + Debug.todo "dictRawMVarMaybeDResultCodec" + + moduleNameRawMVarMaybeDResultDecoder : Decode.Decoder (Dict ModuleName.Raw (MVar (Maybe DResult))) moduleNameRawMVarMaybeDResultDecoder = D.assocListDict compare ModuleName.rawDecoder Utils.mVarDecoder +moduleNameRawMVarMaybeDResultCodec : Codec e (Dict ModuleName.Raw (MVar (Maybe DResult))) +moduleNameRawMVarMaybeDResultCodec = + Debug.todo "moduleNameRawMVarMaybeDResultCodec" + + dResultEncoder : DResult -> Encode.Value dResultEncoder dResult = case dResult of @@ -1298,6 +1331,11 @@ dResultDecoder = ) +dResultCodec : Codec e DResult +dResultCodec = + Debug.todo "dResultCodec" + + statusDictEncoder : StatusDict -> Encode.Value statusDictEncoder statusDict = E.assocListDict ModuleName.rawEncoder Utils.mVarEncoder statusDict @@ -1308,6 +1346,11 @@ statusDictDecoder = D.assocListDict compare ModuleName.rawDecoder Utils.mVarDecoder +statusDictCodec : Codec e StatusDict +statusDictCodec = + Debug.todo "statusDictCodec" + + localEncoder : Local -> Encode.Value localEncoder (Local path time deps hasMain lastChange lastCompile) = Encode.object @@ -1332,6 +1375,16 @@ localDecoder = (Decode.field "lastCompile" Decode.int) +localCodec : Codec e Local +localCodec = + Serialize.customType + (\localCodecEncoder (Local path time deps hasMain lastChange lastCompile) -> + localCodecEncoder path time deps hasMain lastChange lastCompile + ) + |> Serialize.variant6 Local Serialize.string File.timeCodec (Serialize.list ModuleName.rawCodec) Serialize.bool Serialize.int Serialize.int + |> Serialize.finishCustomType + + validOutlineEncoder : ValidOutline -> Encode.Value validOutlineEncoder validOutline = case validOutline of @@ -1350,24 +1403,20 @@ validOutlineEncoder validOutline = ] -validOutlineDecoder : Decode.Decoder ValidOutline -validOutlineDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ValidApp" -> - Decode.map ValidApp (Decode.field "srcDirs" (D.nonempty Outline.srcDirDecoder)) +validOutlineCodec : Codec (Serialize.Error e) ValidOutline +validOutlineCodec = + Serialize.customType + (\validAppEncoder validPkgEncoder validOutline -> + case validOutline of + ValidApp srcDirs -> + validAppEncoder srcDirs - "ValidPkg" -> - Decode.map3 ValidPkg - (Decode.field "pkg" Pkg.nameDecoder) - (Decode.field "exposedList" (Decode.list ModuleName.rawDecoder)) - (Decode.field "exactDeps" (D.assocListDict Pkg.compareName Pkg.nameDecoder V.versionDecoder)) - - _ -> - Decode.fail ("Failed to decode ValidOutline's type: " ++ type_) - ) + ValidPkg pkg exposedList exactDeps -> + 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.finishCustomType foreignEncoder : Foreign -> Encode.Value @@ -1379,11 +1428,14 @@ foreignEncoder (Foreign dep deps) = ] -foreignDecoder : Decode.Decoder Foreign -foreignDecoder = - Decode.map2 Foreign - (Decode.field "dep" Pkg.nameDecoder) - (Decode.field "deps" (Decode.list Pkg.nameDecoder)) +foreignCodec : Codec e Foreign +foreignCodec = + Serialize.customType + (\foreignCodecEncoder (Foreign dep deps) -> + foreignCodecEncoder dep deps + ) + |> Serialize.variant2 Foreign Pkg.nameCodec (Serialize.list Pkg.nameCodec) + |> Serialize.finishCustomType extrasEncoder : Extras -> Encode.Value @@ -1402,33 +1454,25 @@ extrasEncoder extras = ] -extrasDecoder : Decode.Decoder Extras -extrasDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ArtifactsCached" -> - Decode.succeed ArtifactsCached - - "ArtifactsFresh" -> - Decode.map2 ArtifactsFresh - (Decode.field "ifaces" interfacesDecoder) - (Decode.field "objs" Opt.globalGraphDecoder) +extrasCodec : Codec e Extras +extrasCodec = + Serialize.customType + (\artifactsCachedEncoder artifactsFreshEncoder extras -> + case extras of + ArtifactsCached -> + artifactsCachedEncoder - _ -> - Decode.fail ("Failed to decode Extras' type: " ++ type_) - ) - - -fingerprintEncoder : Fingerprint -> Encode.Value -fingerprintEncoder = - E.assocListDict Pkg.nameEncoder V.versionEncoder + ArtifactsFresh ifaces objs -> + artifactsFreshEncoder ifaces objs + ) + |> Serialize.variant0 ArtifactsCached + |> Serialize.variant2 ArtifactsFresh interfacesCodec Opt.globalGraphCodec + |> Serialize.finishCustomType -fingerprintDecoder : Decode.Decoder Fingerprint -fingerprintDecoder = - D.assocListDict Pkg.compareName Pkg.nameDecoder V.versionDecoder +fingerprintCodec : Codec e Fingerprint +fingerprintCodec = + S.assocListDict Pkg.compareName Pkg.nameCodec V.versionCodec docsStatusEncoder : DocsStatus -> Encode.Value diff --git a/src/Builder/Elm/Outline.elm b/src/Builder/Elm/Outline.elm index b7b6b952a..f2fe1e541 100644 --- a/src/Builder/Elm/Outline.elm +++ b/src/Builder/Elm/Outline.elm @@ -9,6 +9,7 @@ module Builder.Elm.Outline exposing , defaultSummary , flattenExposed , read + , srcDirCodec , srcDirDecoder , srcDirEncoder , write @@ -31,6 +32,7 @@ import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Main as Utils exposing (FilePath) @@ -452,3 +454,19 @@ srcDirDecoder = _ -> Decode.fail ("Failed to decode SrcDir's type: " ++ type_) ) + + +srcDirCodec : Codec e SrcDir +srcDirCodec = + Serialize.customType + (\absoluteSrcDirEncoder relativeSrcDirEncoder srcDir -> + case srcDir of + AbsoluteSrcDir dir -> + absoluteSrcDirEncoder dir + + RelativeSrcDir dir -> + relativeSrcDirEncoder dir + ) + |> Serialize.variant1 AbsoluteSrcDir Serialize.string + |> Serialize.variant1 RelativeSrcDir Serialize.string + |> Serialize.finishCustomType diff --git a/src/Builder/File.elm b/src/Builder/File.elm index 8920feddd..4720a2b68 100644 --- a/src/Builder/File.elm +++ b/src/Builder/File.elm @@ -5,6 +5,7 @@ module Builder.File exposing , readBinary , readUtf8 , remove + , timeCodec , timeDecoder , timeEncoder , writeBinary @@ -17,6 +18,7 @@ module Builder.File exposing import Data.IO as IO exposing (IO) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Time import Utils.Main as Utils exposing (FilePath, ZipArchive, ZipEntry) @@ -43,24 +45,24 @@ zeroTime = -- BINARY -writeBinary : (a -> Encode.Value) -> FilePath -> a -> IO () -writeBinary encoder path value = +writeBinary : Codec e a -> FilePath -> a -> IO () +writeBinary codec path value = let dir : FilePath dir = Utils.fpDropFileName path in Utils.dirCreateDirectoryIfMissing True dir - |> IO.bind (\_ -> Utils.binaryEncodeFile encoder path value) + |> IO.bind (\_ -> Utils.binaryEncodeFile codec path value) -readBinary : Decode.Decoder a -> FilePath -> IO (Maybe a) -readBinary decoder path = +readBinary : Codec e a -> FilePath -> IO (Maybe a) +readBinary codec path = Utils.dirDoesFileExist path |> IO.bind (\pathExists -> if pathExists then - Utils.binaryDecodeFileOrFail decoder path + Utils.binaryDecodeFileOrFail codec path |> IO.bind (\result -> case result of @@ -195,3 +197,8 @@ timeEncoder (Time posix) = timeDecoder : Decode.Decoder Time timeDecoder = Decode.map (Time << Time.millisToPosix) Decode.int + + +timeCodec : Codec e Time +timeCodec = + Serialize.int |> Serialize.map (Time << Time.millisToPosix) (\(Time posix) -> Time.posixToMillis posix) diff --git a/src/Builder/Generate.elm b/src/Builder/Generate.elm index fed856730..dcda430fa 100644 --- a/src/Builder/Generate.elm +++ b/src/Builder/Generate.elm @@ -24,7 +24,7 @@ import Compiler.Generate.Mode as Mode import Compiler.Nitpick.Debug as Nitpick import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode +import Serialize import Utils.Main as Utils exposing (FilePath, MVar) @@ -196,14 +196,14 @@ loadObject : FilePath -> Build.Module -> IO ( ModuleName.Raw, MVar (Maybe Opt.Lo loadObject root modul = case modul of Build.Fresh name _ graph -> - Utils.newMVar (Utils.maybeEncoder Opt.localGraphEncoder) (Just graph) + Utils.newMVar (Serialize.maybe Opt.localGraphCodec) (Just graph) |> IO.fmap (\mvar -> ( name, mvar )) Build.Cached name _ _ -> Utils.newEmptyMVar |> IO.bind (\mvar -> - Utils.forkIO (IO.bind (Utils.putMVar (Utils.maybeEncoder Opt.localGraphEncoder) mvar) (File.readBinary Opt.localGraphDecoder (Stuff.elmo root name))) + Utils.forkIO (IO.bind (Utils.putMVar (Serialize.maybe Opt.localGraphCodec) mvar) (File.readBinary Opt.localGraphCodec (Stuff.elmo root name))) |> IO.fmap (\_ -> ( name, mvar )) ) @@ -219,10 +219,10 @@ type Objects finalizeObjects : LoadingObjects -> Task Objects finalizeObjects (LoadingObjects mvar mvars) = Task.eio identity - (Utils.readMVar (Decode.maybe Opt.globalGraphDecoder) mvar + (Utils.readMVar (Serialize.maybe Opt.globalGraphCodec) mvar |> IO.bind (\result -> - Utils.mapTraverse compare (Utils.readMVar (Decode.maybe Opt.localGraphDecoder)) mvars + Utils.mapTraverse compare (Utils.readMVar (Serialize.maybe Opt.localGraphCodec)) mvars |> IO.fmap (\results -> case Maybe.map2 Objects result (Utils.sequenceDictMaybe compare results) of @@ -256,7 +256,7 @@ loadTypes root ifaces modules = foreigns = Extract.mergeMany (Dict.values (Dict.map Extract.fromDependencyInterface ifaces)) in - Utils.listTraverse (Utils.readMVar (Decode.maybe Extract.typesDecoder)) mvars + Utils.listTraverse (Utils.readMVar (Serialize.maybe Extract.typesCodec)) mvars |> IO.fmap (\results -> case Utils.sequenceListMaybe results of @@ -274,10 +274,10 @@ loadTypesHelp : FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types)) loadTypesHelp root modul = case modul of Build.Fresh name iface _ -> - Utils.newMVar (Utils.maybeEncoder Extract.typesEncoder) (Just (Extract.fromInterface name iface)) + Utils.newMVar (Serialize.maybe Extract.typesCodec) (Just (Extract.fromInterface name iface)) Build.Cached name _ ciMVar -> - Utils.readMVar Build.cachedInterfaceDecoder ciMVar + Utils.readMVar Build.cachedInterfaceCodec ciMVar |> IO.bind (\cachedInterface -> case cachedInterface of @@ -286,18 +286,18 @@ loadTypesHelp root modul = |> IO.bind (\mvar -> Utils.forkIO - (File.readBinary I.interfaceDecoder (Stuff.elmi root name) + (File.readBinary I.interfaceCodec (Stuff.elmi root name) |> IO.bind (\maybeIface -> - Utils.putMVar (Utils.maybeEncoder Extract.typesEncoder) mvar (Maybe.map (Extract.fromInterface name) maybeIface) + Utils.putMVar (Serialize.maybe Extract.typesCodec) mvar (Maybe.map (Extract.fromInterface name) maybeIface) ) ) |> IO.fmap (\_ -> mvar) ) Build.Loaded iface -> - Utils.newMVar (Utils.maybeEncoder Extract.typesEncoder) (Just (Extract.fromInterface name iface)) + Utils.newMVar (Serialize.maybe Extract.typesCodec) (Just (Extract.fromInterface name iface)) Build.Corrupted -> - Utils.newMVar (Utils.maybeEncoder Extract.typesEncoder) Nothing + Utils.newMVar (Serialize.maybe Extract.typesCodec) Nothing ) diff --git a/src/Builder/Http.elm b/src/Builder/Http.elm index 95b92e488..9bffb3e92 100644 --- a/src/Builder/Http.elm +++ b/src/Builder/Http.elm @@ -12,6 +12,7 @@ module Builder.Http exposing , getArchive , getManager , jsonPart + , managerCodec , managerDecoder , managerEncoder , post @@ -26,6 +27,7 @@ import Compiler.Elm.Version as V import Data.IO as IO exposing (IO) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Url.Builder import Utils.Main as Utils exposing (SomeException) @@ -57,6 +59,11 @@ managerDecoder = ) +managerCodec : Codec e Manager +managerCodec = + Debug.todo "managerCodec" + + getManager : IO Manager getManager = -- TODO newManager tlsManagerSettings diff --git a/src/Builder/Reporting.elm b/src/Builder/Reporting.elm index b9b527da5..e41b67785 100644 --- a/src/Builder/Reporting.elm +++ b/src/Builder/Reporting.elm @@ -24,14 +24,12 @@ import Compiler.Data.NonEmptyList as NE import Compiler.Elm.ModuleName as ModuleName import Compiler.Elm.Package as Pkg import Compiler.Elm.Version as V -import Compiler.Json.Decode as DecodeX import Compiler.Json.Encode as Encode import Compiler.Reporting.Doc as D import Data.IO as IO exposing (IO) -import Json.Decode as Decode -import Json.Encode as CoreEncode import Prelude -import Utils.Main as Utils exposing (AsyncException(..), Chan, MVar) +import Serialize exposing (Codec) +import Utils.Main as Utils exposing (Chan, MVar) @@ -56,7 +54,7 @@ json = terminal : IO Style terminal = - IO.fmap Terminal (Utils.newMVar (\_ -> CoreEncode.bool True) ()) + IO.fmap Terminal (Utils.newMVar Serialize.unit ()) @@ -99,7 +97,7 @@ attemptWithStyle style toReport work = |> IO.bind (\_ -> Utils.exitFailure) Terminal mvar -> - Utils.readMVar (Decode.map (\_ -> ()) Decode.bool) mvar + Utils.readMVar Serialize.unit mvar |> IO.bind (\_ -> Exit.toStderr (toReport x)) |> IO.bind (\_ -> Utils.exitFailure) ) @@ -208,25 +206,25 @@ trackDetails style callback = callback (Key (\_ -> IO.pure ())) Terminal mvar -> - Utils.newChan Utils.mVarEncoder + Utils.newChan Utils.mVarCodec |> IO.bind (\chan -> Utils.forkIO - (Utils.takeMVar (Decode.succeed ()) mvar + (Utils.takeMVar Serialize.unit mvar |> IO.bind (\_ -> detailsLoop chan (DState 0 0 0 0 0 0 0)) - |> IO.bind (\_ -> Utils.putMVar (\_ -> CoreEncode.bool True) mvar ()) + |> IO.bind (\_ -> Utils.putMVar Serialize.unit mvar ()) ) |> IO.bind (\_ -> let - encoder : Maybe DMsg -> CoreEncode.Value - encoder = - Encode.maybe dMsgEncoder + codec : Codec e (Maybe DMsg) + codec = + Serialize.maybe dMsgCodec in - callback (Key (Utils.writeChan encoder chan << Just)) + callback (Key (Utils.writeChan codec chan << Just)) |> IO.bind (\answer -> - Utils.writeChan encoder chan Nothing + Utils.writeChan codec chan Nothing |> IO.fmap (\_ -> answer) ) ) @@ -235,7 +233,7 @@ trackDetails style callback = detailsLoop : Chan (Maybe DMsg) -> DState -> IO () detailsLoop chan ((DState total _ _ _ _ built _) as state) = - Utils.readChan (Decode.maybe dMsgDecoder) chan + Utils.readChan (Serialize.maybe dMsgCodec) chan |> IO.bind (\msg -> case msg of @@ -369,8 +367,8 @@ type alias BResult a = Result Exit.BuildProblem a -trackBuild : Decode.Decoder a -> (a -> CoreEncode.Value) -> Style -> (BKey -> IO (BResult a)) -> IO (BResult a) -trackBuild decoder encoder style callback = +trackBuild : Codec e a -> Style -> (BKey -> IO (BResult a)) -> IO (BResult a) +trackBuild codec style callback = case style of Silent -> callback (Key (\_ -> IO.pure ())) @@ -379,24 +377,24 @@ trackBuild decoder encoder style callback = callback (Key (\_ -> IO.pure ())) Terminal mvar -> - Utils.newChan Utils.mVarEncoder + Utils.newChan Utils.mVarCodec |> IO.bind (\chan -> let - chanEncoder : Result BMsg (BResult a) -> CoreEncode.Value - chanEncoder = - Encode.result bMsgEncoder (bResultEncoder encoder) + chanCodec : Codec e (Result BMsg (BResult a)) + chanCodec = + Serialize.result bMsgCodec (bResultCodec codec) in Utils.forkIO - (Utils.takeMVar (Decode.succeed ()) mvar + (Utils.takeMVar Serialize.unit mvar |> IO.bind (\_ -> putStrFlush "Compiling ...") - |> IO.bind (\_ -> buildLoop decoder chan 0) - |> IO.bind (\_ -> Utils.putMVar (\_ -> CoreEncode.bool True) mvar ()) + |> IO.bind (\_ -> buildLoop codec chan 0) + |> IO.bind (\_ -> Utils.putMVar Serialize.unit mvar ()) ) - |> IO.bind (\_ -> callback (Key (Utils.writeChan chanEncoder chan << Err))) + |> IO.bind (\_ -> callback (Key (Utils.writeChan chanCodec chan << Err))) |> IO.bind (\result -> - Utils.writeChan chanEncoder chan (Ok result) + Utils.writeChan chanCodec chan (Ok result) |> IO.fmap (\_ -> result) ) ) @@ -406,9 +404,9 @@ type BMsg = BDone -buildLoop : Decode.Decoder a -> Chan (Result BMsg (BResult a)) -> Int -> IO () -buildLoop decoder chan done = - Utils.readChan (DecodeX.result bMsgDecoder (bResultDecoder decoder)) chan +buildLoop : Codec e a -> Chan (Result BMsg (BResult a)) -> Int -> IO () +buildLoop codec chan done = + Utils.readChan (Serialize.result bMsgCodec (bResultCodec codec)) chan |> IO.bind (\msg -> case msg of @@ -419,7 +417,7 @@ buildLoop decoder chan done = done + 1 in putStrFlush ("\u{000D}Compiling (" ++ String.fromInt done1 ++ ")") - |> IO.bind (\_ -> buildLoop decoder chan done1) + |> IO.bind (\_ -> buildLoop codec chan done1) Ok result -> let @@ -482,7 +480,7 @@ reportGenerate style names output = IO.pure () Terminal mvar -> - Utils.readMVar (Decode.map (\_ -> ()) Decode.bool) mvar + Utils.readMVar Serialize.unit mvar |> IO.bind (\_ -> let @@ -570,112 +568,52 @@ putStrFlush str = -- ENCODERS and DECODERS -dMsgEncoder : DMsg -> CoreEncode.Value -dMsgEncoder dMsg = - case dMsg of - DStart numDependencies -> - CoreEncode.object - [ ( "type", CoreEncode.string "DStart" ) - , ( "numDependencies", CoreEncode.int numDependencies ) - ] - - DCached -> - CoreEncode.object - [ ( "type", CoreEncode.string "DCached" ) - ] - - DRequested -> - CoreEncode.object - [ ( "type", CoreEncode.string "DRequested" ) - ] - - DReceived pkg vsn -> - CoreEncode.object - [ ( "type", CoreEncode.string "DReceived" ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "vsn", V.versionEncoder vsn ) - ] - - DFailed pkg vsn -> - CoreEncode.object - [ ( "type", CoreEncode.string "DFailed" ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "vsn", V.versionEncoder vsn ) - ] - - DBuilt -> - CoreEncode.object - [ ( "type", CoreEncode.string "DBuilt" ) - ] - - DBroken -> - CoreEncode.object - [ ( "type", CoreEncode.string "DBroken" ) - ] - - -dMsgDecoder : Decode.Decoder DMsg -dMsgDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "DStart" -> - Decode.map DStart (Decode.field "numDependencies" Decode.int) +dMsgCodec : Codec e DMsg +dMsgCodec = + Serialize.customType + (\dStartEncoder dCachedEncoder dRequestedEncoder dReceivedEncoder dFailedEncoder dBuiltEncoder dBrokenEncoder dMsg -> + case dMsg of + DStart numDependencies -> + dStartEncoder numDependencies - "DCached" -> - Decode.succeed DCached + DCached -> + dCachedEncoder - "DRequested" -> - Decode.succeed DRequested + DRequested -> + dRequestedEncoder - "DReceived" -> - Decode.map2 DReceived - (Decode.field "pkg" Pkg.nameDecoder) - (Decode.field "vsn" V.versionDecoder) + DReceived pkg vsn -> + dReceivedEncoder pkg vsn - "DFailed" -> - Decode.map2 DFailed - (Decode.field "pkg" Pkg.nameDecoder) - (Decode.field "vsn" V.versionDecoder) + DFailed pkg vsn -> + dFailedEncoder pkg vsn - "DBuilt" -> - Decode.succeed DBuilt + DBuilt -> + dBuiltEncoder - "DBroken" -> - Decode.succeed DBroken - - _ -> - Decode.fail ("Failed to decode DMsg's type: " ++ type_) - ) - - -bMsgEncoder : BMsg -> CoreEncode.Value -bMsgEncoder _ = - CoreEncode.object - [ ( "type", CoreEncode.string "BDone" ) - ] - - -bMsgDecoder : Decode.Decoder BMsg -bMsgDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "BDone" -> - Decode.succeed BDone - - _ -> - Decode.fail ("Failed to decode BDone's type: " ++ type_) - ) - - -bResultEncoder : (a -> CoreEncode.Value) -> BResult a -> CoreEncode.Value -bResultEncoder encoder bResult = - Encode.result Exit.buildProblemEncoder encoder bResult + DBroken -> + dBrokenEncoder + ) + |> Serialize.variant1 DStart Serialize.int + |> Serialize.variant0 DCached + |> Serialize.variant0 DRequested + |> Serialize.variant2 DReceived Pkg.nameCodec V.versionCodec + |> Serialize.variant2 DFailed Pkg.nameCodec V.versionCodec + |> Serialize.variant0 DBuilt + |> Serialize.variant0 DBroken + |> Serialize.finishCustomType + + +bMsgCodec : Codec e BMsg +bMsgCodec = + Serialize.customType + (\bMsgCodecEncoder BDone -> + bMsgCodecEncoder + ) + |> Serialize.variant0 BDone + |> Serialize.finishCustomType -bResultDecoder : Decode.Decoder a -> Decode.Decoder (BResult a) -bResultDecoder decoder = - DecodeX.result Exit.buildProblemDecoder decoder +bResultCodec : Codec e a -> Codec e (BResult a) +bResultCodec codec = + Serialize.result Exit.buildProblemCodec codec diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm index e2f47130c..00d2ddf6a 100644 --- a/src/Builder/Reporting/Exit.elm +++ b/src/Builder/Reporting/Exit.elm @@ -17,11 +17,14 @@ module Builder.Reporting.Exit exposing , RegistryProblem(..) , Repl(..) , Solver(..) + , buildProblemCodec , buildProblemDecoder , buildProblemEncoder + , buildProjectProblemCodec , buildProjectProblemDecoder , buildProjectProblemEncoder , bumpToReport + , detailsBadDepCodec , detailsBadDepDecoder , detailsBadDepEncoder , diffToReport @@ -60,6 +63,7 @@ import Data.IO exposing (IO) import Data.Map as Dict exposing (Dict) import Json.Decode as CoreDecode import Json.Encode as CoreEncode +import Serialize exposing (Codec) import Utils.Main as Utils exposing (FilePath) @@ -2867,6 +2871,11 @@ detailsBadDepDecoder = ) +detailsBadDepCodec : Codec e DetailsBadDep +detailsBadDepCodec = + Debug.todo "detailsBadDepCodec" + + buildProblemEncoder : BuildProblem -> CoreEncode.Value buildProblemEncoder buildProblem = case buildProblem of @@ -2905,6 +2914,22 @@ buildProblemDecoder = ) +buildProblemCodec : Codec e BuildProblem +buildProblemCodec = + Serialize.customType + (\buildBadModulesEncoder buildProjectProblemCodecEncoder buildProblem -> + case buildProblem of + BuildBadModules root e es -> + buildBadModulesEncoder root e es + + BuildProjectProblem problem -> + buildProjectProblemCodecEncoder problem + ) + |> Serialize.variant3 BuildBadModules Serialize.string Error.moduleCodec (Serialize.list Error.moduleCodec) + |> Serialize.variant1 BuildProjectProblem buildProjectProblemCodec + |> Serialize.finishCustomType + + buildProjectProblemEncoder : BuildProjectProblem -> CoreEncode.Value buildProjectProblemEncoder buildProjectProblem = case buildProjectProblem of @@ -3026,6 +3051,11 @@ buildProjectProblemDecoder = ) +buildProjectProblemCodec : Codec e BuildProjectProblem +buildProjectProblemCodec = + Debug.todo "buildProjectProblemCodec" + + registryProblemEncoder : RegistryProblem -> CoreEncode.Value registryProblemEncoder registryProblem = case registryProblem of diff --git a/src/Builder/Stuff.elm b/src/Builder/Stuff.elm index edd4cb3ce..0259e3709 100644 --- a/src/Builder/Stuff.elm +++ b/src/Builder/Stuff.elm @@ -39,17 +39,17 @@ stuff root = details : String -> String details root = - stuff root ++ "/d.json" + stuff root ++ "/d.dat" interfaces : String -> String interfaces root = - stuff root ++ "/i.json" + stuff root ++ "/i.dat" objects : String -> String objects root = - stuff root ++ "/o.json" + stuff root ++ "/o.dat" prepublishDir : String -> String @@ -150,7 +150,7 @@ getPackageCache = registry : PackageCache -> String registry (PackageCache dir) = - Utils.fpForwardSlash dir "registry.json" + Utils.fpForwardSlash dir "registry.dat" package : PackageCache -> Pkg.Name -> V.Version -> String diff --git a/src/Compiler/AST/Canonical.elm b/src/Compiler/AST/Canonical.elm index b3f32cc61..b4243d2f3 100644 --- a/src/Compiler/AST/Canonical.elm +++ b/src/Compiler/AST/Canonical.elm @@ -24,17 +24,22 @@ module Compiler.AST.Canonical exposing , Port(..) , Type(..) , Union(..) + , aliasCodec , aliasDecoder , aliasEncoder + , annotationCodec , annotationDecoder , annotationEncoder + , ctorOptsCodec , ctorOptsDecoder , ctorOptsEncoder , fieldUpdateDecoder , fieldUpdateEncoder , fieldsToList + , typeCodec , typeDecoder , typeEncoder + , unionCodec , unionDecoder , unionEncoder ) @@ -67,9 +72,11 @@ import Compiler.Elm.ModuleName as ModuleName import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Reporting.Annotation as A +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -334,6 +341,16 @@ annotationDecoder = (Decode.field "tipe" typeDecoder) +annotationCodec : Codec e Annotation +annotationCodec = + Serialize.customType + (\forallEncoder (Forall freeVars tipe) -> + forallEncoder freeVars tipe + ) + |> Serialize.variant2 Forall freeVarsCodec typeCodec + |> Serialize.finishCustomType + + freeVarsEncoder : FreeVars -> Encode.Value freeVarsEncoder = E.assocListDict Encode.string (\_ -> Encode.object []) @@ -344,6 +361,11 @@ freeVarsDecoder = D.assocListDict compare Decode.string (Decode.succeed ()) +freeVarsCodec : Codec e FreeVars +freeVarsCodec = + S.assocListDict compare Serialize.string Serialize.unit + + aliasEncoder : Alias -> Encode.Value aliasEncoder (Alias vars tipe) = Encode.object @@ -359,6 +381,16 @@ aliasDecoder = (Decode.field "tipe" typeDecoder) +aliasCodec : Codec e Alias +aliasCodec = + Serialize.customType + (\aliasCodecEncoder (Alias vars tipe) -> + aliasCodecEncoder vars tipe + ) + |> Serialize.variant2 Alias (Serialize.list Serialize.string) typeCodec + |> Serialize.finishCustomType + + typeEncoder : Type -> Encode.Value typeEncoder type_ = case type_ of @@ -460,6 +492,42 @@ typeDecoder = ) +typeCodec : Codec e Type +typeCodec = + Serialize.customType + (\tLambdaEncoder tVarEncoder tTypeEncoder tRecordEncoder tUnitEncoder tTupleEncoder tAliasEncoder value -> + case value of + TLambda a b -> + tLambdaEncoder a b + + TVar name -> + tVarEncoder name + + TType home name args -> + tTypeEncoder home name args + + TRecord fields ext -> + tRecordEncoder fields ext + + TUnit -> + tUnitEncoder + + TTuple a b maybeC -> + tTupleEncoder a b maybeC + + TAlias home name args tipe -> + tAliasEncoder home name args tipe + ) + |> 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.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 + |> Serialize.finishCustomType + + fieldTypeEncoder : FieldType -> Encode.Value fieldTypeEncoder (FieldType index tipe) = Encode.object @@ -469,6 +537,23 @@ fieldTypeEncoder (FieldType index tipe) = ] +fieldTypeDecoder : Decode.Decoder FieldType +fieldTypeDecoder = + Decode.map2 FieldType + (Decode.field "index" Decode.int) + (Decode.field "tipe" typeDecoder) + + +fieldTypeCodec : Codec e FieldType +fieldTypeCodec = + Serialize.customType + (\fieldTypeCodecEncoder (FieldType index tipe) -> + fieldTypeCodecEncoder index tipe + ) + |> Serialize.variant2 FieldType Serialize.int (Serialize.lazy (\() -> typeCodec)) + |> Serialize.finishCustomType + + aliasTypeEncoder : AliasType -> Encode.Value aliasTypeEncoder aliasType = case aliasType of @@ -485,13 +570,6 @@ aliasTypeEncoder aliasType = ] -fieldTypeDecoder : Decode.Decoder FieldType -fieldTypeDecoder = - Decode.map2 FieldType - (Decode.field "index" Decode.int) - (Decode.field "tipe" typeDecoder) - - aliasTypeDecoder : Decode.Decoder AliasType aliasTypeDecoder = Decode.field "type" Decode.string @@ -511,6 +589,22 @@ aliasTypeDecoder = ) +aliasTypeCodec : Codec e AliasType +aliasTypeCodec = + Serialize.customType + (\holeyEncoder filledEncoder value -> + case value of + Holey tipe -> + holeyEncoder tipe + + Filled tipe -> + filledEncoder tipe + ) + |> Serialize.variant1 Holey (Serialize.lazy (\() -> typeCodec)) + |> Serialize.variant1 Filled (Serialize.lazy (\() -> typeCodec)) + |> Serialize.finishCustomType + + unionEncoder : Union -> Encode.Value unionEncoder (Union vars ctors numAlts opts) = Encode.object @@ -531,6 +625,20 @@ unionDecoder = (Decode.field "opts" ctorOptsDecoder) +unionCodec : Codec e Union +unionCodec = + Serialize.customType + (\unionCodecEncoder (Union vars ctors numAlts opts) -> + unionCodecEncoder vars ctors numAlts opts + ) + |> Serialize.variant4 Union + (Serialize.list Serialize.string) + (Serialize.list ctorCodec) + Serialize.int + ctorOptsCodec + |> Serialize.finishCustomType + + ctorEncoder : Ctor -> Encode.Value ctorEncoder (Ctor ctor index numArgs args) = Encode.object @@ -551,6 +659,20 @@ ctorDecoder = (Decode.field "args" (Decode.list typeDecoder)) +ctorCodec : Codec e Ctor +ctorCodec = + Serialize.customType + (\ctorCodecEncoder (Ctor ctor index numArgs args) -> + ctorCodecEncoder ctor index numArgs args + ) + |> Serialize.variant4 Ctor + Serialize.string + Index.zeroBasedCodec + Serialize.int + (Serialize.list typeCodec) + |> Serialize.finishCustomType + + ctorOptsEncoder : CtorOpts -> Encode.Value ctorOptsEncoder ctorOpts = case ctorOpts of @@ -584,6 +706,26 @@ ctorOptsDecoder = ) +ctorOptsCodec : Codec e CtorOpts +ctorOptsCodec = + Serialize.customType + (\normalEncoder enumEncoder unboxEncoder value -> + case value of + Normal -> + normalEncoder + + Enum -> + enumEncoder + + Unbox -> + unboxEncoder + ) + |> Serialize.variant0 Normal + |> Serialize.variant0 Enum + |> Serialize.variant0 Unbox + |> Serialize.finishCustomType + + fieldUpdateEncoder : FieldUpdate -> Encode.Value fieldUpdateEncoder (FieldUpdate fieldRegion expr) = Encode.object diff --git a/src/Compiler/AST/Optimized.elm b/src/Compiler/AST/Optimized.elm index 369c5eb2a..b5faf36bd 100644 --- a/src/Compiler/AST/Optimized.elm +++ b/src/Compiler/AST/Optimized.elm @@ -16,8 +16,10 @@ module Compiler.AST.Optimized exposing , addLocalGraph , compareGlobal , empty + , globalGraphCodec , globalGraphDecoder , globalGraphEncoder + , localGraphCodec , localGraphDecoder , localGraphEncoder , toKernelGlobal @@ -34,10 +36,12 @@ import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Optimize.DecisionTree as DT import Compiler.Reporting.Annotation as A +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -259,6 +263,16 @@ globalGraphDecoder = (Decode.field "fields" (D.assocListDict compare Decode.string Decode.int)) +globalGraphCodec : Codec e GlobalGraph +globalGraphCodec = + Serialize.customType + (\globalGraphCodecEncoder (GlobalGraph nodes fields) -> + globalGraphCodecEncoder nodes fields + ) + |> Serialize.variant2 GlobalGraph (S.assocListDict compareGlobal globalCodec nodeCodec) (S.assocListDict compare Serialize.string Serialize.int) + |> Serialize.finishCustomType + + localGraphEncoder : LocalGraph -> Encode.Value localGraphEncoder (LocalGraph main nodes fields) = Encode.object @@ -277,6 +291,19 @@ localGraphDecoder = (Decode.field "fields" (D.assocListDict compare Decode.string Decode.int)) +localGraphCodec : Codec e LocalGraph +localGraphCodec = + Serialize.customType + (\localGraphCodecEncoder (LocalGraph main nodes fields) -> + localGraphCodecEncoder main nodes fields + ) + |> Serialize.variant3 LocalGraph + (Serialize.maybe mainCodec) + (S.assocListDict compareGlobal globalCodec nodeCodec) + (S.assocListDict compare Serialize.string Serialize.int) + |> Serialize.finishCustomType + + mainEncoder : Main -> Encode.Value mainEncoder main_ = case main_ of @@ -312,6 +339,22 @@ mainDecoder = ) +mainCodec : Codec c Main +mainCodec = + Serialize.customType + (\staticEncoder dynamicEncoder value -> + case value of + Static -> + staticEncoder + + Dynamic msgType decoder -> + dynamicEncoder msgType decoder + ) + |> Serialize.variant0 Static + |> Serialize.variant2 Dynamic Can.typeCodec exprCodec + |> Serialize.finishCustomType + + globalEncoder : Global -> Encode.Value globalEncoder (Global home name) = Encode.object @@ -328,6 +371,16 @@ globalDecoder = (Decode.field "name" Decode.string) +globalCodec : Codec e Global +globalCodec = + Serialize.customType + (\globalCodecEncoder (Global home name) -> + globalCodecEncoder home name + ) + |> Serialize.variant2 Global ModuleName.canonicalCodec Serialize.string + |> Serialize.finishCustomType + + nodeEncoder : Node -> Encode.Value nodeEncoder node = case node of @@ -469,6 +522,58 @@ nodeDecoder = ) +nodeCodec : Codec e Node +nodeCodec = + Serialize.customType + (\defineEncoder defineTailFuncEncoder ctorEncoder enumEncoder boxEncoder linkEncoder cycleEncoder managerEncoder kernelEncoder portIncomingEncoder portOutgoingEncoder node -> + case node of + Define expr deps -> + defineEncoder expr deps + + DefineTailFunc argNames body deps -> + defineTailFuncEncoder argNames body deps + + Ctor index arity -> + ctorEncoder index arity + + Enum index -> + enumEncoder index + + Box -> + boxEncoder + + Link linkedGlobal -> + linkEncoder linkedGlobal + + Cycle names values functions deps -> + cycleEncoder names values functions deps + + Manager effectsType -> + managerEncoder effectsType + + Kernel chunks deps -> + kernelEncoder chunks deps + + PortIncoming decoder deps -> + portIncomingEncoder decoder deps + + 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 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.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.finishCustomType + + exprEncoder : Expr -> Encode.Value exprEncoder expr = case expr of @@ -783,6 +888,122 @@ exprDecoder = ) +exprCodec : Codec e Expr +exprCodec = + Serialize.customType + (\boolEncoder chrEncoder strEncoder intEncoder floatEncoder varLocalEncoder varGlobalEncoder varEnumEncoder varBoxEncoder varCycleEncoder varDebugEncoder varKernelEncoder listEncoder functionEncoder callEncoder tailCallEncoder ifEncoder letEncoder destructEncoder caseEncoder accessorEncoder accessEncoder updateEncoder recordEncoder unitEncoder tupleEncoder shaderEncoder expr -> + case expr of + Bool value -> + boolEncoder value + + Chr value -> + chrEncoder value + + Str value -> + strEncoder value + + Int value -> + intEncoder value + + Float value -> + floatEncoder value + + VarLocal value -> + varLocalEncoder value + + VarGlobal value -> + varGlobalEncoder value + + VarEnum global index -> + varEnumEncoder global index + + VarBox value -> + varBoxEncoder value + + VarCycle home name -> + varCycleEncoder home name + + VarDebug name home region unhandledValueName -> + varDebugEncoder name home region unhandledValueName + + VarKernel home name -> + varKernelEncoder home name + + List value -> + listEncoder value + + Function args body -> + functionEncoder args body + + Call func args -> + callEncoder func args + + TailCall name args -> + tailCallEncoder name args + + If branches final -> + ifEncoder branches final + + Let def body -> + letEncoder def body + + Destruct destructor body -> + destructEncoder destructor body + + Case label root decider jumps -> + caseEncoder label root decider jumps + + Accessor field -> + accessorEncoder field + + Access record field -> + accessEncoder record field + + Update record fields -> + updateEncoder record fields + + Record value -> + recordEncoder value + + Unit -> + unitEncoder + + Tuple a b maybeC -> + tupleEncoder a b maybeC + + Shader src attributes uniforms -> + shaderEncoder src attributes uniforms + ) + |> Serialize.variant1 Bool Serialize.bool + |> Serialize.variant1 Chr Serialize.string + |> Serialize.variant1 Str Serialize.string + |> Serialize.variant1 Int Serialize.int + |> Serialize.variant1 Float Serialize.float + |> Serialize.variant1 VarLocal Serialize.string + |> Serialize.variant1 VarGlobal globalCodec + |> Serialize.variant2 VarEnum globalCodec Index.zeroBasedCodec + |> Serialize.variant1 VarBox globalCodec + |> Serialize.variant2 VarCycle ModuleName.canonicalCodec Serialize.string + |> Serialize.variant4 VarDebug Serialize.string ModuleName.canonicalCodec A.regionCodec (Serialize.maybe Serialize.string) + |> Serialize.variant2 VarKernel Serialize.string Serialize.string + |> Serialize.variant1 List (Serialize.list (Serialize.lazy (\() -> exprCodec))) + |> Serialize.variant2 Function (Serialize.list Serialize.string) (Serialize.lazy (\() -> exprCodec)) + |> Serialize.variant2 Call (Serialize.lazy (\() -> exprCodec)) (Serialize.list (Serialize.lazy (\() -> exprCodec))) + |> Serialize.variant2 TailCall Serialize.string (Serialize.list (Serialize.tuple Serialize.string (Serialize.lazy (\() -> exprCodec)))) + |> Serialize.variant2 If (Serialize.list (Serialize.tuple (Serialize.lazy (\() -> exprCodec)) (Serialize.lazy (\() -> exprCodec)))) (Serialize.lazy (\() -> exprCodec)) + |> Serialize.variant2 Let defCodec (Serialize.lazy (\() -> exprCodec)) + |> Serialize.variant2 Destruct destructorCodec (Serialize.lazy (\() -> 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.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.finishCustomType + + defEncoder : Def -> Encode.Value defEncoder def = case def of @@ -824,6 +1045,22 @@ defDecoder = ) +defCodec : Codec e Def +defCodec = + Serialize.customType + (\defCodecEncoder tailDefEncoder value -> + case value of + Def name expr -> + defCodecEncoder name expr + + TailDef name args expr -> + tailDefEncoder name args expr + ) + |> Serialize.variant2 Def Serialize.string (Serialize.lazy (\() -> exprCodec)) + |> Serialize.variant3 TailDef Serialize.string (Serialize.list Serialize.string) (Serialize.lazy (\() -> exprCodec)) + |> Serialize.finishCustomType + + destructorEncoder : Destructor -> Encode.Value destructorEncoder (Destructor name path) = Encode.object @@ -840,6 +1077,16 @@ destructorDecoder = (Decode.field "path" pathDecoder) +destructorCodec : Codec e Destructor +destructorCodec = + Serialize.customType + (\destructorCodecEncoder (Destructor name path) -> + destructorCodecEncoder name path + ) + |> Serialize.variant2 Destructor Serialize.string pathCodec + |> Serialize.finishCustomType + + deciderEncoder : (a -> Encode.Value) -> Decider a -> Encode.Value deciderEncoder encoder decider = case decider of @@ -892,6 +1139,26 @@ deciderDecoder decoder = ) +deciderCodec : Codec e a -> Codec e (Decider a) +deciderCodec codec = + Serialize.customType + (\leafEncoder chainEncoder fanOutEncoder decider -> + case decider of + Leaf value -> + leafEncoder value + + Chain testChain success failure -> + chainEncoder testChain success failure + + FanOut path edges fallback -> + fanOutEncoder path edges fallback + ) + |> Serialize.variant1 Leaf codec + |> Serialize.variant3 Chain (Serialize.list (Serialize.tuple DT.pathCodec DT.testCodec)) (Serialize.lazy (\() -> deciderCodec codec)) (Serialize.lazy (\() -> deciderCodec codec)) + |> Serialize.variant3 FanOut DT.pathCodec (Serialize.list (Serialize.tuple DT.testCodec (Serialize.lazy (\() -> deciderCodec codec)))) (Serialize.lazy (\() -> deciderCodec codec)) + |> Serialize.finishCustomType + + choiceEncoder : Choice -> Encode.Value choiceEncoder choice = case choice of @@ -925,6 +1192,22 @@ choiceDecoder = ) +choiceCodec : Codec e Choice +choiceCodec = + Serialize.customType + (\inlineEncoder jumpEncoder choice -> + case choice of + Inline value -> + inlineEncoder value + + Jump value -> + jumpEncoder value + ) + |> Serialize.variant1 Inline (Serialize.lazy (\() -> exprCodec)) + |> Serialize.variant1 Jump Serialize.int + |> Serialize.finishCustomType + + pathEncoder : Path -> Encode.Value pathEncoder path = case path of @@ -982,6 +1265,30 @@ pathDecoder = ) +pathCodec : Codec e Path +pathCodec = + Serialize.customType + (\indexEncoder fieldEncoder unboxEncoder rootEncoder path -> + case path of + Index index subPath -> + indexEncoder index subPath + + Field field subPath -> + fieldEncoder field subPath + + Unbox subPath -> + unboxEncoder subPath + + Root name -> + rootEncoder name + ) + |> Serialize.variant2 Index Index.zeroBasedCodec (Serialize.lazy (\() -> pathCodec)) + |> Serialize.variant2 Field Serialize.string (Serialize.lazy (\() -> pathCodec)) + |> Serialize.variant1 Unbox (Serialize.lazy (\() -> pathCodec)) + |> Serialize.variant1 Root Serialize.string + |> Serialize.finishCustomType + + effectsTypeEncoder : EffectsType -> Encode.Value effectsTypeEncoder effectsType = case effectsType of @@ -1013,3 +1320,23 @@ effectsTypeDecoder = _ -> Decode.fail ("Unknown EffectsType: " ++ str) ) + + +effectsTypeCodec : Codec e EffectsType +effectsTypeCodec = + Serialize.customType + (\cmdEncoder subEncoder fxEncoder effectsType -> + case effectsType of + Cmd -> + cmdEncoder + + Sub -> + subEncoder + + Fx -> + fxEncoder + ) + |> Serialize.variant0 Cmd + |> Serialize.variant0 Sub + |> Serialize.variant0 Fx + |> Serialize.finishCustomType diff --git a/src/Compiler/AST/Utils/Binop.elm b/src/Compiler/AST/Utils/Binop.elm index c6ffcc4de..3c084c2f0 100644 --- a/src/Compiler/AST/Utils/Binop.elm +++ b/src/Compiler/AST/Utils/Binop.elm @@ -1,14 +1,17 @@ module Compiler.AST.Utils.Binop exposing ( Associativity(..) , Precedence + , associativityCodec , associativityDecoder , associativityEncoder + , precedenceCodec , precedenceDecoder , precedenceEncoder ) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -35,6 +38,11 @@ precedenceDecoder = Decode.int +precedenceCodec : Codec e Precedence +precedenceCodec = + Serialize.int + + associativityEncoder : Associativity -> Encode.Value associativityEncoder associativity = case associativity of @@ -66,3 +74,23 @@ associativityDecoder = _ -> Decode.fail ("Unknown Associativity: " ++ str) ) + + +associativityCodec : Codec e Associativity +associativityCodec = + Serialize.customType + (\leftEncoder nonEncoder rightEncoder value -> + case value of + Left -> + leftEncoder + + Non -> + nonEncoder + + Right -> + rightEncoder + ) + |> Serialize.variant0 Left + |> Serialize.variant0 Non + |> Serialize.variant0 Right + |> Serialize.finishCustomType diff --git a/src/Compiler/AST/Utils/Shader.elm b/src/Compiler/AST/Utils/Shader.elm index bbc7ba951..71a0cad1e 100644 --- a/src/Compiler/AST/Utils/Shader.elm +++ b/src/Compiler/AST/Utils/Shader.elm @@ -3,6 +3,7 @@ module Compiler.AST.Utils.Shader exposing , Type(..) , Types(..) , fromString + , sourceCodec , sourceDecoder , sourceEncoder , toJsStringBuilder @@ -15,6 +16,7 @@ import Compiler.Json.Encode as E import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -109,6 +111,11 @@ sourceDecoder = Decode.map Source Decode.string +sourceCodec : Codec e Source +sourceCodec = + Serialize.string |> Serialize.map Source (\(Source src) -> src) + + typesEncoder : Types -> Encode.Value typesEncoder (Types attribute uniform varying) = Encode.object diff --git a/src/Compiler/Data/Index.elm b/src/Compiler/Data/Index.elm index 6c769cf91..9d49b8b1e 100644 --- a/src/Compiler/Data/Index.elm +++ b/src/Compiler/Data/Index.elm @@ -9,12 +9,14 @@ module Compiler.Data.Index exposing , third , toHuman , toMachine + , zeroBasedCodec , zeroBasedDecoder , zeroBasedEncoder ) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -111,3 +113,8 @@ zeroBasedEncoder (ZeroBased zeroBased) = zeroBasedDecoder : Decode.Decoder ZeroBased zeroBasedDecoder = Decode.map ZeroBased Decode.int + + +zeroBasedCodec : Codec e ZeroBased +zeroBasedCodec = + Serialize.int |> Serialize.map ZeroBased (\(ZeroBased zeroBased) -> zeroBased) diff --git a/src/Compiler/Elm/Compiler/Type/Extract.elm b/src/Compiler/Elm/Compiler/Type/Extract.elm index 9655c861b..635a04bb2 100644 --- a/src/Compiler/Elm/Compiler/Type/Extract.elm +++ b/src/Compiler/Elm/Compiler/Type/Extract.elm @@ -7,6 +7,7 @@ module Compiler.Elm.Compiler.Type.Extract exposing , fromType , merge , mergeMany + , typesCodec , typesDecoder , typesEncoder ) @@ -25,6 +26,7 @@ import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode import Json.Encode as Encode import Maybe.Extra as Maybe +import Serialize exposing (Codec) import Utils.Main as Utils @@ -324,6 +326,11 @@ typesDecoder = Decode.map Types (D.assocListDict ModuleName.compareCanonical ModuleName.canonicalDecoder types_Decoder) +typesCodec : Codec e Types +typesCodec = + Debug.todo "typesCodec" + + types_Encoder : Types_ -> Encode.Value types_Encoder (Types_ unionInfo aliasInfo) = Encode.object diff --git a/src/Compiler/Elm/Docs.elm b/src/Compiler/Elm/Docs.elm index 980f8b39f..46f85fad5 100644 --- a/src/Compiler/Elm/Docs.elm +++ b/src/Compiler/Elm/Docs.elm @@ -10,6 +10,7 @@ module Compiler.Elm.Docs exposing , decoder , encode , fromModule + , jsonCodec , jsonDecoder , jsonEncoder , jsonModuleDecoder @@ -39,6 +40,7 @@ import Compiler.Reporting.Result as Result import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Main as Utils @@ -780,6 +782,11 @@ jsonDecoder = Decode.map toDict (Decode.list jsonModuleDecoder) +jsonCodec : Codec e Documentation +jsonCodec = + Debug.todo "jsonCodec" + + jsonModuleEncoder : Module -> Encode.Value jsonModuleEncoder (Module name comment unions aliases values binops) = Encode.object diff --git a/src/Compiler/Elm/Interface.elm b/src/Compiler/Elm/Interface.elm index 40e9e3bb9..0348c5d2a 100644 --- a/src/Compiler/Elm/Interface.elm +++ b/src/Compiler/Elm/Interface.elm @@ -4,11 +4,13 @@ module Compiler.Elm.Interface exposing , DependencyInterface(..) , Interface(..) , Union(..) + , dependencyInterfaceCodec , dependencyInterfaceDecoder , dependencyInterfaceEncoder , extractAlias , extractUnion , fromModule + , interfaceCodec , interfaceDecoder , interfaceEncoder , private @@ -25,9 +27,11 @@ import Compiler.Elm.Package as Pkg import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Reporting.Annotation as A +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils @@ -229,6 +233,21 @@ interfaceDecoder = (Decode.field "binops" (D.assocListDict compare Decode.string binopDecoder)) +interfaceCodec : Codec e Interface +interfaceCodec = + Serialize.customType + (\interfaceCodecEncoder (Interface home values unions aliases binops) -> + interfaceCodecEncoder home values unions aliases binops + ) + |> 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) + |> Serialize.finishCustomType + + unionEncoder : Union -> Encode.Value unionEncoder union_ = case union_ of @@ -274,6 +293,26 @@ unionDecoder = ) +unionCodec : Codec e Union +unionCodec = + Serialize.customType + (\openUnionEncoder closedUnionEncoder privateUnionEncoder value -> + case value of + OpenUnion union -> + openUnionEncoder union + + ClosedUnion union -> + closedUnionEncoder union + + PrivateUnion union -> + privateUnionEncoder union + ) + |> Serialize.variant1 OpenUnion Can.unionCodec + |> Serialize.variant1 ClosedUnion Can.unionCodec + |> Serialize.variant1 PrivateUnion Can.unionCodec + |> Serialize.finishCustomType + + aliasEncoder : Alias -> Encode.Value aliasEncoder aliasValue = case aliasValue of @@ -309,6 +348,22 @@ aliasDecoder = ) +aliasCodec : Codec e Alias +aliasCodec = + Serialize.customType + (\publicAliasEncoder privateAliasEncoder value -> + case value of + PublicAlias alias_ -> + publicAliasEncoder alias_ + + PrivateAlias alias_ -> + privateAliasEncoder alias_ + ) + |> Serialize.variant1 PublicAlias Can.aliasCodec + |> Serialize.variant1 PrivateAlias Can.aliasCodec + |> Serialize.finishCustomType + + binopEncoder : Binop -> Encode.Value binopEncoder (Binop name annotation associativity precedence) = Encode.object @@ -329,6 +384,16 @@ binopDecoder = (Decode.field "precedence" Binop.precedenceDecoder) +binopCodec : Codec e Binop +binopCodec = + Serialize.customType + (\binopCodecEncoder (Binop name annotation associativity precedence) -> + binopCodecEncoder name annotation associativity precedence + ) + |> Serialize.variant4 Binop Serialize.string Can.annotationCodec Binop.associativityCodec Binop.precedenceCodec + |> Serialize.finishCustomType + + dependencyInterfaceEncoder : DependencyInterface -> Encode.Value dependencyInterfaceEncoder dependencyInterface = case dependencyInterface of @@ -365,3 +430,19 @@ dependencyInterfaceDecoder = _ -> Decode.fail ("Failed to decode DependencyInterface's type: " ++ type_) ) + + +dependencyInterfaceCodec : Codec e DependencyInterface +dependencyInterfaceCodec = + Serialize.customType + (\publicEncoder privateEncoder dependencyInterface -> + case dependencyInterface of + Public i -> + publicEncoder i + + Private pkg unions aliases -> + 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.finishCustomType diff --git a/src/Compiler/Elm/Kernel.elm b/src/Compiler/Elm/Kernel.elm index f69010945..3f9b046e7 100644 --- a/src/Compiler/Elm/Kernel.elm +++ b/src/Compiler/Elm/Kernel.elm @@ -2,6 +2,7 @@ module Compiler.Elm.Kernel exposing ( Chunk(..) , Content(..) , Foreigns + , chunkCodec , chunkDecoder , chunkEncoder , countFields @@ -20,6 +21,7 @@ import Compiler.Reporting.Annotation as A import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) @@ -505,3 +507,43 @@ chunkDecoder = _ -> Decode.fail ("Unknown Chunk's type: " ++ type_) ) + + +chunkCodec : Codec e Chunk +chunkCodec = + Serialize.customType + (\jsEncoder elmVarEncoder jsVarEncoder elmFieldEncoder jsFieldEncoder jsEnumEncoder debugEncoder prodEncoder chunk -> + case chunk of + JS javascript -> + jsEncoder javascript + + ElmVar home name -> + elmVarEncoder home name + + JsVar home name -> + jsVarEncoder home name + + ElmField name -> + elmFieldEncoder name + + JsField int -> + jsFieldEncoder int + + JsEnum int -> + jsEnumEncoder int + + Debug -> + debugEncoder + + Prod -> + prodEncoder + ) + |> Serialize.variant1 JS Serialize.string + |> Serialize.variant2 ElmVar ModuleName.canonicalCodec Serialize.string + |> Serialize.variant2 JsVar Serialize.string Serialize.string + |> Serialize.variant1 ElmField Serialize.string + |> Serialize.variant1 JsField Serialize.int + |> Serialize.variant1 JsEnum Serialize.int + |> Serialize.variant0 Debug + |> Serialize.variant0 Prod + |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/ModuleName.elm b/src/Compiler/Elm/ModuleName.elm index f50d51aa9..c03c60e44 100644 --- a/src/Compiler/Elm/ModuleName.elm +++ b/src/Compiler/Elm/ModuleName.elm @@ -3,6 +3,7 @@ module Compiler.Elm.ModuleName exposing , Raw , array , basics + , canonicalCodec , canonicalDecoder , canonicalEncoder , char @@ -18,6 +19,7 @@ module Compiler.Elm.ModuleName exposing , matrix4 , maybe , platform + , rawCodec , rawDecoder , rawEncoder , result @@ -43,6 +45,7 @@ import Compiler.Parse.Primitives as P import Compiler.Parse.Variable as Var import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -337,6 +340,16 @@ canonicalDecoder = (Decode.field "name" Decode.string) +canonicalCodec : Codec e Canonical +canonicalCodec = + Serialize.customType + (\canonicalCodecEncoder (Canonical pkgName name) -> + canonicalCodecEncoder pkgName name + ) + |> Serialize.variant2 Canonical Pkg.nameCodec Serialize.string + |> Serialize.finishCustomType + + rawEncoder : Raw -> Encode.Value rawEncoder = Encode.string @@ -345,3 +358,8 @@ rawEncoder = rawDecoder : Decode.Decoder Raw rawDecoder = Decode.string + + +rawCodec : Codec e Raw +rawCodec = + Serialize.string diff --git a/src/Compiler/Elm/Package.elm b/src/Compiler/Elm/Package.elm index 1e077bedf..01cda8e06 100644 --- a/src/Compiler/Elm/Package.elm +++ b/src/Compiler/Elm/Package.elm @@ -14,6 +14,7 @@ module Compiler.Elm.Package exposing , kernel , keyDecoder , linearAlgebra + , nameCodec , nameDecoder , nameEncoder , nearbyNames @@ -34,6 +35,7 @@ import Compiler.Reporting.Suggest as Suggest import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -379,3 +381,13 @@ nameDecoder = Decode.map2 Name (Decode.field "author" Decode.string) (Decode.field "project" Decode.string) + + +nameCodec : Codec e Name +nameCodec = + Serialize.customType + (\nameCodecEncoder (Name author project) -> + nameCodecEncoder author project + ) + |> Serialize.variant2 Name Serialize.string Serialize.string + |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/Version.elm b/src/Compiler/Elm/Version.elm index 6a6592d63..206960ffc 100644 --- a/src/Compiler/Elm/Version.elm +++ b/src/Compiler/Elm/Version.elm @@ -7,6 +7,7 @@ module Compiler.Elm.Version exposing , compiler , decoder , encode + , jsonCodec , jsonDecoder , jsonEncoder , major @@ -16,6 +17,7 @@ module Compiler.Elm.Version exposing , one , parser , toChars + , versionCodec , versionDecoder , versionEncoder ) @@ -25,6 +27,7 @@ import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P exposing (Col, Row) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -227,6 +230,11 @@ isDigit word = -- ENCODERS and DECODERS +jsonEncoder : Version -> Encode.Value +jsonEncoder version = + Encode.string (toChars version) + + jsonDecoder : Decode.Decoder Version jsonDecoder = Decode.string @@ -241,13 +249,23 @@ jsonDecoder = ) +jsonCodec : Codec e Version +jsonCodec = + Serialize.customType + (\versionCodecEncoder (Version major_ minor patch) -> + versionCodecEncoder major_ minor patch + ) + |> Serialize.variant3 Version Serialize.int Serialize.int Serialize.int + |> Serialize.finishCustomType + + versionEncoder : Version -> Encode.Value -versionEncoder (Version major_ minor_ patch_) = +versionEncoder (Version major_ minor patch) = Encode.object [ ( "type", Encode.string "Version" ) , ( "major", Encode.int major_ ) - , ( "minor", Encode.int minor_ ) - , ( "patch", Encode.int patch_ ) + , ( "minor", Encode.int minor ) + , ( "patch", Encode.int patch ) ] @@ -259,6 +277,11 @@ versionDecoder = (Decode.field "patch" Decode.int) -jsonEncoder : Version -> Encode.Value -jsonEncoder version = - Encode.string (toChars version) +versionCodec : Codec e Version +versionCodec = + Serialize.customType + (\versionCodecEncoder (Version major_ minor patch) -> + versionCodecEncoder major_ minor patch + ) + |> Serialize.variant3 Version Serialize.int Serialize.int Serialize.int + |> Serialize.finishCustomType diff --git a/src/Compiler/Optimize/DecisionTree.elm b/src/Compiler/Optimize/DecisionTree.elm index e142f6357..36749b223 100644 --- a/src/Compiler/Optimize/DecisionTree.elm +++ b/src/Compiler/Optimize/DecisionTree.elm @@ -3,8 +3,10 @@ module Compiler.Optimize.DecisionTree exposing , Path(..) , Test(..) , compile + , pathCodec , pathDecoder , pathEncoder + , testCodec , testDecoder , testEncoder ) @@ -29,6 +31,7 @@ import Data.Set as EverySet import Json.Decode as Decode import Json.Encode as Encode import Prelude +import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils @@ -791,6 +794,26 @@ pathDecoder = ) +pathCodec : Codec e Path +pathCodec = + Serialize.customType + (\indexEncoder unboxEncoder emptyEncoder value -> + case value of + Index index path -> + indexEncoder index path + + Unbox path -> + unboxEncoder path + + Empty -> + emptyEncoder + ) + |> Serialize.variant2 Index Index.zeroBasedCodec (Serialize.lazy (\() -> pathCodec)) + |> Serialize.variant1 Unbox (Serialize.lazy (\() -> pathCodec)) + |> Serialize.variant0 Empty + |> Serialize.finishCustomType + + testEncoder : Test -> Encode.Value testEncoder test = case test of @@ -882,3 +905,51 @@ testDecoder = _ -> Decode.fail ("Unknown Test's type: " ++ type_) ) + + +testCodec : Codec e Test +testCodec = + Serialize.customType + (\isCtorEncoder isConsEncoder isNilEncoder isTupleEncoder isIntEncoder isChrEncoder isStrEncoder isBoolEncoder test -> + case test of + IsCtor home name index numAlts opts -> + isCtorEncoder home name index numAlts opts + + IsCons -> + isConsEncoder + + IsNil -> + isNilEncoder + + IsTuple -> + isTupleEncoder + + IsInt value -> + isIntEncoder value + + IsChr value -> + isChrEncoder value + + IsStr value -> + isStrEncoder value + + IsBool value -> + isBoolEncoder value + ) + -- Encode.object + -- [ ( "type", Encode.string "IsCtor" ) + -- , ( "home", ModuleName.canonicalEncoder home ) + -- , ( "name", Encode.string name ) + -- , ( "index", Index.zeroBasedEncoder index ) + -- , ( "numAlts", Encode.int numAlts ) + -- , ( "opts", Can.ctorOptsEncoder opts ) + -- ] + |> Serialize.variant5 IsCtor ModuleName.canonicalCodec Serialize.string Index.zeroBasedCodec Serialize.int Can.ctorOptsCodec + |> Serialize.variant0 IsCons + |> Serialize.variant0 IsNil + |> Serialize.variant0 IsTuple + |> Serialize.variant1 IsInt Serialize.int + |> Serialize.variant1 IsChr Serialize.string + |> Serialize.variant1 IsStr Serialize.string + |> Serialize.variant1 IsBool Serialize.bool + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Annotation.elm b/src/Compiler/Reporting/Annotation.elm index 7781c6d10..74247cfa1 100644 --- a/src/Compiler/Reporting/Annotation.elm +++ b/src/Compiler/Reporting/Annotation.elm @@ -8,6 +8,7 @@ module Compiler.Reporting.Annotation exposing , merge , mergeRegions , one + , regionCodec , regionDecoder , regionEncoder , toRegion @@ -19,6 +20,7 @@ module Compiler.Reporting.Annotation exposing import Data.IO as IO exposing (IO) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -105,6 +107,16 @@ regionDecoder = (Decode.field "end" positionDecoder) +regionCodec : Codec e Region +regionCodec = + Serialize.customType + (\regionCodecEncoder (Region start end) -> + regionCodecEncoder start end + ) + |> Serialize.variant2 Region positionCodec positionCodec + |> Serialize.finishCustomType + + positionEncoder : Position -> Encode.Value positionEncoder (Position start end) = Encode.object @@ -121,6 +133,16 @@ positionDecoder = (Decode.field "end" Decode.int) +positionCodec : Codec e Position +positionCodec = + Serialize.customType + (\positionCodecEncoder (Position start end) -> + positionCodecEncoder start end + ) + |> Serialize.variant2 Position Serialize.int Serialize.int + |> Serialize.finishCustomType + + locatedEncoder : (a -> Encode.Value) -> Located a -> Encode.Value locatedEncoder encoder (At region value) = Encode.object diff --git a/src/Compiler/Reporting/Error.elm b/src/Compiler/Reporting/Error.elm index 837e18ece..5617e39f9 100644 --- a/src/Compiler/Reporting/Error.elm +++ b/src/Compiler/Reporting/Error.elm @@ -2,6 +2,7 @@ module Compiler.Reporting.Error exposing ( Error(..) , Module , jsonToJson + , moduleCodec , moduleDecoder , moduleEncoder , toDoc @@ -29,6 +30,7 @@ import Compiler.Reporting.Render.Type.Localizer as L import Compiler.Reporting.Report as Report import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Time import Utils.Main as Utils @@ -265,6 +267,17 @@ moduleDecoder = (Decode.field "error" errorDecoder) +moduleCodec : Codec e Module +moduleCodec = + Serialize.record Module + |> Serialize.field .name ModuleName.rawCodec + |> Serialize.field .absolutePath Serialize.string + |> Serialize.field .modificationTime File.timeCodec + |> Serialize.field .source Serialize.string + |> Serialize.field .error errorCodec + |> Serialize.finishRecord + + errorEncoder : Error -> Encode.Value errorEncoder error = case error of @@ -347,3 +360,8 @@ errorDecoder = _ -> Decode.fail ("Unknown Path's type: " ++ type_) ) + + +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" diff --git a/src/Compiler/Serialize.elm b/src/Compiler/Serialize.elm new file mode 100644 index 000000000..4270bae04 --- /dev/null +++ b/src/Compiler/Serialize.elm @@ -0,0 +1,34 @@ +module Compiler.Serialize exposing (assocListDict, everySet, nonempty) + +import Compiler.Data.NonEmptyList as NE +import Data.Map as Dict exposing (Dict) +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 = + S.list (S.tuple keyCodec valueCodec) + |> S.map (Dict.fromList keyComparison) Dict.toList + + +everySet : (a -> a -> Order) -> Codec e a -> Codec e (EverySet a) +everySet keyComparison codec = + S.list codec + |> S.map (EverySet.fromList keyComparison) (List.reverse << EverySet.toList) + + +nonempty : Codec e a -> Codec (S.Error e) (NE.Nonempty a) +nonempty codec = + S.list codec + |> S.mapError S.CustomError + |> S.mapValid + (\values -> + case values of + x :: xs -> + Ok (NE.Nonempty x xs) + + [] -> + Err S.DataCorrupted + ) + (\(NE.Nonempty x xs) -> x :: xs) diff --git a/src/Compiler/Type/Solve.elm b/src/Compiler/Type/Solve.elm index 1b6c6c095..ccf8ac27c 100644 --- a/src/Compiler/Type/Solve.elm +++ b/src/Compiler/Type/Solve.elm @@ -16,8 +16,7 @@ import Compiler.Type.Unify as Unify import Compiler.Type.UnionFind as UF exposing (Content, Descriptor(..), Mark, Variable) import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode +import Serialize import Utils.Crash exposing (crash) import Utils.Main as Utils @@ -28,7 +27,7 @@ import Utils.Main as Utils run : Constraint -> IO (Result (NE.Nonempty Error.Error) (Dict Name.Name Can.Annotation)) run constraint = - IO.mVectorReplicate (Encode.list UF.variableEncoder) 8 [] + IO.mVectorReplicate (Serialize.list UF.variableCodec) 8 [] |> IO.bind (\pools -> solve Dict.empty Type.outermostRank pools emptyState constraint @@ -219,15 +218,14 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = nextRank = rank + 1 in - IO.mVectorLength pools + IO.mVectorLength (Serialize.list UF.variableCodec) pools |> IO.bind (\poolsLength -> (if nextRank < poolsLength then IO.pure pools else - IO.mVectorGrow (Decode.list UF.variableDecoder) - (Encode.list UF.variableEncoder) + IO.mVectorGrow (Serialize.list UF.variableCodec) pools poolsLength ) @@ -247,7 +245,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = ) |> IO.bind (\_ -> - IO.mVectorWrite (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) nextPools nextRank vars + IO.mVectorWrite (Serialize.list UF.variableCodec) nextPools nextRank vars |> IO.bind (\_ -> -- run solver in next pool @@ -274,7 +272,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = generalize youngMark visitMark nextRank nextPools |> IO.bind (\_ -> - IO.mVectorWrite (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) nextPools nextRank [] + IO.mVectorWrite (Serialize.list UF.variableCodec) nextPools nextRank [] |> IO.bind (\_ -> -- check that things went well @@ -407,7 +405,7 @@ This sorts variables into the young and old pools accordingly. -} generalize : Mark -> Mark -> Int -> Pools -> IO () generalize youngMark visitMark youngRank pools = - IO.mVectorRead (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) pools youngRank + IO.mVectorRead (Serialize.list UF.variableCodec) pools youngRank |> IO.bind (\youngVars -> poolToRankTable youngMark youngRank youngVars @@ -416,7 +414,7 @@ generalize youngMark visitMark youngRank pools = -- get the ranks right for each entry. -- start at low ranks so that we only have to pass -- over the information once. - IO.vectorImapM_ (Decode.list UF.variableDecoder) + IO.vectorImapM_ (Serialize.list UF.variableCodec) (\rank table -> Utils.mapM_ (adjustRank youngMark visitMark rank) table ) @@ -425,7 +423,7 @@ generalize youngMark visitMark youngRank pools = (\_ -> -- For variables that have rank lowerer than youngRank, register them in -- the appropriate old pool if they are not redundant. - IO.vectorForM_ (Decode.list UF.variableDecoder) + IO.vectorForM_ (Serialize.list UF.variableCodec) (IO.vectorUnsafeInit rankTable) (\vars -> Utils.forM_ vars @@ -440,7 +438,7 @@ generalize youngMark visitMark youngRank pools = UF.get var |> IO.bind (\(Descriptor _ rank _ _) -> - IO.mVectorModify (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) pools ((::) var) rank + IO.mVectorModify (Serialize.list UF.variableCodec) pools ((::) var) rank ) ) ) @@ -450,7 +448,7 @@ generalize youngMark visitMark youngRank pools = -- For variables with rank youngRank -- If rank < youngRank: register in oldPool -- otherwise generalize - IO.vectorUnsafeLast (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) rankTable + IO.vectorUnsafeLast (Serialize.list UF.variableCodec) rankTable |> IO.bind (\lastRankTable -> Utils.forM_ lastRankTable <| @@ -466,7 +464,7 @@ generalize youngMark visitMark youngRank pools = |> IO.bind (\(Descriptor content rank mark copy) -> if rank < youngRank then - IO.mVectorModify (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) pools ((::) var) rank + IO.mVectorModify (Serialize.list UF.variableCodec) pools ((::) var) rank else UF.set var <| Descriptor content Type.noRank mark copy @@ -481,7 +479,7 @@ generalize youngMark visitMark youngRank pools = poolToRankTable : Mark -> Int -> List Variable -> IO (IO.IORef (Array (Maybe (List Variable)))) poolToRankTable youngMark youngRank youngInhabitants = - IO.mVectorReplicate (Encode.list UF.variableEncoder) (youngRank + 1) [] + IO.mVectorReplicate (Serialize.list UF.variableCodec) (youngRank + 1) [] |> IO.bind (\mutableTable -> -- Sort the youngPool variables into buckets by rank. @@ -493,7 +491,7 @@ poolToRankTable youngMark youngRank youngInhabitants = UF.set var (Descriptor content rank youngMark copy) |> IO.bind (\_ -> - IO.mVectorModify (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) mutableTable ((::) var) rank + IO.mVectorModify (Serialize.list UF.variableCodec) mutableTable ((::) var) rank ) ) ) @@ -618,9 +616,7 @@ adjustRankContent youngMark visitMark groupRank content = introduce : Int -> Pools -> List Variable -> IO () introduce rank pools variables = - IO.mVectorModify - (Decode.list UF.variableDecoder) - (Encode.list UF.variableEncoder) + IO.mVectorModify (Serialize.list UF.variableCodec) pools (\a -> variables ++ a) rank @@ -735,7 +731,7 @@ register rank pools content = UF.fresh (Descriptor content rank Type.noMark Nothing) |> IO.bind (\var -> - IO.mVectorModify (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) pools ((::) var) rank + IO.mVectorModify (Serialize.list UF.variableCodec) pools ((::) var) rank |> IO.fmap (\_ -> var) ) @@ -781,7 +777,7 @@ srcTypeToVariable rank pools freeVars srcType = Utils.mapTraverseWithKey compare makeVar freeVars |> IO.bind (\flexVars -> - IO.mVectorModify (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) pools (\a -> Dict.values flexVars ++ a) rank + IO.mVectorModify (Serialize.list UF.variableCodec) pools (\a -> Dict.values flexVars ++ a) rank |> IO.bind (\_ -> srcTypeToVar rank pools flexVars srcType) ) @@ -909,7 +905,7 @@ makeCopyHelp maxRank pools variable = UF.fresh (makeDescriptor content) |> IO.bind (\copy -> - IO.mVectorModify (Decode.list UF.variableDecoder) (Encode.list UF.variableEncoder) pools ((::) copy) maxRank + IO.mVectorModify (Serialize.list UF.variableCodec) pools ((::) copy) maxRank |> IO.bind (\_ -> -- Link the original variable to the new variable. This lets us diff --git a/src/Compiler/Type/UnionFind.elm b/src/Compiler/Type/UnionFind.elm index 14b506ecb..e17030149 100644 --- a/src/Compiler/Type/UnionFind.elm +++ b/src/Compiler/Type/UnionFind.elm @@ -13,6 +13,7 @@ module Compiler.Type.UnionFind exposing , redundant , set , union + , variableCodec , variableDecoder , variableEncoder ) @@ -33,11 +34,12 @@ module Compiler.Type.UnionFind exposing import Compiler.Data.Name exposing (Name) import Compiler.Elm.ModuleName as ModuleName -import Compiler.Json.Decode as D +import Compiler.Serialize as S import Data.IO as IO exposing (IO, IORef) -import Data.Map as Dict exposing (Dict) +import Data.Map exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) @@ -49,28 +51,14 @@ type Descriptor = Descriptor Content Int Mark (Maybe Variable) -descriptorEncoder : Descriptor -> Encode.Value -descriptorEncoder (Descriptor content rank mark copy) = - Encode.object - [ ( "type", Encode.string "Descriptor" ) - , ( "content", contentEncoder content ) - , ( "rank", Encode.int rank ) - , ( "mark", markEncoder mark ) - , ( "copy" - , copy - |> Maybe.map variableEncoder - |> Maybe.withDefault Encode.null - ) - ] - - -descriptorDecoder : Decode.Decoder Descriptor -descriptorDecoder = - Decode.map4 Descriptor - (Decode.field "content" contentDecoder) - (Decode.field "rank" Decode.int) - (Decode.field "mark" markDecoder) - (Decode.field "copy" (Decode.maybe variableDecoder)) +descriptorCodec : Codec e Descriptor +descriptorCodec = + Serialize.customType + (\descriptorCodecEncoder (Descriptor content rank mark copy) -> + descriptorCodecEncoder content rank mark copy + ) + |> Serialize.variant4 Descriptor contentCodec Serialize.int markCodec (Serialize.maybe variableCodec) + |> Serialize.finishCustomType type Content @@ -83,151 +71,75 @@ type Content | Error -contentEncoder : Content -> Encode.Value -contentEncoder content = - case content of - FlexVar maybeName -> - Encode.object - [ ( "type", Encode.string "FlexVar" ) - , ( "name" - , maybeName - |> Maybe.map Encode.string - |> Maybe.withDefault Encode.null - ) - ] - - FlexSuper superType maybeName -> - Encode.object - [ ( "type", Encode.string "FlexSuper" ) - , ( "superType", superTypeEncoder superType ) - , ( "name" - , maybeName - |> Maybe.map Encode.string - |> Maybe.withDefault Encode.null - ) - ] - - RigidVar name -> - Encode.object - [ ( "type", Encode.string "RigidVar" ) - , ( "name", Encode.string name ) - ] - - RigidSuper superType name -> - Encode.object - [ ( "type", Encode.string "RigidSuper" ) - , ( "superType", superTypeEncoder superType ) - , ( "name", Encode.string name ) - ] - - Structure flatType -> - Encode.object - [ ( "type", Encode.string "Structure" ) - , ( "flatType", flatTypeEncoder flatType ) - ] - - Alias canonical name variableList variable -> - Encode.object - [ ( "type", Encode.string "Alias" ) - , ( "canonical", ModuleName.canonicalEncoder canonical ) - , ( "name", Encode.string name ) - , ( "variableList", Encode.object (List.map (Tuple.mapSecond variableEncoder) variableList) ) - , ( "variable", variableEncoder variable ) - ] - - Error -> - Encode.object - [ ( "type", Encode.string "Error" ) - ] - - -contentDecoder : Decode.Decoder Content -contentDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "FlexVar" -> - Decode.map FlexVar - (Decode.field "name" (Decode.maybe Decode.string)) - - "FlexSuper" -> - Decode.map2 FlexSuper - (Decode.field "superType" superTypeDecoder) - (Decode.field "name" (Decode.maybe Decode.string)) - - "RigidVar" -> - Decode.map RigidVar - (Decode.field "name" Decode.string) - - "RigidSuper" -> - Decode.map2 RigidSuper - (Decode.field "superType" superTypeDecoder) - (Decode.field "name" Decode.string) - - "Structure" -> - Decode.map Structure - (Decode.field "flatType" flatTypeDecoder) - - "Alias" -> - Decode.map4 Alias - (Decode.field "canonical" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "variableList" (Decode.keyValuePairs variableDecoder)) - (Decode.field "variable" variableDecoder) - - "Error" -> - Decode.succeed Error - - _ -> - Decode.fail ("Unknown Content's type: " ++ type_) - ) +contentCodec : Codec e Content +contentCodec = + Serialize.customType + (\flexVarEncoder flexSuperEncoder rigidVarEncoder rigidSuperEncoder structureEncoder aliasEncoder errorEncoder content -> + case content of + FlexVar maybeName -> + flexVarEncoder maybeName + FlexSuper superType maybeName -> + flexSuperEncoder superType maybeName -type SuperType - = Number - | Comparable - | Appendable - | CompAppend + RigidVar name -> + rigidVarEncoder name + RigidSuper superType name -> + rigidSuperEncoder superType name -superTypeEncoder : SuperType -> Encode.Value -superTypeEncoder superType = - case superType of - Number -> - Encode.string "Number" + Structure flatType -> + structureEncoder flatType - Comparable -> - Encode.string "Comparable" + Alias canonical name variableList variable -> + aliasEncoder canonical name variableList variable - Appendable -> - Encode.string "Appendable" + Error -> + errorEncoder + ) + |> Serialize.variant1 FlexVar (Serialize.maybe Serialize.string) + |> Serialize.variant2 FlexSuper superTypeCodec (Serialize.maybe Serialize.string) + |> Serialize.variant1 RigidVar Serialize.string + |> Serialize.variant2 RigidSuper superTypeCodec Serialize.string + |> Serialize.variant1 Structure flatTypeCodec + |> Serialize.variant4 Alias + ModuleName.canonicalCodec + Serialize.string + (Serialize.list (Serialize.tuple Serialize.string variableCodec)) + variableCodec + |> Serialize.variant0 Error + |> Serialize.finishCustomType - CompAppend -> - Encode.string "CompAppend" +type SuperType + = Number + | Comparable + | Appendable + | CompAppend -superTypeDecoder : Decode.Decoder SuperType -superTypeDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "Number" -> - Decode.succeed Number - "Comparable" -> - Decode.succeed Comparable +superTypeCodec : Codec e SuperType +superTypeCodec = + Serialize.customType + (\numberEncoder comparableEncoder appendableEncoder compAppendEncoder superType -> + case superType of + Number -> + numberEncoder - "Appendable" -> - Decode.succeed Appendable + Comparable -> + comparableEncoder - "CompAppend" -> - Decode.succeed CompAppend + Appendable -> + appendableEncoder - _ -> - Decode.fail ("Failed to decode SuperType: " ++ str) - ) + CompAppend -> + compAppendEncoder + ) + |> Serialize.variant0 Number + |> Serialize.variant0 Comparable + |> Serialize.variant0 Appendable + |> Serialize.variant0 CompAppend + |> Serialize.finishCustomType type FlatType @@ -239,114 +151,45 @@ type FlatType | Tuple1 Variable Variable (Maybe Variable) -flatTypeEncoder : FlatType -> Encode.Value -flatTypeEncoder flatType = - case flatType of - App1 canonical name variableList -> - Encode.object - [ ( "type", Encode.string "App1" ) - , ( "canonical", ModuleName.canonicalEncoder canonical ) - , ( "name", Encode.string name ) - , ( "variableList", Encode.list variableEncoder variableList ) - ] - - Fun1 var1 var2 -> - Encode.object - [ ( "type", Encode.string "Fun1" ) - , ( "var1", variableEncoder var1 ) - , ( "var2", variableEncoder var2 ) - ] - - EmptyRecord1 -> - Encode.object - [ ( "type", Encode.string "EmptyRecord1" ) - ] - - Record1 variableDict variable -> - Encode.object - [ ( "type", Encode.string "Record1" ) - , ( "variableDict" - , Dict.toList variableDict - |> Encode.list - (\( name, var ) -> - Encode.object - [ ( "a", Encode.string name ) - , ( "b", variableEncoder var ) - ] - ) - ) - , ( "variable", variableEncoder variable ) - ] - - Unit1 -> - Encode.object - [ ( "type", Encode.string "Unit1" ) - ] - - Tuple1 var1 var2 maybeVariable -> - Encode.object - [ ( "type", Encode.string "Tuple1" ) - , ( "var1", variableEncoder var1 ) - , ( "var2", variableEncoder var2 ) - , ( "maybeVariable" - , maybeVariable - |> Maybe.map variableEncoder - |> Maybe.withDefault Encode.null - ) - ] - - -flatTypeDecoder : Decode.Decoder FlatType -flatTypeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "App1" -> - Decode.map3 App1 - (Decode.field "canonical" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "variableList" (Decode.list variableDecoder)) - - "Fun1" -> - Decode.map2 Fun1 - (Decode.field "var1" variableDecoder) - (Decode.field "var2" variableDecoder) - - "EmptyRecord1" -> - Decode.succeed EmptyRecord1 - - "Record1" -> - Decode.map2 Record1 - (Decode.field "variableDict" (D.assocListDict compare Decode.string variableDecoder)) - (Decode.field "variable" variableDecoder) - - "Unit1" -> - Decode.succeed Unit1 - - "Tuple1" -> - Decode.map3 Tuple1 - (Decode.field "var1" variableDecoder) - (Decode.field "var2" variableDecoder) - (Decode.field "maybeVariable" (Decode.maybe variableDecoder)) - - _ -> - Decode.fail ("Unknown FlatType's type: " ++ type_) - ) +flatTypeCodec : Codec e FlatType +flatTypeCodec = + Serialize.customType + (\app1Encoder fun1Encoder emptyRecord1Encoder record1Encoder unit1Encoder tuple1Encoder flatType -> + case flatType of + App1 canonical name variableList -> + app1Encoder canonical name variableList + Fun1 var1 var2 -> + fun1Encoder var1 var2 -type Mark - = Mark Int + EmptyRecord1 -> + emptyRecord1Encoder + + Record1 variableDict variable -> + record1Encoder variableDict variable + Unit1 -> + unit1Encoder -markEncoder : Mark -> Encode.Value -markEncoder (Mark value) = - Encode.int value + Tuple1 var1 var2 maybeVariable -> + tuple1Encoder var1 var2 maybeVariable + ) + |> Serialize.variant3 App1 ModuleName.canonicalCodec Serialize.string (Serialize.list variableCodec) + |> Serialize.variant2 Fun1 variableCodec variableCodec + |> Serialize.variant0 EmptyRecord1 + |> Serialize.variant2 Record1 (S.assocListDict compare Serialize.string variableCodec) variableCodec + |> Serialize.variant0 Unit1 + |> Serialize.variant3 Tuple1 variableCodec variableCodec (Serialize.maybe variableCodec) + |> Serialize.finishCustomType + + +type Mark + = Mark Int -markDecoder : Decode.Decoder Mark -markDecoder = - Decode.map Mark Decode.int +markCodec : Codec e Mark +markCodec = + Serialize.int |> Serialize.map Mark (\(Mark value) -> value) type alias Variable = @@ -363,6 +206,11 @@ variableDecoder = pointDecoder +variableCodec : Codec e Variable +variableCodec = + pointCodec + + -- POINT @@ -381,46 +229,30 @@ pointDecoder = Decode.map Pt IO.ioRefDecoder +pointCodec : Codec e Point +pointCodec = + IO.ioRefCodec |> Serialize.map Pt (\(Pt ioRef) -> ioRef) + + type PointInfo = Info (IORef Int) (IORef Descriptor) | Link Point -pointInfoEncoder : PointInfo -> Encode.Value -pointInfoEncoder pointInfo = - case pointInfo of - Info weight desc -> - Encode.object - [ ( "type", Encode.string "Info" ) - , ( "weight", IO.ioRefEncoder weight ) - , ( "desc", IO.ioRefEncoder desc ) - ] - - Link point -> - Encode.object - [ ( "type", Encode.string "Link" ) - , ( "point", pointEncoder point ) - ] - - -pointInfoDecoder : Decode.Decoder PointInfo -pointInfoDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Info" -> - Decode.map2 Info - (Decode.field "weight" IO.ioRefDecoder) - (Decode.field "desc" IO.ioRefDecoder) - - "Link" -> - Decode.map Link - (Decode.field "point" pointDecoder) - - _ -> - Decode.fail ("Unknown PointInfo's type: " ++ type_) - ) +pointInfoCodec : Codec e PointInfo +pointInfoCodec = + Serialize.customType + (\infoEncoder linkEncoder value -> + case value of + Info weight desc -> + infoEncoder weight desc + + Link point -> + linkEncoder point + ) + |> Serialize.variant2 Info IO.ioRefCodec IO.ioRefCodec + |> Serialize.variant1 Link pointCodec + |> Serialize.finishCustomType @@ -429,18 +261,18 @@ pointInfoDecoder = fresh : Descriptor -> IO Variable fresh value = - IO.newIORef Encode.int 1 + IO.newIORef Serialize.int 1 |> IO.bind (\weight -> - IO.newIORef descriptorEncoder value - |> IO.bind (\desc -> IO.newIORef pointInfoEncoder (Info weight desc)) + IO.newIORef descriptorCodec value + |> IO.bind (\desc -> IO.newIORef pointInfoCodec (Info weight desc)) |> IO.fmap (\link -> Pt link) ) repr : Point -> IO Point repr ((Pt ref) as point) = - IO.readIORef pointInfoDecoder ref + IO.readIORef pointInfoCodec ref |> IO.bind (\pInfo -> case pInfo of @@ -452,10 +284,10 @@ repr ((Pt ref) as point) = |> IO.bind (\point2 -> if point2 /= point1 then - IO.readIORef pointInfoDecoder ref1 + IO.readIORef pointInfoCodec ref1 |> IO.bind (\pInfo1 -> - IO.writeIORef pointInfoEncoder ref pInfo1 + IO.writeIORef pointInfoCodec ref pInfo1 |> IO.fmap (\_ -> point2) ) @@ -467,20 +299,20 @@ repr ((Pt ref) as point) = get : Point -> IO Descriptor get ((Pt ref) as point) = - IO.readIORef pointInfoDecoder ref + IO.readIORef pointInfoCodec ref |> IO.bind (\pInfo -> case pInfo of Info _ descRef -> - IO.readIORef descriptorDecoder descRef + IO.readIORef descriptorCodec descRef Link (Pt ref1) -> - IO.readIORef pointInfoDecoder ref1 + IO.readIORef pointInfoCodec ref1 |> IO.bind (\link_ -> case link_ of Info _ descRef -> - IO.readIORef descriptorDecoder descRef + IO.readIORef descriptorCodec descRef Link _ -> IO.bind get (repr point) @@ -490,20 +322,20 @@ get ((Pt ref) as point) = set : Point -> Descriptor -> IO () set ((Pt ref) as point) newDesc = - IO.readIORef pointInfoDecoder ref + IO.readIORef pointInfoCodec ref |> IO.bind (\pInfo -> case pInfo of Info _ descRef -> - IO.writeIORef descriptorEncoder descRef newDesc + IO.writeIORef descriptorCodec descRef newDesc Link (Pt ref1) -> - IO.readIORef pointInfoDecoder ref1 + IO.readIORef pointInfoCodec ref1 |> IO.bind (\link_ -> case link_ of Info _ descRef -> - IO.writeIORef descriptorEncoder descRef newDesc + IO.writeIORef descriptorCodec descRef newDesc Link _ -> repr point @@ -517,20 +349,20 @@ set ((Pt ref) as point) newDesc = modify : Point -> (Descriptor -> Descriptor) -> IO () modify ((Pt ref) as point) func = - IO.readIORef pointInfoDecoder ref + IO.readIORef pointInfoCodec ref |> IO.bind (\pInfo -> case pInfo of Info _ descRef -> - IO.modifyIORef descriptorDecoder descriptorEncoder descRef func + IO.modifyIORef descriptorCodec descRef func Link (Pt ref1) -> - IO.readIORef pointInfoDecoder ref1 + IO.readIORef pointInfoCodec ref1 |> IO.bind (\link_ -> case link_ of Info _ descRef -> - IO.modifyIORef descriptorDecoder descriptorEncoder descRef func + IO.modifyIORef descriptorCodec descRef func Link _ -> repr point @@ -547,22 +379,22 @@ union p1 p2 newDesc = repr p2 |> IO.bind (\((Pt ref2) as point2) -> - IO.readIORef pointInfoDecoder ref1 + IO.readIORef pointInfoCodec ref1 |> IO.bind (\pointInfo1 -> - IO.readIORef pointInfoDecoder ref2 + IO.readIORef pointInfoCodec ref2 |> IO.bind (\pointInfo2 -> case ( pointInfo1, pointInfo2 ) of ( Info w1 d1, Info w2 d2 ) -> if point1 == point2 then - IO.writeIORef descriptorEncoder d1 newDesc + IO.writeIORef descriptorCodec d1 newDesc else - IO.readIORef Decode.int w1 + IO.readIORef Serialize.int w1 |> IO.bind (\weight1 -> - IO.readIORef Decode.int w2 + IO.readIORef Serialize.int w2 |> IO.bind (\weight2 -> let @@ -571,14 +403,14 @@ union p1 p2 newDesc = weight1 + weight2 in if weight1 >= weight2 then - IO.writeIORef pointInfoEncoder ref2 (Link point1) - |> IO.bind (\_ -> IO.writeIORef Encode.int w1 newWeight) - |> IO.bind (\_ -> IO.writeIORef descriptorEncoder d1 newDesc) + IO.writeIORef pointInfoCodec ref2 (Link point1) + |> IO.bind (\_ -> IO.writeIORef Serialize.int w1 newWeight) + |> IO.bind (\_ -> IO.writeIORef descriptorCodec d1 newDesc) else - IO.writeIORef pointInfoEncoder ref1 (Link point2) - |> IO.bind (\_ -> IO.writeIORef Encode.int w2 newWeight) - |> IO.bind (\_ -> IO.writeIORef descriptorEncoder d2 newDesc) + IO.writeIORef pointInfoCodec ref1 (Link point2) + |> IO.bind (\_ -> IO.writeIORef Serialize.int w2 newWeight) + |> IO.bind (\_ -> IO.writeIORef descriptorCodec d2 newDesc) ) ) @@ -602,7 +434,7 @@ equivalent p1 p2 = redundant : Point -> IO Bool redundant (Pt ref) = - IO.readIORef pointInfoDecoder ref + IO.readIORef pointInfoCodec ref |> IO.fmap (\pInfo -> case pInfo of diff --git a/src/Data/IO.elm b/src/Data/IO.elm index 9da64c79b..ebfbb2e2f 100644 --- a/src/Data/IO.elm +++ b/src/Data/IO.elm @@ -29,6 +29,7 @@ module Data.IO exposing , hIsTerminalDevice , hPutStr , hPutStrLn + , ioRefCodec , ioRefDecoder , ioRefEncoder , liftIO @@ -65,6 +66,7 @@ import Array exposing (Array) import Array.Extra as Array import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) make : Decode.Decoder a -> Effect -> IO a @@ -223,25 +225,30 @@ ioRefDecoder = Decode.map IORef Decode.int -newIORef : (a -> Encode.Value) -> a -> IO (IORef a) -newIORef encoder value = - make (Decode.map IORef Decode.int) (NewIORef (encoder value)) +ioRefCodec : Codec e (IORef a) +ioRefCodec = + Serialize.int |> Serialize.map IORef (\(IORef value) -> value) -readIORef : Decode.Decoder a -> IORef a -> IO a -readIORef decoder (IORef ref) = - make decoder (ReadIORef ref) +newIORef : Codec e a -> a -> IO (IORef a) +newIORef codec value = + make (Decode.map IORef Decode.int) (NewIORef (Serialize.encodeToJson codec value)) -writeIORef : (b -> Encode.Value) -> IORef a -> b -> IO () -writeIORef encoder (IORef ref) value = - make (Decode.succeed ()) (WriteIORef ref (encoder value)) +readIORef : Codec e a -> IORef a -> IO a +readIORef codec (IORef ref) = + make (Serialize.getJsonDecoder (\_ -> "failure on readIORef...") codec) (ReadIORef ref) -modifyIORef : Decode.Decoder a -> (a -> Encode.Value) -> IORef a -> (a -> a) -> IO () -modifyIORef decoder encoder ioRef func = - readIORef decoder ioRef - |> bind (\value -> writeIORef encoder ioRef (func value)) +writeIORef : Codec e b -> IORef a -> b -> IO () +writeIORef codec (IORef ref) value = + make (Decode.succeed ()) (WriteIORef ref (Serialize.encodeToJson codec value)) + + +modifyIORef : Codec e a -> IORef a -> (a -> a) -> IO () +modifyIORef codec ioRef func = + readIORef codec ioRef + |> bind (\value -> writeIORef codec ioRef (func value)) pure : a -> IO a @@ -293,77 +300,53 @@ foldrM f z0 xs = List.foldl c pure xs z0 -mVectorReplicate : (a -> Encode.Value) -> Int -> a -> IO (IORef (Array (Maybe a))) -mVectorReplicate encoder n e = - newIORef - (Encode.array - (Maybe.map encoder - >> Maybe.withDefault Encode.null - ) - ) - (Array.repeat n (Just e)) +mVectorReplicate : Codec e a -> Int -> a -> IO (IORef (Array (Maybe a))) +mVectorReplicate codec n e = + newIORef (Serialize.array (Serialize.maybe codec)) (Array.repeat n (Just e)) -mVectorLength : IORef (Array (Maybe a)) -> IO Int -mVectorLength = - readIORef (Decode.array (Decode.succeed Nothing)) +mVectorLength : Codec e a -> IORef (Array (Maybe a)) -> IO Int +mVectorLength codec = + readIORef (Serialize.array (Serialize.maybe codec)) >> fmap Array.length -mVectorGrow : Decode.Decoder a -> (a -> Encode.Value) -> IORef (Array (Maybe a)) -> Int -> IO (IORef (Array (Maybe a))) -mVectorGrow decoder encoder ioRef length = - readIORef (Decode.array (Decode.maybe decoder)) ioRef +mVectorGrow : Codec e a -> IORef (Array (Maybe a)) -> Int -> IO (IORef (Array (Maybe a))) +mVectorGrow codec ioRef length = + readIORef (Serialize.array (Serialize.maybe codec)) ioRef |> bind (\value -> - writeIORef - (Encode.array - (Maybe.map encoder - >> Maybe.withDefault Encode.null - ) - ) + writeIORef (Serialize.array (Serialize.maybe codec)) ioRef (Array.append value (Array.repeat length Nothing)) ) |> fmap (\_ -> ioRef) -mVectorWrite : Decode.Decoder a -> (a -> Encode.Value) -> IORef (Array (Maybe a)) -> Int -> a -> IO () -mVectorWrite decoder encoder ioRef i x = - modifyIORef (Decode.array (Decode.maybe decoder)) - (Encode.array - (Maybe.map encoder - >> Maybe.withDefault Encode.null - ) - ) +mVectorWrite : Codec e a -> IORef (Array (Maybe a)) -> Int -> a -> IO () +mVectorWrite codec ioRef i x = + modifyIORef (Serialize.array (Serialize.maybe codec)) ioRef (Array.set i (Just x)) -mVectorRead : Decode.Decoder a -> (a -> Encode.Value) -> IORef (Array (Maybe a)) -> Int -> IO a -mVectorRead decoder encoder ioRef i = - readIORef (Decode.array (Decode.maybe decoder)) ioRef +mVectorRead : Codec e a -> IORef (Array (Maybe a)) -> Int -> IO a +mVectorRead codec ioRef i = + let + arrayCodec = + Serialize.array (Serialize.maybe codec) + in + readIORef arrayCodec ioRef |> bind (\vector -> - make decoder - (MVectorRead i - (Encode.array - (\maybeValue -> - case maybeValue of - Just value -> - encoder value - - Nothing -> - Encode.null - ) - vector - ) - ) + make (Serialize.getJsonDecoder (\_ -> "failure on mVectorRead") codec) + (MVectorRead i (Serialize.encodeToJson arrayCodec vector)) ) -vectorImapM_ : Decode.Decoder a -> (Int -> a -> IO b) -> IORef (Array (Maybe a)) -> IO () -vectorImapM_ decoder action ioRef = - readIORef (Decode.array (Decode.maybe decoder)) ioRef +vectorImapM_ : Codec e a -> (Int -> a -> IO b) -> IORef (Array (Maybe a)) -> IO () +vectorImapM_ codec action ioRef = + readIORef (Serialize.array (Serialize.maybe codec)) ioRef |> bind (\value -> Array.foldl @@ -386,14 +369,14 @@ vectorImapM_ decoder action ioRef = ) -vectorMapM_ : Decode.Decoder a -> (a -> IO b) -> IORef (Array (Maybe a)) -> IO () -vectorMapM_ decoder action ioRef = - vectorImapM_ decoder (\_ -> action) ioRef +vectorMapM_ : Codec e a -> (a -> IO b) -> IORef (Array (Maybe a)) -> IO () +vectorMapM_ codec action ioRef = + vectorImapM_ codec (\_ -> action) ioRef -vectorForM_ : Decode.Decoder a -> IORef (Array (Maybe a)) -> (a -> IO b) -> IO () -vectorForM_ decoder ioRef action = - vectorMapM_ decoder action ioRef +vectorForM_ : Codec e a -> IORef (Array (Maybe a)) -> (a -> IO b) -> IO () +vectorForM_ codec ioRef action = + vectorMapM_ codec action ioRef vectorUnsafeInit : IORef (Array (Maybe a)) -> IORef (Array (Maybe a)) @@ -401,32 +384,22 @@ vectorUnsafeInit = identity -mVectorModify : Decode.Decoder a -> (a -> Encode.Value) -> IORef (Array (Maybe a)) -> (a -> a) -> Int -> IO () -mVectorModify decoder encoder ioRef func index = - modifyIORef (Decode.array (Decode.maybe decoder)) - (Encode.array - (Maybe.map encoder - >> Maybe.withDefault Encode.null - ) - ) - ioRef - (Array.update index (Maybe.map func)) +mVectorModify : Codec e a -> IORef (Array (Maybe a)) -> (a -> a) -> Int -> IO () +mVectorModify codec ioRef func index = + modifyIORef (Serialize.array (Serialize.maybe codec)) ioRef (Array.update index (Maybe.map func)) -vectorUnsafeLast : Decode.Decoder a -> (a -> Encode.Value) -> IORef (Array (Maybe a)) -> IO a -vectorUnsafeLast decoder encoder ioRef = - readIORef (Decode.array (Decode.maybe decoder)) ioRef +vectorUnsafeLast : Codec e a -> IORef (Array (Maybe a)) -> IO a +vectorUnsafeLast codec ioRef = + let + arrayCodec = + Serialize.array (Serialize.maybe codec) + in + readIORef arrayCodec ioRef |> bind (\value -> - make decoder - (VectorUnsafeLast - (Encode.array - (Maybe.map encoder - >> Maybe.withDefault Encode.null - ) - value - ) - ) + make (Serialize.getJsonDecoder (\_ -> "failure on vectorUnsafeLast") codec) + (VectorUnsafeLast (Serialize.encodeToJson arrayCodec value)) ) diff --git a/src/Terminal/Bump.elm b/src/Terminal/Bump.elm index ab4766023..73c6427a9 100644 --- a/src/Terminal/Bump.elm +++ b/src/Terminal/Bump.elm @@ -188,7 +188,7 @@ generateDocs root (Outline.PkgOutline _ _ _ _ exposed _ _ _) = e :: es -> Task.eio Exit.BumpBadBuild <| - Build.fromExposed Docs.jsonDecoder Docs.jsonEncoder Reporting.silent root details Build.keepDocs (NE.Nonempty e es) + Build.fromExposed Docs.jsonCodec Reporting.silent root details Build.keepDocs (NE.Nonempty e es) ) diff --git a/src/Terminal/Diff.elm b/src/Terminal/Diff.elm index 189fa6526..c7fddbfbc 100644 --- a/src/Terminal/Diff.elm +++ b/src/Terminal/Diff.elm @@ -216,7 +216,7 @@ generateDocs (Env maybeRoot _ _ _) = e :: es -> Task.eio Exit.DiffBadBuild <| - Build.fromExposed Docs.jsonDecoder Docs.jsonEncoder Reporting.silent root details Build.keepDocs (NE.Nonempty e es) + Build.fromExposed Docs.jsonCodec Reporting.silent root details Build.keepDocs (NE.Nonempty e es) ) diff --git a/src/Terminal/Make.elm b/src/Terminal/Make.elm index 5f12f6aae..cda2c0c69 100644 --- a/src/Terminal/Make.elm +++ b/src/Terminal/Make.elm @@ -25,9 +25,8 @@ import Compiler.Data.NonEmptyList as NE import Compiler.Elm.ModuleName as ModuleName import Compiler.Generate.Html as Html import Data.IO as IO exposing (IO) -import Json.Decode as Decode -import Json.Encode as Encode import Maybe.Extra as Maybe +import Serialize import Terminal.Terminal.Internal exposing (Parser(..)) import Utils.Main as Utils exposing (FilePath) @@ -207,7 +206,7 @@ buildExposed style root details maybeDocs exposed = Maybe.unwrap Build.ignoreDocs Build.writeDocs maybeDocs in Task.eio Exit.MakeCannotBuild <| - Build.fromExposed (Decode.succeed ()) (\_ -> Encode.object []) style root details docsGoal exposed + Build.fromExposed Serialize.unit style root details docsGoal exposed buildPaths : Reporting.Style -> FilePath -> Details.Details -> NE.Nonempty FilePath -> Task Build.Artifacts diff --git a/src/Terminal/Publish.elm b/src/Terminal/Publish.elm index ac912675d..14a5ec366 100644 --- a/src/Terminal/Publish.elm +++ b/src/Terminal/Publish.elm @@ -238,7 +238,7 @@ verifyBuild root = |> Task.bind (\exposed -> Task.eio Exit.PublishBuildProblem <| - Build.fromExposed Docs.jsonDecoder Docs.jsonEncoder Reporting.silent root details Build.keepDocs exposed + Build.fromExposed Docs.jsonCodec Reporting.silent root details Build.keepDocs exposed ) ) ) @@ -423,7 +423,7 @@ verifyZipBuild root = |> Task.bind (\exposed -> Task.eio Exit.PublishZipBuildProblem - (Build.fromExposed Docs.jsonDecoder Docs.jsonEncoder Reporting.silent root details Build.keepDocs exposed) + (Build.fromExposed Docs.jsonCodec Reporting.silent root details Build.keepDocs exposed) |> Task.fmap (\_ -> ()) ) ) diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index 8c7e1e33d..a372bc815 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -1,6 +1,5 @@ module Utils.Main exposing - ( AsyncException(..) - , ChItem + ( ChItem , Chan , FilePath , HttpExceptionContent(..) @@ -83,6 +82,7 @@ module Utils.Main exposing , listTraverseStateT , listTraverse_ , lockWithFileLock + , mVarCodec , mVarDecoder , mVarEncoder , mapFindMin @@ -158,6 +158,7 @@ import Json.Decode as Decode import Json.Encode as Encode import Maybe.Extra as Maybe import Prelude +import Serialize exposing (Codec) import Time import Utils.Crash exposing (crash) @@ -1027,10 +1028,6 @@ type SomeException = SomeException -type AsyncException - = UserInterrupt - - bracket : IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket before after thing = before @@ -1078,40 +1075,40 @@ type MVar a = MVar Int -newMVar : (a -> Encode.Value) -> a -> IO (MVar a) -newMVar encoder value = +newMVar : Codec e a -> a -> IO (MVar a) +newMVar codec value = newEmptyMVar |> IO.bind (\mvar -> - putMVar encoder mvar value + putMVar codec mvar value |> IO.fmap (\_ -> mvar) ) -readMVar : Decode.Decoder a -> MVar a -> IO a -readMVar decoder (MVar ref) = - IO.make decoder (IO.ReadMVar ref) +readMVar : Codec e a -> MVar a -> IO a +readMVar codec (MVar ref) = + IO.make (Serialize.getJsonDecoder (\_ -> "failure on readMVar...") codec) (IO.ReadMVar ref) -modifyMVar : Decode.Decoder a -> (a -> Encode.Value) -> MVar a -> (a -> IO ( a, b )) -> IO b -modifyMVar decoder encoder m io = - takeMVar decoder m +modifyMVar : Codec e a -> MVar a -> (a -> IO ( a, b )) -> IO b +modifyMVar codec m io = + takeMVar codec m |> IO.bind io |> IO.bind (\( a, b ) -> - putMVar encoder m a + putMVar codec m a |> IO.fmap (\_ -> b) ) -takeMVar : Decode.Decoder a -> MVar a -> IO a -takeMVar decoder (MVar ref) = - IO.make decoder (IO.TakeMVar ref) +takeMVar : Codec e a -> MVar a -> IO a +takeMVar codec (MVar ref) = + IO.make (Serialize.getJsonDecoder (\_ -> "failure on takeMVar") codec) (IO.TakeMVar ref) -putMVar : (a -> Encode.Value) -> MVar a -> a -> IO () -putMVar encoder (MVar ref) value = - IO.make (Decode.succeed ()) (IO.PutMVar ref (encoder value)) +putMVar : Codec e a -> MVar a -> a -> IO () +putMVar codec (MVar ref) value = + IO.make (Decode.succeed ()) (IO.PutMVar ref (Serialize.encodeToJson codec value)) newEmptyMVar : IO (MVar a) @@ -1135,15 +1132,15 @@ type ChItem a = ChItem a (Stream a) -newChan : (MVar (ChItem a) -> Encode.Value) -> IO (Chan a) -newChan encoder = +newChan : Codec e (MVar (ChItem a)) -> IO (Chan a) +newChan codec = newEmptyMVar |> IO.bind (\hole -> - newMVar encoder hole + newMVar codec hole |> IO.bind (\readVar -> - newMVar encoder hole + newMVar codec hole |> IO.fmap (\writeVar -> Chan readVar writeVar @@ -1152,11 +1149,11 @@ newChan encoder = ) -readChan : Decode.Decoder a -> Chan a -> IO a -readChan decoder (Chan readVar _) = - modifyMVar mVarDecoder mVarEncoder readVar <| +readChan : Codec e a -> Chan a -> IO a +readChan codec (Chan readVar _) = + modifyMVar mVarCodec readVar <| \read_end -> - readMVar (chItemDecoder decoder) read_end + readMVar (chItemCodec codec) read_end |> IO.fmap (\(ChItem val new_read_end) -> -- Use readMVar here, not takeMVar, @@ -1165,16 +1162,16 @@ readChan decoder (Chan readVar _) = ) -writeChan : (a -> Encode.Value) -> Chan a -> a -> IO () -writeChan encoder (Chan _ writeVar) val = +writeChan : Codec e a -> Chan a -> a -> IO () +writeChan codec (Chan _ writeVar) val = newEmptyMVar |> IO.bind (\new_hole -> - takeMVar mVarDecoder writeVar + takeMVar mVarCodec writeVar |> IO.bind (\old_hole -> - putMVar (chItemEncoder encoder) old_hole (ChItem val new_hole) - |> IO.bind (\_ -> putMVar mVarEncoder writeVar new_hole) + putMVar (chItemCodec codec) old_hole (ChItem val new_hole) + |> IO.bind (\_ -> putMVar mVarCodec writeVar new_hole) ) ) @@ -1206,20 +1203,20 @@ builderHPutBuilder handle str = -- Data.Binary -binaryDecodeFileOrFail : Decode.Decoder a -> FilePath -> IO (Result ( Int, String ) a) -binaryDecodeFileOrFail decoder filename = +binaryDecodeFileOrFail : Codec e a -> FilePath -> IO (Result ( Int, String ) a) +binaryDecodeFileOrFail codec filename = IO.make (Decode.oneOf - [ Decode.map Ok decoder + [ Decode.map Ok (Serialize.getJsonDecoder (\_ -> "Could not find file " ++ filename) codec) , Decode.succeed (Err ( 0, "Could not find file " ++ filename )) ] ) (IO.BinaryDecodeFileOrFail filename) -binaryEncodeFile : (a -> Encode.Value) -> FilePath -> a -> IO () -binaryEncodeFile encoder path value = - IO.make (Decode.succeed ()) (IO.Write path (encoder value)) +binaryEncodeFile : Codec e a -> FilePath -> a -> IO () +binaryEncodeFile codec path value = + IO.make (Decode.succeed ()) (IO.Write path (Serialize.encodeToJson codec value)) @@ -1295,28 +1292,29 @@ statePut encoder s = -- ENCODERS and DECODERS -mVarDecoder : Decode.Decoder (MVar a) -mVarDecoder = - Decode.map MVar Decode.int - - mVarEncoder : MVar a -> Encode.Value mVarEncoder (MVar ref) = Encode.int ref -chItemEncoder : (a -> Encode.Value) -> ChItem a -> Encode.Value -chItemEncoder valueEncoder (ChItem value hole) = - Encode.object - [ ( "type", Encode.string "ChItem" ) - , ( "value", valueEncoder value ) - , ( "hole", mVarEncoder hole ) - ] +mVarDecoder : Decode.Decoder (MVar a) +mVarDecoder = + Decode.map MVar Decode.int -chItemDecoder : Decode.Decoder a -> Decode.Decoder (ChItem a) -chItemDecoder decoder = - Decode.map2 ChItem (Decode.field "value" decoder) (Decode.field "hole" mVarDecoder) +mVarCodec : Codec e (MVar a) +mVarCodec = + Serialize.int |> Serialize.map MVar (\(MVar ref) -> ref) + + +chItemCodec : Codec e a -> Codec e (ChItem a) +chItemCodec codec = + Serialize.customType + (\chItemCodecEncoder (ChItem value hole) -> + chItemCodecEncoder value hole + ) + |> Serialize.variant2 ChItem codec mVarCodec + |> Serialize.finishCustomType someExceptionEncoder : SomeException -> Encode.Value From 8306dc697770a1fad49e5909ac22626277db045a Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Sat, 9 Nov 2024 20:09:00 +0000 Subject: [PATCH 2/7] WIP elm-serialize --- src/Builder/BackgroundWriter.elm | 2 - src/Builder/Build.elm | 667 ++++++------------------ src/Builder/Deps/Solver.elm | 7 + src/Builder/Elm/Details.elm | 244 ++------- src/Builder/Http.elm | 7 +- src/Builder/Reporting/Exit.elm | 25 +- src/Compiler/AST/Source.elm | 7 + src/Compiler/Elm/Docs.elm | 6 + src/Compiler/Reporting/Error/Import.elm | 7 + src/Compiler/Reporting/Error/Syntax.elm | 7 + 10 files changed, 290 insertions(+), 689 deletions(-) diff --git a/src/Builder/BackgroundWriter.elm b/src/Builder/BackgroundWriter.elm index eb8de170a..1a625664f 100644 --- a/src/Builder/BackgroundWriter.elm +++ b/src/Builder/BackgroundWriter.elm @@ -6,8 +6,6 @@ module Builder.BackgroundWriter exposing import Builder.File as File import Data.IO as IO exposing (IO) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import Utils.Main as Utils diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm index bca6be70b..ec6315b0c 100644 --- a/src/Builder/Build.elm +++ b/src/Builder/Build.elm @@ -37,7 +37,6 @@ import Compiler.Elm.Docs as Docs import Compiler.Elm.Interface as I import Compiler.Elm.ModuleName as ModuleName import Compiler.Elm.Package as Pkg -import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Parse.Module as Parse import Compiler.Reporting.Annotation as A @@ -52,7 +51,6 @@ import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) import Data.Set as EverySet import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils exposing (FilePath, MVar(..)) @@ -1841,116 +1839,55 @@ dictRawMVarBResultCodec = S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec -bResultEncoder : BResult -> Encode.Value -bResultEncoder bResult = - case bResult of - RNew local iface objects docs -> - Encode.object - [ ( "type", Encode.string "RNew" ) - , ( "local", Details.localEncoder local ) - , ( "iface", I.interfaceEncoder iface ) - , ( "objects", Opt.localGraphEncoder objects ) - , ( "docs" - , docs - |> Maybe.map Docs.jsonModuleEncoder - |> Maybe.withDefault Encode.null - ) - ] - - RSame local iface objects docs -> - Encode.object - [ ( "type", Encode.string "RSame" ) - , ( "local", Details.localEncoder local ) - , ( "iface", I.interfaceEncoder iface ) - , ( "objects", Opt.localGraphEncoder objects ) - , ( "docs", E.maybe Docs.jsonModuleEncoder docs ) - ] - - RCached main lastChange (MVar ref) -> - Encode.object - [ ( "type", Encode.string "RCached" ) - , ( "main", Encode.bool main ) - , ( "lastChange", Encode.int lastChange ) - , ( "mvar", Encode.int ref ) - ] - - RNotFound importProblem -> - Encode.object - [ ( "type", Encode.string "RNotFound" ) - , ( "importProblem", Import.problemEncoder importProblem ) - ] +bResultCodec : Codec e BResult +bResultCodec = + Serialize.customType + (\rNewEncoder rSameEncoder rCachedEncoder rNotFoundEncoder rProblemEncoder rBlockedEncoder rForeignEncoder rKernelEncoder bResult -> + case bResult of + RNew local iface objects docs -> + rNewEncoder local iface objects docs - RProblem e -> - Encode.object - [ ( "type", Encode.string "RProblem" ) - , ( "e", Error.moduleEncoder e ) - ] + RSame local iface objects docs -> + rSameEncoder local iface objects docs - RBlocked -> - Encode.object [ ( "type", Encode.string "RBlocked" ) ] + RCached main lastChange mVar -> + rCachedEncoder main lastChange mVar - RForeign iface -> - Encode.object - [ ( "type", Encode.string "RForeign" ) - , ( "iface", I.interfaceEncoder iface ) - ] + RNotFound importProblem -> + rNotFoundEncoder importProblem - RKernel -> - Encode.object [ ( "type", Encode.string "RKernel" ) ] + RProblem e -> + rProblemEncoder e + RBlocked -> + rBlockedEncoder -bResultDecoder : Decode.Decoder BResult -bResultDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "RNew" -> - Decode.map4 RNew - (Decode.field "local" Details.localDecoder) - (Decode.field "iface" I.interfaceDecoder) - (Decode.field "objects" Opt.localGraphDecoder) - (Decode.field "docs" (Decode.maybe Docs.jsonModuleDecoder)) - - "RSame" -> - Decode.map4 RSame - (Decode.field "local" Details.localDecoder) - (Decode.field "iface" I.interfaceDecoder) - (Decode.field "objects" Opt.localGraphDecoder) - (Decode.field "docs" (Decode.maybe Docs.jsonModuleDecoder)) - - "RCached" -> - Decode.map3 RCached - (Decode.field "main" Decode.bool) - (Decode.field "lastChange" Decode.int) - (Decode.field "mvar" (Decode.map MVar Decode.int)) - - "RNotFound" -> - Decode.map RNotFound - (Decode.field "importProblem" Import.problemDecoder) - - "RProblem" -> - Decode.map RProblem - (Decode.field "e" Error.moduleDecoder) - - "RBlocked" -> - Decode.succeed RBlocked - - "RForeign" -> - Decode.map RForeign - (Decode.field "iface" I.interfaceDecoder) - - "RKernel" -> - Decode.succeed RKernel + RForeign iface -> + rForeignEncoder iface - _ -> - Decode.fail ("Failed to decode BResult's type: " ++ type_) - ) - - -bResultCodec : Codec e BResult -bResultCodec = - Debug.todo "bResultCodec" + RKernel -> + rKernelEncoder + ) + |> Serialize.variant4 RNew + Details.localCodec + I.interfaceCodec + Opt.localGraphCodec + (Serialize.maybe Docs.jsonModuleCodec) + |> Serialize.variant4 RSame + Details.localCodec + I.interfaceCodec + Opt.localGraphCodec + (Serialize.maybe Docs.jsonModuleCodec) + |> Serialize.variant3 RCached + Serialize.bool + Serialize.int + (Serialize.int |> Serialize.map MVar (\(MVar ref) -> ref)) + |> Serialize.variant1 RNotFound Import.problemCodec + |> Serialize.variant1 RProblem Error.moduleCodec + |> Serialize.variant0 RBlocked + |> Serialize.variant1 RForeign I.interfaceCodec + |> Serialize.variant0 RKernel + |> Serialize.finishCustomType statusDictCodec : Codec e StatusDict @@ -1958,143 +1895,56 @@ statusDictCodec = S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec -statusEncoder : Status -> Encode.Value -statusEncoder status = - case status of - SCached local -> - Encode.object - [ ( "type", Encode.string "SCached" ) - , ( "local", Details.localEncoder local ) - ] - - SChanged local iface objects docs -> - Encode.object - [ ( "type", Encode.string "SChanged" ) - , ( "local", Details.localEncoder local ) - , ( "iface", Encode.string iface ) - , ( "objects", Src.moduleEncoder objects ) - , ( "docs", docsNeedEncoder docs ) - ] - - SBadImport importProblem -> - Encode.object - [ ( "type", Encode.string "SBadImport" ) - , ( "importProblem", Import.problemEncoder importProblem ) - ] - - SBadSyntax path time source err -> - Encode.object - [ ( "type", Encode.string "SBadSyntax" ) - , ( "path", Encode.string path ) - , ( "time", File.timeEncoder time ) - , ( "source", Encode.string source ) - , ( "err", Syntax.errorEncoder err ) - ] - - SForeign home -> - Encode.object - [ ( "type", Encode.string "SForeign" ) - , ( "home", Pkg.nameEncoder home ) - ] - - SKernel -> - Encode.object - [ ( "type", Encode.string "SKernel" ) - ] - - -statusDecoder : Decode.Decoder Status -statusDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "SCached" -> - Decode.map SCached (Decode.field "local" Details.localDecoder) - - "SChanged" -> - Decode.map4 SChanged - (Decode.field "local" Details.localDecoder) - (Decode.field "iface" Decode.string) - (Decode.field "objects" Src.moduleDecoder) - (Decode.field "docs" docsNeedDecoder) - - "SBadImport" -> - Decode.map SBadImport (Decode.field "importProblem" Import.problemDecoder) - - "SBadSyntax" -> - Decode.map4 SBadSyntax - (Decode.field "path" Decode.string) - (Decode.field "time" File.timeDecoder) - (Decode.field "source" Decode.string) - (Decode.field "err" Syntax.errorDecoder) - - "SForeign" -> - Decode.map SForeign (Decode.field "home" Pkg.nameDecoder) - - "SKernel" -> - Decode.succeed SKernel - - _ -> - Decode.fail ("Failed to decode Status's type: " ++ type_) - ) - - statusCodec : Codec e Status statusCodec = - Debug.todo "statusCodec" - - -rootStatusEncoder : RootStatus -> Encode.Value -rootStatusEncoder rootStatus = - case rootStatus of - SInside name -> - Encode.object - [ ( "type", Encode.string "SInside" ) - , ( "name", ModuleName.rawEncoder name ) - ] - - SOutsideOk local source modul -> - Encode.object - [ ( "type", Encode.string "SOutsideOk" ) - , ( "local", Details.localEncoder local ) - , ( "source", Encode.string source ) - , ( "modul", Src.moduleEncoder modul ) - ] - - SOutsideErr err -> - Encode.object - [ ( "type", Encode.string "SOutsideErr" ) - , ( "err", Error.moduleEncoder err ) - ] + Serialize.customType + (\sCachedEncoder sChangedEncoder sBadImportEncoder sBadSyntaxEncoder sForeignEncoder sKernelEncoder status -> + case status of + SCached local -> + sCachedEncoder local + SChanged local iface objects docs -> + sChangedEncoder local iface objects docs -rootStatusDecoder : Decode.Decoder RootStatus -rootStatusDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "SInside" -> - Decode.map SInside (Decode.field "name" ModuleName.rawDecoder) + SBadImport importProblem -> + sBadImportEncoder importProblem - "SOutsideOk" -> - Decode.map3 SOutsideOk - (Decode.field "local" Details.localDecoder) - (Decode.field "source" Decode.string) - (Decode.field "modul" Src.moduleDecoder) + SBadSyntax path time source err -> + sBadSyntaxEncoder path time source err - "SOutsideErr" -> - Decode.map SOutsideErr (Decode.field "err" Error.moduleDecoder) + SForeign home -> + sForeignEncoder home - _ -> - Decode.fail ("Failed to decode RootStatus' type: " ++ type_) - ) + SKernel -> + sKernelEncoder + ) + |> Serialize.variant1 SCached Details.localCodec + |> Serialize.variant4 SChanged Details.localCodec Serialize.string Src.moduleCodec docsNeedCodec + |> Serialize.variant1 SBadImport Import.problemCodec + |> Serialize.variant4 SBadSyntax Serialize.string File.timeCodec Serialize.string Syntax.errorCodec + |> Serialize.variant1 SForeign Pkg.nameCodec + |> Serialize.variant0 SKernel + |> Serialize.finishCustomType rootStatusCodec : Codec e RootStatus rootStatusCodec = - Debug.todo "rootStatusCodec" + Serialize.customType + (\sInsideEncoder sOutsideOkEncoder sOutsideErrEncoder rootStatus -> + case rootStatus of + SInside name -> + sInsideEncoder name + + SOutsideOk local source modul -> + sOutsideOkEncoder local source modul + + SOutsideErr err -> + sOutsideErrEncoder err + ) + |> Serialize.variant1 SInside ModuleName.rawCodec + |> Serialize.variant3 SOutsideOk Details.localCodec Serialize.string Src.moduleCodec + |> Serialize.variant1 SOutsideErr Error.moduleCodec + |> Serialize.finishCustomType resultDictCodec : Codec e ResultDict @@ -2102,74 +1952,28 @@ resultDictCodec = S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec -rootResultEncoder : RootResult -> Encode.Value -rootResultEncoder rootResult = - case rootResult of - RInside name -> - Encode.object - [ ( "type", Encode.string "RInside" ) - , ( "name", ModuleName.rawEncoder name ) - ] - - ROutsideOk name iface objs -> - Encode.object - [ ( "type", Encode.string "ROutsideOk" ) - , ( "name", ModuleName.rawEncoder name ) - , ( "iface", I.interfaceEncoder iface ) - , ( "objs", Opt.localGraphEncoder objs ) - ] - - ROutsideErr err -> - Encode.object - [ ( "type", Encode.string "ROutsideErr" ) - , ( "err", Error.moduleEncoder err ) - ] - - ROutsideBlocked -> - Encode.object - [ ( "type", Encode.string "ROutsideBlocked" ) - ] - - -rootResultDecoder : Decode.Decoder RootResult -rootResultDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "RInside" -> - Decode.map RInside (Decode.field "name" ModuleName.rawDecoder) - - "ROutsideOk" -> - Decode.map3 ROutsideOk - (Decode.field "name" ModuleName.rawDecoder) - (Decode.field "iface" I.interfaceDecoder) - (Decode.field "objs" Opt.localGraphDecoder) - - "ROutsideErr" -> - Decode.map ROutsideErr (Decode.field "err" Error.moduleDecoder) - - "ROutsideBlocked" -> - Decode.succeed ROutsideBlocked - - _ -> - Decode.fail ("Failed to decode RootResult's type: " ++ type_) - ) - - rootResultCodec : Codec e RootResult rootResultCodec = - Debug.todo "rootResultCodec" + Serialize.customType + (\rInsideEncoder rOutsideOkEncoder rOutsideErrEncoder rOutsideBlockedEncoder rootResult -> + case rootResult of + RInside name -> + rInsideEncoder name + ROutsideOk name iface objs -> + rOutsideOkEncoder name iface objs -maybeDepEncoder : Maybe Dep -> Encode.Value -maybeDepEncoder = - E.maybe depEncoder + ROutsideErr err -> + rOutsideErrEncoder err - -maybeDepDecoder : Decode.Decoder (Maybe Dep) -maybeDepDecoder = - Decode.maybe depDecoder + ROutsideBlocked -> + rOutsideBlockedEncoder + ) + |> Serialize.variant1 RInside ModuleName.rawCodec + |> Serialize.variant3 ROutsideOk ModuleName.rawCodec I.interfaceCodec Opt.localGraphCodec + |> Serialize.variant1 ROutsideErr Error.moduleCodec + |> Serialize.variant0 ROutsideBlocked + |> Serialize.finishCustomType maybeDepCodec : Codec e (Maybe Dep) @@ -2177,19 +1981,9 @@ maybeDepCodec = Serialize.maybe depCodec -depEncoder : Dep -> Encode.Value -depEncoder = - E.jsonPair ModuleName.rawEncoder I.interfaceEncoder - - -depDecoder : Decode.Decoder Dep -depDecoder = - D.jsonPair ModuleName.rawDecoder I.interfaceDecoder - - depCodec : Codec e Dep depCodec = - Debug.todo "depCodec" + Serialize.tuple ModuleName.rawCodec I.interfaceCodec maybeDependenciesCodec : Codec e (Maybe Dependencies) @@ -2197,41 +1991,11 @@ maybeDependenciesCodec = Serialize.maybe (S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec) -resultBuildProjectProblemRootInfoEncoder : Result Exit.BuildProjectProblem RootInfo -> Encode.Value -resultBuildProjectProblemRootInfoEncoder = - E.result Exit.buildProjectProblemEncoder rootInfoEncoder - - -resultBuildProjectProblemRootInfoDecoder : Decode.Decoder (Result Exit.BuildProjectProblem RootInfo) -resultBuildProjectProblemRootInfoDecoder = - D.result Exit.buildProjectProblemDecoder rootInfoDecoder - - resultBuildProjectProblemRootInfoCodec : Codec e (Result Exit.BuildProjectProblem RootInfo) resultBuildProjectProblemRootInfoCodec = Serialize.result Exit.buildProjectProblemCodec rootInfoCodec -cachedInterfaceEncoder : CachedInterface -> Encode.Value -cachedInterfaceEncoder cachedInterface = - case cachedInterface of - Unneeded -> - Encode.object - [ ( "type", Encode.string "Unneeded" ) - ] - - Loaded iface -> - Encode.object - [ ( "type", Encode.string "Loaded" ) - , ( "iface", I.interfaceEncoder iface ) - ] - - Corrupted -> - Encode.object - [ ( "type", Encode.string "Corrupted" ) - ] - - cachedInterfaceDecoder : Decode.Decoder CachedInterface cachedInterfaceDecoder = Decode.field "type" Decode.string @@ -2254,186 +2018,97 @@ cachedInterfaceDecoder = cachedInterfaceCodec : Codec e CachedInterface cachedInterfaceCodec = - Debug.todo "cachedInterfaceCodec" - - -docsNeedEncoder : DocsNeed -> Encode.Value -docsNeedEncoder (DocsNeed isNeeded) = - Encode.bool isNeeded + Serialize.customType + (\unneededEncoder loadedEncoder corruptedEncoder cachedInterface -> + case cachedInterface of + Unneeded -> + unneededEncoder + Loaded iface -> + loadedEncoder iface -docsNeedDecoder : Decode.Decoder DocsNeed -docsNeedDecoder = - Decode.map DocsNeed Decode.bool - - -artifactsEncoder : Artifacts -> Encode.Value -artifactsEncoder (Artifacts pkg ifaces roots modules) = - Encode.object - [ ( "type", Encode.string "Artifacts" ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "ifaces", dependenciesEncoder ifaces ) - , ( "roots", E.nonempty rootEncoder roots ) - , ( "modules", Encode.list moduleEncoder modules ) - ] + Corrupted -> + corruptedEncoder + ) + |> Serialize.variant0 Unneeded + |> Serialize.variant1 Loaded I.interfaceCodec + |> Serialize.variant0 Corrupted + |> Serialize.finishCustomType -artifactsDecoder : Decode.Decoder Artifacts -artifactsDecoder = - Decode.map4 Artifacts - (Decode.field "pkg" Pkg.nameDecoder) - (Decode.field "ifaces" dependenciesDecoder) - (Decode.field "roots" (D.nonempty rootDecoder)) - (Decode.field "modules" (Decode.list moduleDecoder)) +docsNeedCodec : Codec e DocsNeed +docsNeedCodec = + Serialize.bool |> Serialize.map DocsNeed (\(DocsNeed isNeeded) -> isNeeded) -artifactsCodec : Codec e Artifacts +artifactsCodec : Codec (Serialize.Error e) Artifacts artifactsCodec = - Debug.todo "artifactsCodec" - - -dependenciesEncoder : Dependencies -> Encode.Value -dependenciesEncoder = - E.assocListDict ModuleName.canonicalEncoder I.dependencyInterfaceEncoder - - -dependenciesDecoder : Decode.Decoder Dependencies -dependenciesDecoder = - D.assocListDict ModuleName.compareCanonical ModuleName.canonicalDecoder I.dependencyInterfaceDecoder - + Serialize.customType + (\artifactsCodecEncoder (Artifacts pkg ifaces roots modules) -> + artifactsCodecEncoder pkg ifaces roots modules + ) + |> Serialize.variant4 Artifacts Pkg.nameCodec dependenciesCodec (S.nonempty rootCodec) (Serialize.list moduleCodec) + |> Serialize.finishCustomType -rootEncoder : Root -> Encode.Value -rootEncoder root = - case root of - Inside name -> - Encode.object - [ ( "type", Encode.string "Inside" ) - , ( "name", ModuleName.rawEncoder name ) - ] - - Outside name main mvar -> - Encode.object - [ ( "type", Encode.string "Outside" ) - , ( "name", ModuleName.rawEncoder name ) - , ( "main", I.interfaceEncoder main ) - , ( "mvar", Opt.localGraphEncoder mvar ) - ] - - -rootDecoder : Decode.Decoder Root -rootDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Inside" -> - Decode.map Inside (Decode.field "name" ModuleName.rawDecoder) - "Outside" -> - Decode.map3 Outside - (Decode.field "name" ModuleName.rawDecoder) - (Decode.field "main" I.interfaceDecoder) - (Decode.field "mvar" Opt.localGraphDecoder) +dependenciesCodec : Codec e Dependencies +dependenciesCodec = + S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec - _ -> - Decode.fail ("Failed to decode Root's type: " ++ type_) - ) +rootCodec : Codec e Root +rootCodec = + Serialize.customType + (\insideEncoder outsideEncoder root -> + case root of + Inside name -> + insideEncoder name -moduleEncoder : Module -> Encode.Value -moduleEncoder modul = - case modul of - Fresh name iface objs -> - Encode.object - [ ( "type", Encode.string "Fresh" ) - , ( "name", ModuleName.rawEncoder name ) - , ( "iface", I.interfaceEncoder iface ) - , ( "objs", Opt.localGraphEncoder objs ) - ] - - Cached name main mvar -> - Encode.object - [ ( "type", Encode.string "Cached" ) - , ( "name", ModuleName.rawEncoder name ) - , ( "main", Encode.bool main ) - , ( "mvar", Utils.mVarEncoder mvar ) - ] - - -moduleDecoder : Decode.Decoder Module -moduleDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Fresh" -> - Decode.map3 Fresh - (Decode.field "name" ModuleName.rawDecoder) - (Decode.field "iface" I.interfaceDecoder) - (Decode.field "objs" Opt.localGraphDecoder) - - "Cached" -> - Decode.map3 Cached - (Decode.field "name" ModuleName.rawDecoder) - (Decode.field "main" Decode.bool) - (Decode.field "mvar" Utils.mVarDecoder) - - _ -> - Decode.fail ("Failed to decode Module's type: " ++ type_) - ) - + Outside name main mvar -> + outsideEncoder name main mvar + ) + |> Serialize.variant1 Inside ModuleName.rawCodec + |> Serialize.variant3 Outside ModuleName.rawCodec I.interfaceCodec Opt.localGraphCodec + |> Serialize.finishCustomType -rootInfoEncoder : RootInfo -> Encode.Value -rootInfoEncoder (RootInfo absolute relative location) = - Encode.object - [ ( "type", Encode.string "RootInfo" ) - , ( "absolute", Encode.string absolute ) - , ( "relative", Encode.string relative ) - , ( "location", rootLocationEncoder location ) - ] +moduleCodec : Codec e Module +moduleCodec = + Serialize.customType + (\freshEncoder cachedEncoder modul -> + case modul of + Fresh name iface objs -> + freshEncoder name iface objs -rootInfoDecoder : Decode.Decoder RootInfo -rootInfoDecoder = - Decode.map3 RootInfo - (Decode.field "absolute" Decode.string) - (Decode.field "relative" Decode.string) - (Decode.field "location" rootLocationDecoder) + Cached name main mvar -> + cachedEncoder name main mvar + ) + |> Serialize.variant3 Fresh ModuleName.rawCodec I.interfaceCodec Opt.localGraphCodec + |> Serialize.variant3 Cached ModuleName.rawCodec Serialize.bool Utils.mVarCodec + |> Serialize.finishCustomType rootInfoCodec : Codec e RootInfo rootInfoCodec = - Debug.todo "rootInfoCodec" - - -rootLocationEncoder : RootLocation -> Encode.Value -rootLocationEncoder rootLocation = - case rootLocation of - LInside name -> - Encode.object - [ ( "type", Encode.string "LInside" ) - , ( "name", ModuleName.rawEncoder name ) - ] - - LOutside path -> - Encode.object - [ ( "type", Encode.string "LOutside" ) - , ( "path", Encode.string path ) - ] - + Serialize.customType + (\rootInfoCodecEncoder (RootInfo absolute relative location) -> + rootInfoCodecEncoder absolute relative location + ) + |> Serialize.variant3 RootInfo Serialize.string Serialize.string rootLocationCodec + |> Serialize.finishCustomType -rootLocationDecoder : Decode.Decoder RootLocation -rootLocationDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "LInside" -> - Decode.map LInside (Decode.field "name" ModuleName.rawDecoder) - "LOutside" -> - Decode.map LOutside (Decode.field "path" Decode.string) +rootLocationCodec : Codec e RootLocation +rootLocationCodec = + Serialize.customType + (\lInsideEncoder lOutsideEncoder rootLocation -> + case rootLocation of + LInside name -> + lInsideEncoder name - _ -> - Decode.fail ("Failed to decode RootLocation's type: " ++ type_) - ) + LOutside path -> + lOutsideEncoder path + ) + |> Serialize.variant1 LInside ModuleName.rawCodec + |> Serialize.variant1 LOutside Serialize.string + |> Serialize.finishCustomType diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index 3be35ef61..fa85a1cf5 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -8,6 +8,7 @@ module Builder.Deps.Solver exposing , SolverResult(..) , State , addToApp + , envCodec , envDecoder , envEncoder , initEnv @@ -29,6 +30,7 @@ import Data.IO as IO exposing (IO) import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils @@ -614,6 +616,11 @@ envDecoder = (Decode.field "registry" Registry.registryDecoder) +envCodec : Codec e Env +envCodec = + Debug.todo "envCodec" + + connectionEncoder : Connection -> Encode.Value connectionEncoder connection = case connection of diff --git a/src/Builder/Elm/Details.elm b/src/Builder/Elm/Details.elm index df3b6b463..290705512 100644 --- a/src/Builder/Elm/Details.elm +++ b/src/Builder/Elm/Details.elm @@ -12,6 +12,7 @@ module Builder.Elm.Details exposing , load , loadInterfaces , loadObjects + , localCodec , localDecoder , localEncoder , verifyInstall @@ -1124,24 +1125,9 @@ interfacesCodec = S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec -resultRegistryProblemEnvEncoder : Result Exit.RegistryProblem Solver.Env -> Encode.Value -resultRegistryProblemEnvEncoder = - E.result Exit.registryProblemEncoder Solver.envEncoder - - -resultRegistryProblemEnvDecoder : Decode.Decoder (Result Exit.RegistryProblem Solver.Env) -resultRegistryProblemEnvDecoder = - D.result Exit.registryProblemDecoder Solver.envDecoder - - resultRegistryProblemEnvCodec : Codec e (Result Exit.RegistryProblem Solver.Env) resultRegistryProblemEnvCodec = - Debug.todo "resultRegistryProblemEnvCodec" - - -depDecoder : Decode.Decoder Dep -depDecoder = - D.result (Decode.maybe Exit.detailsBadDepDecoder) artifactsDecoder + Serialize.result Exit.registryProblemCodec Solver.envCodec depCodec : Codec e Dep @@ -1149,13 +1135,6 @@ depCodec = Serialize.result (Serialize.maybe Exit.detailsBadDepCodec) artifactsCodec -artifactsDecoder : Decode.Decoder Artifacts -artifactsDecoder = - Decode.map2 Artifacts - (Decode.field "ifaces" (D.assocListDict compare ModuleName.rawDecoder I.dependencyInterfaceDecoder)) - (Decode.field "objects" Opt.globalGraphDecoder) - - artifactsCodec : Codec e Artifacts artifactsCodec = Serialize.customType @@ -1166,14 +1145,9 @@ artifactsCodec = |> Serialize.finishCustomType -dictNameMVarDepEncoder : Dict Pkg.Name (MVar Dep) -> Encode.Value -dictNameMVarDepEncoder = - E.assocListDict Pkg.nameEncoder Utils.mVarEncoder - - dictNameMVarDepCodec : Codec e (Dict Pkg.Name (MVar Dep)) dictNameMVarDepCodec = - Debug.todo "dictNameMVarDepCodec" + S.assocListDict Pkg.compareName Pkg.nameCodec Utils.mVarCodec artifactCacheCodec : Codec e ArtifactCache @@ -1186,169 +1160,72 @@ artifactCacheCodec = |> Serialize.finishCustomType -dictPkgNameMVarDepDecoder : Decode.Decoder (Dict Pkg.Name (MVar Dep)) -dictPkgNameMVarDepDecoder = - D.assocListDict Pkg.compareName Pkg.nameDecoder Utils.mVarDecoder - - dictPkgNameMVarDepCodec : Codec e (Dict Pkg.Name (MVar Dep)) dictPkgNameMVarDepCodec = - Debug.todo "dictPkgNameMVarDepCodec" - - -statusEncoder : Status -> Encode.Value -statusEncoder status = - case status of - SLocal docsStatus deps modul -> - Encode.object - [ ( "type", Encode.string "SLocal" ) - , ( "docsStatus", docsStatusEncoder docsStatus ) - , ( "deps", E.assocListDict ModuleName.rawEncoder (\_ -> Encode.object []) deps ) - , ( "modul", Src.moduleEncoder modul ) - ] - - SForeign iface -> - Encode.object - [ ( "type", Encode.string "SForeign" ) - , ( "iface", I.interfaceEncoder iface ) - ] - - SKernelLocal chunks -> - Encode.object - [ ( "type", Encode.string "SKernelLocal" ) - , ( "chunks", Encode.list Kernel.chunkEncoder chunks ) - ] - - SKernelForeign -> - Encode.object - [ ( "type", Encode.string "SKernelForeign" ) - ] - - -statusDecoder : Decode.Decoder Status -statusDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "SLocal" -> - Decode.map3 SLocal - (Decode.field "docsStatus" docsStatusDecoder) - (Decode.field "deps" (D.assocListDict compare ModuleName.rawDecoder (Decode.succeed ()))) - (Decode.field "modul" Src.moduleDecoder) - - "SForeign" -> - Decode.map SForeign (Decode.field "iface" I.interfaceDecoder) - - "SKernelLocal" -> - Decode.map SKernelLocal (Decode.field "chunks" (Decode.list Kernel.chunkDecoder)) - - "SKernelForeign" -> - Decode.succeed SKernelForeign - - _ -> - Decode.fail ("Failed to decode Status' type: " ++ type_) - ) + S.assocListDict Pkg.compareName Pkg.nameCodec Utils.mVarCodec statusCodec : Codec e Status statusCodec = - Debug.todo "statusCodec" + Serialize.customType + (\sLocalEncoder sForeignEncoder sKernelLocalEncoder sKernelForeignEncoder status -> + case status of + SLocal docsStatus deps modul -> + sLocalEncoder docsStatus deps modul + SForeign iface -> + sForeignEncoder iface -dictRawMVarMaybeDResultEncoder : Dict ModuleName.Raw (MVar (Maybe DResult)) -> Encode.Value -dictRawMVarMaybeDResultEncoder = - E.assocListDict ModuleName.rawEncoder Utils.mVarEncoder + SKernelLocal chunks -> + sKernelLocalEncoder chunks + + SKernelForeign -> + sKernelForeignEncoder + ) + |> Serialize.variant3 SLocal docsStatusCodec (S.assocListDict 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 = - Debug.todo "dictRawMVarMaybeDResultCodec" - - -moduleNameRawMVarMaybeDResultDecoder : Decode.Decoder (Dict ModuleName.Raw (MVar (Maybe DResult))) -moduleNameRawMVarMaybeDResultDecoder = - D.assocListDict compare ModuleName.rawDecoder Utils.mVarDecoder + S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec moduleNameRawMVarMaybeDResultCodec : Codec e (Dict ModuleName.Raw (MVar (Maybe DResult))) moduleNameRawMVarMaybeDResultCodec = - Debug.todo "moduleNameRawMVarMaybeDResultCodec" - - -dResultEncoder : DResult -> Encode.Value -dResultEncoder dResult = - case dResult of - RLocal ifaces objects docs -> - Encode.object - [ ( "type", Encode.string "RLocal" ) - , ( "ifaces", I.interfaceEncoder ifaces ) - , ( "objects", Opt.localGraphEncoder objects ) - , ( "docs", E.maybe Docs.jsonModuleEncoder docs ) - ] - - RForeign iface -> - Encode.object - [ ( "type", Encode.string "RForeign" ) - , ( "iface", I.interfaceEncoder iface ) - ] - - RKernelLocal chunks -> - Encode.object - [ ( "type", Encode.string "RKernelLocal" ) - , ( "chunks", Encode.list Kernel.chunkEncoder chunks ) - ] - - RKernelForeign -> - Encode.object - [ ( "type", Encode.string "RKernelForeign" ) - ] - - -dResultDecoder : Decode.Decoder DResult -dResultDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "RLocal" -> - Decode.map3 RLocal - (Decode.field "ifaces" I.interfaceDecoder) - (Decode.field "objects" Opt.localGraphDecoder) - (Decode.field "docs" (Decode.maybe Docs.jsonModuleDecoder)) - - "RForeign" -> - Decode.map RForeign (Decode.field "iface" I.interfaceDecoder) - - "RKernelLocal" -> - Decode.map RKernelLocal (Decode.field "chunks" (Decode.list Kernel.chunkDecoder)) - - "RKernelForeign" -> - Decode.succeed RKernelForeign - - _ -> - Decode.fail ("Failed to decode DResult's type: " ++ type_) - ) + S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec dResultCodec : Codec e DResult dResultCodec = - Debug.todo "dResultCodec" - + Serialize.customType + (\rLocalEncoder rForeignEncoder rKernelLocalEncoder rKernelForeignEncoder dResult -> + case dResult of + RLocal ifaces objects docs -> + rLocalEncoder ifaces objects docs -statusDictEncoder : StatusDict -> Encode.Value -statusDictEncoder statusDict = - E.assocListDict ModuleName.rawEncoder Utils.mVarEncoder statusDict + RForeign iface -> + rForeignEncoder iface + RKernelLocal chunks -> + rKernelLocalEncoder chunks -statusDictDecoder : Decode.Decoder StatusDict -statusDictDecoder = - D.assocListDict compare ModuleName.rawDecoder Utils.mVarDecoder + RKernelForeign -> + rKernelForeignEncoder + ) + |> Serialize.variant3 RLocal I.interfaceCodec Opt.localGraphCodec (Serialize.maybe Docs.jsonModuleCodec) + |> Serialize.variant1 RForeign I.interfaceCodec + |> Serialize.variant1 RKernelLocal (Serialize.list Kernel.chunkCodec) + |> Serialize.variant0 RKernelForeign + |> Serialize.finishCustomType statusDictCodec : Codec e StatusDict statusDictCodec = - Debug.todo "statusDictCodec" + S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec localEncoder : Local -> Encode.Value @@ -1475,28 +1352,17 @@ fingerprintCodec = S.assocListDict Pkg.compareName Pkg.nameCodec V.versionCodec -docsStatusEncoder : DocsStatus -> Encode.Value -docsStatusEncoder docsStatus = - case docsStatus of - DocsNeeded -> - Encode.string "DocsNeeded" - - DocsNotNeeded -> - Encode.string "DocsNotNeeded" - - -docsStatusDecoder : Decode.Decoder DocsStatus -docsStatusDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "DocsNeeded" -> - Decode.succeed DocsNeeded - - "DocsNotNeeded" -> - Decode.succeed DocsNotNeeded +docsStatusCodec : Codec e DocsStatus +docsStatusCodec = + Serialize.customType + (\docsNeededEncoder docsNotNeededEncoder docsStatus -> + case docsStatus of + DocsNeeded -> + docsNeededEncoder - _ -> - Decode.fail ("Unknown DocsStatus: " ++ str) - ) + DocsNotNeeded -> + docsNotNeededEncoder + ) + |> Serialize.variant0 DocsNeeded + |> Serialize.variant0 DocsNotNeeded + |> Serialize.finishCustomType diff --git a/src/Builder/Http.elm b/src/Builder/Http.elm index 9bffb3e92..c43c9b420 100644 --- a/src/Builder/Http.elm +++ b/src/Builder/Http.elm @@ -61,7 +61,12 @@ managerDecoder = managerCodec : Codec e Manager managerCodec = - Debug.todo "managerCodec" + Serialize.customType + (\managerCodecEncoder Manager -> + managerCodecEncoder + ) + |> Serialize.variant0 Manager + |> Serialize.finishCustomType getManager : IO Manager diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm index 00d2ddf6a..bc85e1391 100644 --- a/src/Builder/Reporting/Exit.elm +++ b/src/Builder/Reporting/Exit.elm @@ -33,6 +33,7 @@ module Builder.Reporting.Exit exposing , makeToReport , newPackageOverview , publishToReport + , registryProblemCodec , registryProblemDecoder , registryProblemEncoder , replToReport @@ -59,6 +60,7 @@ import Compiler.Reporting.Error as Error import Compiler.Reporting.Error.Import as Import import Compiler.Reporting.Error.Json as Json import Compiler.Reporting.Render.Code as Code +import Compiler.Serialize as S import Data.IO exposing (IO) import Data.Map as Dict exposing (Dict) import Json.Decode as CoreDecode @@ -2873,7 +2875,18 @@ detailsBadDepDecoder = detailsBadDepCodec : Codec e DetailsBadDep detailsBadDepCodec = - Debug.todo "detailsBadDepCodec" + Serialize.customType + (\bdBadDownloadEncoder bdBadBuildEncoder detailsBadDep -> + case detailsBadDep of + BD_BadDownload pkg vsn packageProblem -> + bdBadDownloadEncoder pkg vsn packageProblem + + BD_BadBuild pkg vsn fingerprint -> + 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.finishCustomType buildProblemEncoder : BuildProblem -> CoreEncode.Value @@ -3092,6 +3105,11 @@ registryProblemDecoder = ) +registryProblemCodec : Codec e RegistryProblem +registryProblemCodec = + Debug.todo "registryProblemCodec" + + packageProblemEncoder : PackageProblem -> CoreEncode.Value packageProblemEncoder packageProblem = case packageProblem of @@ -3155,3 +3173,8 @@ packageProblemDecoder = _ -> CoreDecode.fail ("Failed to decode PackageProblem's type: " ++ type_) ) + + +packageProblemCodec : Codec e PackageProblem +packageProblemCodec = + Debug.todo "packageProblemCodec" diff --git a/src/Compiler/AST/Source.elm b/src/Compiler/AST/Source.elm index 7d8bc7ac8..b0739990e 100644 --- a/src/Compiler/AST/Source.elm +++ b/src/Compiler/AST/Source.elm @@ -23,6 +23,7 @@ module Compiler.AST.Source exposing , VarType(..) , getImportName , getName + , moduleCodec , moduleDecoder , moduleEncoder , typeDecoder @@ -37,6 +38,7 @@ import Compiler.Parse.Primitives as P import Compiler.Reporting.Annotation as A import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -369,6 +371,11 @@ moduleDecoder = (Decode.field "effects" effectsDecoder) +moduleCodec : Codec e Module +moduleCodec = + Debug.todo "moduleCodec" + + exposingEncoder : Exposing -> Encode.Value exposingEncoder exposing_ = case exposing_ of diff --git a/src/Compiler/Elm/Docs.elm b/src/Compiler/Elm/Docs.elm index 46f85fad5..ec0500a73 100644 --- a/src/Compiler/Elm/Docs.elm +++ b/src/Compiler/Elm/Docs.elm @@ -13,6 +13,7 @@ module Compiler.Elm.Docs exposing , jsonCodec , jsonDecoder , jsonEncoder + , jsonModuleCodec , jsonModuleDecoder , jsonModuleEncoder ) @@ -810,6 +811,11 @@ jsonModuleDecoder = (Decode.field "binops" (D.assocListDict compare Decode.string jsonBinopDecoder)) +jsonModuleCodec : Codec e Module +jsonModuleCodec = + Debug.todo "jsonModuleCodec" + + jsonUnionEncoder : Union -> Encode.Value jsonUnionEncoder (Union comment args cases) = Encode.object diff --git a/src/Compiler/Reporting/Error/Import.elm b/src/Compiler/Reporting/Error/Import.elm index 4f52e8c71..2b8d15630 100644 --- a/src/Compiler/Reporting/Error/Import.elm +++ b/src/Compiler/Reporting/Error/Import.elm @@ -3,6 +3,7 @@ module Compiler.Reporting.Error.Import exposing , Problem(..) , errorDecoder , errorEncoder + , problemCodec , problemDecoder , problemEncoder , toReport @@ -21,6 +22,7 @@ import Data.Map as Dict import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -253,6 +255,11 @@ problemDecoder = ) +problemCodec : Codec e Problem +problemCodec = + Debug.todo "problemCodec" + + errorEncoder : Error -> Encode.Value errorEncoder (Error region name unimportedModules problem) = Encode.object diff --git a/src/Compiler/Reporting/Error/Syntax.elm b/src/Compiler/Reporting/Error/Syntax.elm index 261997cc2..556c4c74d 100644 --- a/src/Compiler/Reporting/Error/Syntax.elm +++ b/src/Compiler/Reporting/Error/Syntax.elm @@ -30,6 +30,7 @@ module Compiler.Reporting.Error.Syntax exposing , Tuple(..) , Type(..) , TypeAlias(..) + , errorCodec , errorDecoder , errorEncoder , spaceDecoder @@ -49,6 +50,7 @@ import Compiler.Reporting.Report as Report import Hex import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -7952,6 +7954,11 @@ errorDecoder = ) +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" + + spaceEncoder : Space -> Encode.Value spaceEncoder space = case space of From 8e8d52ce329ae8df03692c2c9653b9f215b1adf6 Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Tue, 19 Nov 2024 19:06:03 +0000 Subject: [PATCH 3/7] WIP elm-serialize --- src/Builder/Build.elm | 10 +- src/Builder/Deps/Registry.elm | 15 +- src/Builder/Deps/Solver.elm | 23 +- src/Builder/Http.elm | 21 + src/Builder/Reporting.elm | 8 +- src/Builder/Reporting/Exit.elm | 83 +++- src/Builder/Stuff.elm | 12 + src/Compiler/Nitpick/PatternMatches.elm | 7 + src/Compiler/Parse/Symbol.elm | 7 + src/Compiler/Reporting/Annotation.elm | 6 + src/Compiler/Reporting/Error.elm | 38 +- src/Compiler/Reporting/Error/Canonicalize.elm | 7 + src/Compiler/Reporting/Error/Docs.elm | 7 + src/Compiler/Reporting/Error/Import.elm | 27 +- src/Compiler/Reporting/Error/Main.elm | 7 + src/Compiler/Reporting/Error/Syntax.elm | 432 +++++++++++++++++- src/Compiler/Reporting/Error/Type.elm | 7 + .../Reporting/Render/Type/Localizer.elm | 7 + src/Compiler/Serialize.elm | 13 +- src/Utils/Main.elm | 12 + 20 files changed, 721 insertions(+), 28 deletions(-) diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm index ec6315b0c..ba89461d7 100644 --- a/src/Builder/Build.elm +++ b/src/Builder/Build.elm @@ -130,7 +130,7 @@ forkWithKey keyComparison codec func dict = -- FROM EXPOSED -fromExposed : Codec e docs -> Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> IO (Result Exit.BuildProblem docs) +fromExposed : Codec (Serialize.Error e) docs -> Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> IO (Result Exit.BuildProblem docs) fromExposed docsCodec style root details docsGoal ((NE.Nonempty e es) as exposed) = Reporting.trackBuild docsCodec style <| \key -> @@ -1839,7 +1839,7 @@ dictRawMVarBResultCodec = S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec -bResultCodec : Codec e BResult +bResultCodec : Codec (Serialize.Error e) BResult bResultCodec = Serialize.customType (\rNewEncoder rSameEncoder rCachedEncoder rNotFoundEncoder rProblemEncoder rBlockedEncoder rForeignEncoder rKernelEncoder bResult -> @@ -1927,7 +1927,7 @@ statusCodec = |> Serialize.finishCustomType -rootStatusCodec : Codec e RootStatus +rootStatusCodec : Codec (Serialize.Error e) RootStatus rootStatusCodec = Serialize.customType (\sInsideEncoder sOutsideOkEncoder sOutsideErrEncoder rootStatus -> @@ -1952,7 +1952,7 @@ resultDictCodec = S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec -rootResultCodec : Codec e RootResult +rootResultCodec : Codec (Serialize.Error e) RootResult rootResultCodec = Serialize.customType (\rInsideEncoder rOutsideOkEncoder rOutsideErrEncoder rOutsideBlockedEncoder rootResult -> @@ -1991,7 +1991,7 @@ maybeDependenciesCodec = Serialize.maybe (S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec) -resultBuildProjectProblemRootInfoCodec : Codec e (Result Exit.BuildProjectProblem RootInfo) +resultBuildProjectProblemRootInfoCodec : Codec (Serialize.Error e) (Result Exit.BuildProjectProblem RootInfo) resultBuildProjectProblemRootInfoCodec = Serialize.result Exit.buildProjectProblemCodec rootInfoCodec diff --git a/src/Builder/Deps/Registry.elm b/src/Builder/Deps/Registry.elm index 0d8e09640..4694ca597 100644 --- a/src/Builder/Deps/Registry.elm +++ b/src/Builder/Deps/Registry.elm @@ -7,6 +7,7 @@ module Builder.Deps.Registry exposing , knownVersionsDecoder , latest , read + , registryCodec , registryDecoder , registryEncoder , update @@ -262,13 +263,6 @@ post manager path decoder callback = -- ENCODERS and DECODERS -registryDecoder : Decode.Decoder Registry -registryDecoder = - Decode.map2 Registry - (Decode.field "size" Decode.int) - (Decode.field "packages" (D.assocListDict Pkg.compareName Pkg.nameDecoder knownVersionsDecoder)) - - registryEncoder : Registry -> Encode.Value registryEncoder (Registry size versions) = Encode.object @@ -277,6 +271,13 @@ registryEncoder (Registry size versions) = ] +registryDecoder : Decode.Decoder Registry +registryDecoder = + Decode.map2 Registry + (Decode.field "size" Decode.int) + (Decode.field "packages" (D.assocListDict Pkg.compareName Pkg.nameDecoder knownVersionsDecoder)) + + registryCodec : Codec e Registry registryCodec = Serialize.customType diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index fa85a1cf5..9e9fd1756 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -618,7 +618,12 @@ envDecoder = envCodec : Codec e Env envCodec = - Debug.todo "envCodec" + Serialize.customType + (\envCodecEncoder (Env cache manager connection registry) -> + envCodecEncoder cache manager connection registry + ) + |> Serialize.variant4 Env Stuff.packageCacheCodec Http.managerCodec connectionCodec Registry.registryCodec + |> Serialize.finishCustomType connectionEncoder : Connection -> Encode.Value @@ -651,3 +656,19 @@ connectionDecoder = _ -> Decode.fail ("Failed to decode Connection's type: " ++ type_) ) + + +connectionCodec : Codec e Connection +connectionCodec = + Serialize.customType + (\onlineEncoder offlineEncoder value -> + case value of + Online manager -> + onlineEncoder manager + + Offline -> + offlineEncoder + ) + |> Serialize.variant1 Online Http.managerCodec + |> Serialize.variant0 Offline + |> Serialize.finishCustomType diff --git a/src/Builder/Http.elm b/src/Builder/Http.elm index c43c9b420..dcb332c74 100644 --- a/src/Builder/Http.elm +++ b/src/Builder/Http.elm @@ -5,6 +5,7 @@ module Builder.Http exposing , MultiPart , Sha , accept + , errorCodec , errorDecoder , errorEncoder , filePart @@ -296,3 +297,23 @@ errorDecoder = _ -> Decode.fail ("Failed to decode Error's type: " ++ type_) ) + + +errorCodec : Codec e Error +errorCodec = + Serialize.customType + (\badUrlEncoder badHttpEncoder badMysteryEncoder value -> + case value of + BadUrl url reason -> + badUrlEncoder url reason + + BadHttp url httpExceptionContent -> + badHttpEncoder url httpExceptionContent + + BadMystery url someException -> + badMysteryEncoder url someException + ) + |> Serialize.variant2 BadUrl Serialize.string Serialize.string + |> Serialize.variant2 BadHttp Serialize.string Utils.httpExceptionContentCodec + |> Serialize.variant2 BadMystery Serialize.string Utils.someExceptionCodec + |> Serialize.finishCustomType diff --git a/src/Builder/Reporting.elm b/src/Builder/Reporting.elm index e41b67785..d537cb1f7 100644 --- a/src/Builder/Reporting.elm +++ b/src/Builder/Reporting.elm @@ -367,7 +367,7 @@ type alias BResult a = Result Exit.BuildProblem a -trackBuild : Codec e a -> Style -> (BKey -> IO (BResult a)) -> IO (BResult a) +trackBuild : Codec (Serialize.Error e) a -> Style -> (BKey -> IO (BResult a)) -> IO (BResult a) trackBuild codec style callback = case style of Silent -> @@ -381,7 +381,7 @@ trackBuild codec style callback = |> IO.bind (\chan -> let - chanCodec : Codec e (Result BMsg (BResult a)) + chanCodec : Codec (Serialize.Error e) (Result BMsg (BResult a)) chanCodec = Serialize.result bMsgCodec (bResultCodec codec) in @@ -404,7 +404,7 @@ type BMsg = BDone -buildLoop : Codec e a -> Chan (Result BMsg (BResult a)) -> Int -> IO () +buildLoop : Codec (Serialize.Error e) a -> Chan (Result BMsg (BResult a)) -> Int -> IO () buildLoop codec chan done = Utils.readChan (Serialize.result bMsgCodec (bResultCodec codec)) chan |> IO.bind @@ -614,6 +614,6 @@ bMsgCodec = |> Serialize.finishCustomType -bResultCodec : Codec e a -> Codec e (BResult a) +bResultCodec : Codec (Serialize.Error e) a -> Codec (Serialize.Error e) (BResult a) bResultCodec codec = Serialize.result Exit.buildProblemCodec codec diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm index bc85e1391..0782bd44e 100644 --- a/src/Builder/Reporting/Exit.elm +++ b/src/Builder/Reporting/Exit.elm @@ -2927,7 +2927,7 @@ buildProblemDecoder = ) -buildProblemCodec : Codec e BuildProblem +buildProblemCodec : Codec (Serialize.Error e) BuildProblem buildProblemCodec = Serialize.customType (\buildBadModulesEncoder buildProjectProblemCodecEncoder buildProblem -> @@ -3064,9 +3064,48 @@ buildProjectProblemDecoder = ) -buildProjectProblemCodec : Codec e BuildProjectProblem +buildProjectProblemCodec : Codec (Serialize.Error e) BuildProjectProblem buildProjectProblemCodec = - Debug.todo "buildProjectProblemCodec" + Serialize.customType + (\pathUnknownEncoder withBadExtensionEncoder withAmbiguousSrcDirEncoder mainPathDuplicateEncoder rootNameDuplicateEncoder rootNameInvalidEncoder cannotLoadDependenciesEncoder cycleEncoder missingExposedEncoder value -> + case value of + BP_PathUnknown path -> + pathUnknownEncoder path + + BP_WithBadExtension path -> + withBadExtensionEncoder path + + BP_WithAmbiguousSrcDir path srcDir1 srcDir2 -> + withAmbiguousSrcDirEncoder path srcDir1 srcDir2 + + BP_MainPathDuplicate path1 path2 -> + mainPathDuplicateEncoder path1 path2 + + BP_RootNameDuplicate name outsidePath otherPath -> + rootNameDuplicateEncoder name outsidePath otherPath + + BP_RootNameInvalid givenPath srcDir names -> + rootNameInvalidEncoder givenPath srcDir names + + BP_CannotLoadDependencies -> + cannotLoadDependenciesEncoder + + BP_Cycle name names -> + cycleEncoder name names + + BP_MissingExposed problems -> + missingExposedEncoder problems + ) + |> Serialize.variant1 BP_PathUnknown Serialize.string + |> Serialize.variant1 BP_WithBadExtension Serialize.string + |> Serialize.variant3 BP_WithAmbiguousSrcDir Serialize.string Serialize.string Serialize.string + |> Serialize.variant2 BP_MainPathDuplicate Serialize.string Serialize.string + |> Serialize.variant3 BP_RootNameDuplicate ModuleName.rawCodec Serialize.string Serialize.string + |> Serialize.variant3 BP_RootNameInvalid Serialize.string Serialize.string (Serialize.list Serialize.string) + |> Serialize.variant0 BP_CannotLoadDependencies + |> Serialize.variant2 BP_Cycle ModuleName.rawCodec (Serialize.list Serialize.string) + |> Serialize.variant1 BP_MissingExposed (S.nonempty (Serialize.tuple ModuleName.rawCodec Import.problemCodec)) + |> Serialize.finishCustomType registryProblemEncoder : RegistryProblem -> CoreEncode.Value @@ -3107,7 +3146,18 @@ registryProblemDecoder = registryProblemCodec : Codec e RegistryProblem registryProblemCodec = - Debug.todo "registryProblemCodec" + Serialize.customType + (\httpEncoder dataEncoder value -> + case value of + RP_Http err -> + httpEncoder err + + RP_Data url body -> + dataEncoder url body + ) + |> Serialize.variant1 RP_Http Http.errorCodec + |> Serialize.variant2 RP_Data Serialize.string Serialize.string + |> Serialize.finishCustomType packageProblemEncoder : PackageProblem -> CoreEncode.Value @@ -3177,4 +3227,27 @@ packageProblemDecoder = packageProblemCodec : Codec e PackageProblem packageProblemCodec = - Debug.todo "packageProblemCodec" + Serialize.customType + (\badEndpointRequestEncoder badEndpointContentEncoder badArchiveRequestEncoder badArchiveContentEncoder badArchiveHashEncoder value -> + case value of + PP_BadEndpointRequest httpError -> + badEndpointRequestEncoder httpError + + PP_BadEndpointContent url -> + badEndpointContentEncoder url + + PP_BadArchiveRequest httpError -> + badArchiveRequestEncoder httpError + + PP_BadArchiveContent url -> + badArchiveContentEncoder url + + PP_BadArchiveHash url expectedHash actualHash -> + badArchiveHashEncoder url expectedHash actualHash + ) + |> Serialize.variant1 PP_BadEndpointRequest Http.errorCodec + |> Serialize.variant1 PP_BadEndpointContent Serialize.string + |> Serialize.variant1 PP_BadArchiveRequest Http.errorCodec + |> Serialize.variant1 PP_BadArchiveContent Serialize.string + |> Serialize.variant3 PP_BadArchiveHash Serialize.string Serialize.string Serialize.string + |> Serialize.finishCustomType diff --git a/src/Builder/Stuff.elm b/src/Builder/Stuff.elm index 0259e3709..3d62da1ed 100644 --- a/src/Builder/Stuff.elm +++ b/src/Builder/Stuff.elm @@ -10,6 +10,7 @@ module Builder.Stuff exposing , interfaces , objects , package + , packageCacheCodec , packageCacheDecoder , packageCacheEncoder , prepublishDir @@ -25,6 +26,7 @@ import Data.IO as IO exposing (IO) import Json.Decode as Decode import Json.Encode as Encode import Prelude +import Serialize exposing (Codec) import Utils.Main as Utils @@ -211,3 +213,13 @@ packageCacheEncoder (PackageCache dir) = packageCacheDecoder : Decode.Decoder PackageCache packageCacheDecoder = Decode.map PackageCache (Decode.field "dir" Decode.string) + + +packageCacheCodec : Codec e PackageCache +packageCacheCodec = + Serialize.customType + (\packageCacheCodecEncoder (PackageCache dir) -> + packageCacheCodecEncoder dir + ) + |> Serialize.variant1 PackageCache Serialize.string + |> Serialize.finishCustomType diff --git a/src/Compiler/Nitpick/PatternMatches.elm b/src/Compiler/Nitpick/PatternMatches.elm index d678aeccf..1ed49135f 100644 --- a/src/Compiler/Nitpick/PatternMatches.elm +++ b/src/Compiler/Nitpick/PatternMatches.elm @@ -4,6 +4,7 @@ module Compiler.Nitpick.PatternMatches exposing , Literal(..) , Pattern(..) , check + , errorCodec , errorDecoder , errorEncoder ) @@ -26,6 +27,7 @@ import Json.Decode as Decode import Json.Encode as Encode import List.Extra as List import Prelude +import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils @@ -755,6 +757,11 @@ errorDecoder = ) +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" + + contextEncoder : Context -> Encode.Value contextEncoder context = case context of diff --git a/src/Compiler/Parse/Symbol.elm b/src/Compiler/Parse/Symbol.elm index 21a090ea7..76a6eb074 100644 --- a/src/Compiler/Parse/Symbol.elm +++ b/src/Compiler/Parse/Symbol.elm @@ -1,5 +1,6 @@ module Compiler.Parse.Symbol exposing ( BadOperator(..) + , badOperatorCodec , badOperatorDecoder , badOperatorEncoder , binopCharSet @@ -11,6 +12,7 @@ import Compiler.Parse.Primitives as P exposing (Col, Parser, Row) import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -148,3 +150,8 @@ badOperatorDecoder = _ -> Decode.fail ("Unknown BadOperator: " ++ str) ) + + +badOperatorCodec : Codec e BadOperator +badOperatorCodec = + Debug.todo "badOperatorCodec" diff --git a/src/Compiler/Reporting/Annotation.elm b/src/Compiler/Reporting/Annotation.elm index 74247cfa1..7aad43f08 100644 --- a/src/Compiler/Reporting/Annotation.elm +++ b/src/Compiler/Reporting/Annotation.elm @@ -3,6 +3,7 @@ module Compiler.Reporting.Annotation exposing , Position(..) , Region(..) , at + , locatedCodec , locatedDecoder , locatedEncoder , merge @@ -157,3 +158,8 @@ locatedDecoder decoder = Decode.map2 At (Decode.field "region" regionDecoder) (Decode.field "value" (Decode.lazy (\_ -> decoder))) + + +locatedCodec : Codec e a -> Codec e (Located a) +locatedCodec = + Debug.todo "locatedCodec" diff --git a/src/Compiler/Reporting/Error.elm b/src/Compiler/Reporting/Error.elm index 5617e39f9..e40b10f20 100644 --- a/src/Compiler/Reporting/Error.elm +++ b/src/Compiler/Reporting/Error.elm @@ -28,6 +28,7 @@ import Compiler.Reporting.Error.Type as Type import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Render.Type.Localizer as L import Compiler.Reporting.Report as Report +import Compiler.Serialize as S import Json.Decode as Decode import Json.Encode as Encode import Serialize exposing (Codec) @@ -267,7 +268,7 @@ moduleDecoder = (Decode.field "error" errorDecoder) -moduleCodec : Codec e Module +moduleCodec : Codec (Serialize.Error e) Module moduleCodec = Serialize.record Module |> Serialize.field .name ModuleName.rawCodec @@ -362,6 +363,37 @@ errorDecoder = ) -errorCodec : Codec e Error +errorCodec : Codec (Serialize.Error e) Error errorCodec = - Debug.todo "errorCodec" + Serialize.customType + (\badSyntaxEncoder badImportsEncoder badNamesEncoder badTypesEncoder badMainsEncoder badPatternsEncoder badDocsEncoder value -> + case value of + BadSyntax syntaxError -> + badSyntaxEncoder syntaxError + + BadImports errs -> + badImportsEncoder errs + + BadNames errs -> + badNamesEncoder errs + + BadTypes localizer errs -> + badTypesEncoder localizer errs + + BadMains localizer errs -> + badMainsEncoder localizer errs + + BadPatterns errs -> + badPatternsEncoder errs + + BadDocs docsErr -> + badDocsEncoder docsErr + ) + |> Serialize.variant1 BadSyntax Syntax.errorCodec + |> Serialize.variant1 BadImports (S.nonempty Import.errorCodec) + |> Serialize.variant1 BadNames (S.oneOrMore Canonicalize.errorCodec) + |> Serialize.variant2 BadTypes L.localizerCodec (S.nonempty Type.errorCodec) + |> Serialize.variant2 BadMains L.localizerCodec (S.oneOrMore Main.errorCodec) + |> Serialize.variant1 BadPatterns (S.nonempty P.errorCodec) + |> Serialize.variant1 BadDocs Docs.errorCodec + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Error/Canonicalize.elm b/src/Compiler/Reporting/Error/Canonicalize.elm index 5c2f087ad..1cda2a4ba 100644 --- a/src/Compiler/Reporting/Error/Canonicalize.elm +++ b/src/Compiler/Reporting/Error/Canonicalize.elm @@ -6,6 +6,7 @@ module Compiler.Reporting.Error.Canonicalize exposing , PortProblem(..) , PossibleNames , VarKind(..) + , errorCodec , errorDecoder , errorEncoder , invalidPayloadDecoder @@ -31,6 +32,7 @@ import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -1877,6 +1879,11 @@ errorDecoder = ) +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" + + badArityContextEncoder : BadArityContext -> Encode.Value badArityContextEncoder badArityContext = case badArityContext of diff --git a/src/Compiler/Reporting/Error/Docs.elm b/src/Compiler/Reporting/Error/Docs.elm index cd6cda15d..023e47b47 100644 --- a/src/Compiler/Reporting/Error/Docs.elm +++ b/src/Compiler/Reporting/Error/Docs.elm @@ -3,6 +3,7 @@ module Compiler.Reporting.Error.Docs exposing , Error(..) , NameProblem(..) , SyntaxProblem(..) + , errorCodec , errorDecoder , errorEncoder , toReports @@ -21,6 +22,7 @@ import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Report as Report import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) type Error @@ -266,6 +268,11 @@ errorDecoder = ) +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" + + syntaxProblemEncoder : SyntaxProblem -> Encode.Value syntaxProblemEncoder syntaxProblem = case syntaxProblem of diff --git a/src/Compiler/Reporting/Error/Import.elm b/src/Compiler/Reporting/Error/Import.elm index 2b8d15630..f038b2dd0 100644 --- a/src/Compiler/Reporting/Error/Import.elm +++ b/src/Compiler/Reporting/Error/Import.elm @@ -1,6 +1,7 @@ module Compiler.Reporting.Error.Import exposing ( Error(..) , Problem(..) + , errorCodec , errorDecoder , errorEncoder , problemCodec @@ -257,7 +258,26 @@ problemDecoder = problemCodec : Codec e Problem problemCodec = - Debug.todo "problemCodec" + Serialize.customType + (\notFoundEncoder ambiguousEncoder ambiguousLocalEncoder ambiguousForeignEncoder value -> + case value of + NotFound -> + notFoundEncoder + + Ambiguous path paths pkg pkgs -> + ambiguousEncoder path paths pkg pkgs + + AmbiguousLocal path1 path2 paths -> + ambiguousLocalEncoder path1 path2 paths + + AmbiguousForeign pkg1 pkg2 pkgs -> + ambiguousForeignEncoder pkg1 pkg2 pkgs + ) + |> Serialize.variant0 NotFound + |> Serialize.variant4 Ambiguous Serialize.string (Serialize.list Serialize.string) Pkg.nameCodec (Serialize.list Pkg.nameCodec) + |> Serialize.variant3 AmbiguousLocal Serialize.string Serialize.string (Serialize.list Serialize.string) + |> Serialize.variant3 AmbiguousForeign Pkg.nameCodec Pkg.nameCodec (Serialize.list Pkg.nameCodec) + |> Serialize.finishCustomType errorEncoder : Error -> Encode.Value @@ -278,3 +298,8 @@ errorDecoder = (Decode.field "name" ModuleName.rawDecoder) (Decode.field "unimportedModules" (DecodeX.everySet compare ModuleName.rawDecoder)) (Decode.field "problem" problemDecoder) + + +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" diff --git a/src/Compiler/Reporting/Error/Main.elm b/src/Compiler/Reporting/Error/Main.elm index bdc6d4f10..10bfb64ec 100644 --- a/src/Compiler/Reporting/Error/Main.elm +++ b/src/Compiler/Reporting/Error/Main.elm @@ -1,5 +1,6 @@ module Compiler.Reporting.Error.Main exposing ( Error(..) + , errorCodec , errorDecoder , errorEncoder , toReport @@ -16,6 +17,7 @@ import Compiler.Reporting.Render.Type.Localizer as L import Compiler.Reporting.Report as Report import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -151,3 +153,8 @@ errorDecoder = _ -> Decode.fail ("Failed to decode Error's type: " ++ type_) ) + + +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" diff --git a/src/Compiler/Reporting/Error/Syntax.elm b/src/Compiler/Reporting/Error/Syntax.elm index 556c4c74d..551e2a893 100644 --- a/src/Compiler/Reporting/Error/Syntax.elm +++ b/src/Compiler/Reporting/Error/Syntax.elm @@ -50,6 +50,7 @@ import Compiler.Reporting.Report as Report import Hex import Json.Decode as Decode import Json.Encode as Encode +import Pretty exposing (space) import Serialize exposing (Codec) @@ -7956,7 +7957,42 @@ errorDecoder = errorCodec : Codec e Error errorCodec = - Debug.todo "errorCodec" + Serialize.customType + (\moduleNameUnspecifiedEncoder moduleNameMismatchEncoder unexpectedPortEncoder noPortsEncoder noPortsInPackageEncoder noPortModulesInPackageEncoder noEffectsOutsideKernelEncoder parseErrorEncoder value -> + case value of + ModuleNameUnspecified name -> + moduleNameUnspecifiedEncoder name + + ModuleNameMismatch expectedName actualName -> + moduleNameMismatchEncoder expectedName actualName + + UnexpectedPort region -> + unexpectedPortEncoder region + + NoPorts region -> + noPortsEncoder region + + NoPortsInPackage name -> + noPortsInPackageEncoder name + + NoPortModulesInPackage region -> + noPortModulesInPackageEncoder region + + NoEffectsOutsideKernel region -> + noEffectsOutsideKernelEncoder region + + ParseError modul -> + parseErrorEncoder modul + ) + |> Serialize.variant1 ModuleNameUnspecified ModuleName.rawCodec + |> Serialize.variant2 ModuleNameMismatch ModuleName.rawCodec (A.locatedCodec ModuleName.rawCodec) + |> Serialize.variant1 UnexpectedPort A.regionCodec + |> Serialize.variant1 NoPorts A.regionCodec + |> Serialize.variant1 NoPortsInPackage (A.locatedCodec Serialize.string) + |> Serialize.variant1 NoPortModulesInPackage A.regionCodec + |> Serialize.variant1 NoEffectsOutsideKernel A.regionCodec + |> Serialize.variant1 ParseError moduleCodec + |> Serialize.finishCustomType spaceEncoder : Space -> Encode.Value @@ -7986,6 +8022,22 @@ spaceDecoder = ) +spaceCodec : Codec e Space +spaceCodec = + Serialize.customType + (\hasTabEncoder endlessMultiCommentEncoder value -> + case value of + HasTab -> + hasTabEncoder + + EndlessMultiComment -> + endlessMultiCommentEncoder + ) + |> Serialize.variant0 HasTab + |> Serialize.variant0 EndlessMultiComment + |> Serialize.finishCustomType + + moduleEncoder : Module -> Encode.Value moduleEncoder modul = case modul of @@ -8275,6 +8327,102 @@ moduleDecoder = ) +moduleCodec : Codec e Module +moduleCodec = + Serialize.customType + (\moduleSpaceEncoder moduleBadEndEncoder moduleProblemEncoder moduleNameEncoder moduleExposingEncoder portModuleProblemEncoder portModuleNameEncoder portModuleExposingEncoder effectEncoder freshLineEncoder importStartEncoder importNameEncoder importAsEncoder importAliasEncoder importExposingEncoder importExposingListEncoder importEndEncoder importIndentNameEncoder importIndentAliasEncoder importIndentExposingListEncoder infixEncoder declarationsEncoder value -> + case value of + ModuleSpace space row col -> + moduleSpaceEncoder space row col + + ModuleBadEnd row col -> + moduleBadEndEncoder row col + + ModuleProblem row col -> + moduleProblemEncoder row col + + ModuleName row col -> + moduleNameEncoder row col + + ModuleExposing exposing_ row col -> + moduleExposingEncoder exposing_ row col + + PortModuleProblem row col -> + portModuleProblemEncoder row col + + PortModuleName row col -> + portModuleNameEncoder row col + + PortModuleExposing exposing_ row col -> + portModuleExposingEncoder exposing_ row col + + Effect row col -> + effectEncoder row col + + FreshLine row col -> + freshLineEncoder row col + + ImportStart row col -> + importStartEncoder row col + + ImportName row col -> + importNameEncoder row col + + ImportAs row col -> + importAsEncoder row col + + ImportAlias row col -> + importAliasEncoder row col + + ImportExposing row col -> + importExposingEncoder row col + + ImportExposingList exposing_ row col -> + importExposingListEncoder exposing_ row col + + ImportEnd row col -> + importEndEncoder row col + + ImportIndentName row col -> + importIndentNameEncoder row col + + ImportIndentAlias row col -> + importIndentAliasEncoder row col + + ImportIndentExposingList row col -> + importIndentExposingListEncoder row col + + Infix row col -> + infixEncoder row col + + Declarations decl row col -> + declarationsEncoder decl row col + ) + |> Serialize.variant3 ModuleSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 ModuleBadEnd Serialize.int Serialize.int + |> Serialize.variant2 ModuleProblem Serialize.int Serialize.int + |> Serialize.variant2 ModuleName Serialize.int Serialize.int + |> Serialize.variant3 ModuleExposing exposingCodec Serialize.int Serialize.int + |> Serialize.variant2 PortModuleProblem Serialize.int Serialize.int + |> Serialize.variant2 PortModuleName Serialize.int Serialize.int + |> Serialize.variant3 PortModuleExposing exposingCodec Serialize.int Serialize.int + |> Serialize.variant2 Effect Serialize.int Serialize.int + |> Serialize.variant2 FreshLine Serialize.int Serialize.int + |> Serialize.variant2 ImportStart Serialize.int Serialize.int + |> Serialize.variant2 ImportName Serialize.int Serialize.int + |> Serialize.variant2 ImportAs Serialize.int Serialize.int + |> Serialize.variant2 ImportAlias Serialize.int Serialize.int + |> Serialize.variant2 ImportExposing Serialize.int Serialize.int + |> Serialize.variant3 ImportExposingList exposingCodec Serialize.int Serialize.int + |> Serialize.variant2 ImportEnd Serialize.int Serialize.int + |> Serialize.variant2 ImportIndentName Serialize.int Serialize.int + |> Serialize.variant2 ImportIndentAlias Serialize.int Serialize.int + |> Serialize.variant2 ImportIndentExposingList Serialize.int Serialize.int + |> Serialize.variant2 Infix Serialize.int Serialize.int + |> Serialize.variant3 Declarations declCodec Serialize.int Serialize.int + |> Serialize.finishCustomType + + exposingEncoder : Exposing -> Encode.Value exposingEncoder exposing_ = case exposing_ of @@ -8414,6 +8562,54 @@ exposingDecoder = ) +exposingCodec : Codec e Exposing +exposingCodec = + Serialize.customType + (\exposingSpaceEncoder exposingStartEncoder exposingValueEncoder exposingOperatorEncoder exposingOperatorReservedEncoder exposingOperatorRightParenEncoder exposingTypePrivacyEncoder exposingEndEncoder exposingIndentEndEncoder exposingIndentValueEncoder value -> + case value of + ExposingSpace space row col -> + exposingSpaceEncoder space row col + + ExposingStart row col -> + exposingStartEncoder row col + + ExposingValue row col -> + exposingValueEncoder row col + + ExposingOperator row col -> + exposingOperatorEncoder row col + + ExposingOperatorReserved op row col -> + exposingOperatorReservedEncoder op row col + + ExposingOperatorRightParen row col -> + exposingOperatorRightParenEncoder row col + + ExposingTypePrivacy row col -> + exposingTypePrivacyEncoder row col + + ExposingEnd row col -> + exposingEndEncoder row col + + ExposingIndentEnd row col -> + exposingIndentEndEncoder row col + + ExposingIndentValue row col -> + exposingIndentValueEncoder row col + ) + |> Serialize.variant3 ExposingSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 ExposingStart Serialize.int Serialize.int + |> Serialize.variant2 ExposingValue Serialize.int Serialize.int + |> Serialize.variant2 ExposingOperator Serialize.int Serialize.int + |> Serialize.variant3 ExposingOperatorReserved Compiler.Parse.Symbol.badOperatorCodec Serialize.int Serialize.int + |> Serialize.variant2 ExposingOperatorRightParen Serialize.int Serialize.int + |> Serialize.variant2 ExposingTypePrivacy Serialize.int Serialize.int + |> Serialize.variant2 ExposingEnd Serialize.int Serialize.int + |> Serialize.variant2 ExposingIndentEnd Serialize.int Serialize.int + |> Serialize.variant2 ExposingIndentValue Serialize.int Serialize.int + |> Serialize.finishCustomType + + declEncoder : Decl -> Encode.Value declEncoder decl = case decl of @@ -8511,6 +8707,38 @@ declDecoder = ) +declCodec : Codec e Decl +declCodec = + Serialize.customType + (\declStartEncoder declSpaceEncoder portCodecEncoder declTypeCodecEncoder declDefCodecEncoder declFreshLineAfterDocCommentEncoder value -> + case value of + DeclStart row col -> + declStartEncoder row col + + DeclSpace space row col -> + declSpaceEncoder space row col + + Port port_ row col -> + portCodecEncoder port_ row col + + DeclType declType row col -> + declTypeCodecEncoder declType row col + + DeclDef name declDef row col -> + declDefCodecEncoder name declDef row col + + DeclFreshLineAfterDocComment row col -> + declFreshLineAfterDocCommentEncoder row col + ) + |> Serialize.variant2 DeclStart Serialize.int Serialize.int + |> Serialize.variant3 DeclSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant3 Port portCodec Serialize.int Serialize.int + |> Serialize.variant3 DeclType declTypeCodec Serialize.int Serialize.int + |> Serialize.variant4 DeclDef Serialize.string declDefCodec Serialize.int Serialize.int + |> Serialize.variant2 DeclFreshLineAfterDocComment Serialize.int Serialize.int + |> Serialize.finishCustomType + + portEncoder : Port -> Encode.Value portEncoder port_ = case port_ of @@ -8614,6 +8842,11 @@ portDecoder = ) +portCodec : Codec e Port +portCodec = + Debug.todo "portCodec" + + declTypeEncoder : DeclType -> Encode.Value declTypeEncoder declType = case declType of @@ -8695,6 +8928,11 @@ declTypeDecoder = ) +declTypeCodec : Codec e DeclType +declTypeCodec = + Debug.todo "declTypeCodec" + + declDefEncoder : DeclDef -> Encode.Value declDefEncoder declDef = case declDef of @@ -8840,6 +9078,54 @@ declDefDecoder = ) +declDefCodec : Codec e DeclDef +declDefCodec = + Serialize.customType + (\declDefSpaceEncoder declDefEqualsEncoder declDefTypeEncoder declDefArgEncoder declDefBodyEncoder declDefNameRepeatEncoder declDefNameMatchEncoder declDefIndentTypeEncoder declDefIndentEqualsEncoder declDefIndentBodyEncoder value -> + case value of + DeclDefSpace space row col -> + declDefSpaceEncoder space row col + + DeclDefEquals row col -> + declDefEqualsEncoder row col + + DeclDefType tipe row col -> + declDefTypeEncoder tipe row col + + DeclDefArg pattern row col -> + declDefArgEncoder pattern row col + + DeclDefBody expr row col -> + declDefBodyEncoder expr row col + + DeclDefNameRepeat row col -> + declDefNameRepeatEncoder row col + + DeclDefNameMatch name row col -> + declDefNameMatchEncoder name row col + + DeclDefIndentType row col -> + declDefIndentTypeEncoder row col + + DeclDefIndentEquals row col -> + declDefIndentEqualsEncoder row col + + DeclDefIndentBody row col -> + declDefIndentBodyEncoder row col + ) + |> Serialize.variant3 DeclDefSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 DeclDefEquals Serialize.int Serialize.int + |> Serialize.variant3 DeclDefType typeCodec Serialize.int Serialize.int + |> Serialize.variant3 DeclDefArg patternCodec Serialize.int Serialize.int + |> Serialize.variant3 DeclDefBody exprCodec Serialize.int Serialize.int + |> Serialize.variant2 DeclDefNameRepeat Serialize.int Serialize.int + |> Serialize.variant3 DeclDefNameMatch Serialize.string Serialize.int Serialize.int + |> Serialize.variant2 DeclDefIndentType Serialize.int Serialize.int + |> Serialize.variant2 DeclDefIndentEquals Serialize.int Serialize.int + |> Serialize.variant2 DeclDefIndentBody Serialize.int Serialize.int + |> Serialize.finishCustomType + + typeEncoder : Type -> Encode.Value typeEncoder type_ = case type_ of @@ -8921,6 +9207,11 @@ typeDecoder = ) +typeCodec : Codec e Type +typeCodec = + Debug.todo "typeCodec" + + patternEncoder : Pattern -> Encode.Value patternEncoder pattern = case pattern of @@ -9112,6 +9403,11 @@ patternDecoder = ) +patternCodec : Codec e Pattern +patternCodec = + Debug.todo "patternCodec" + + exprEncoder : Expr -> Encode.Value exprEncoder expr = case expr of @@ -9385,6 +9681,90 @@ exprDecoder = ) +exprCodec : Codec e Expr +exprCodec = + Serialize.customType + (\letCodecEncoder caseCodecEncoder ifCodecEncoder listCodecEncoder recordCodecEncoder tupleCodecEncoder funcCodecEncoder dotEncoder accessEncoder operatorRightEncoder operatorReservedEncoder startEncoder charCodecEncoder string_Encoder numberCodecEncoder spaceCodecEncoder endlessShaderEncoder shaderProblemEncoder indentOperatorRightEncoder value -> + case value of + Let let_ row col -> + letCodecEncoder let_ row col + + Case case_ row col -> + caseCodecEncoder case_ row col + + If if_ row col -> + ifCodecEncoder if_ row col + + List list row col -> + listCodecEncoder list row col + + Record record row col -> + recordCodecEncoder record row col + + Tuple tuple row col -> + tupleCodecEncoder tuple row col + + Func func row col -> + funcCodecEncoder func row col + + Dot row col -> + dotEncoder row col + + Access row col -> + accessEncoder row col + + OperatorRight op row col -> + operatorRightEncoder op row col + + OperatorReserved operator row col -> + operatorReservedEncoder operator row col + + Start row col -> + startEncoder row col + + Char char row col -> + charCodecEncoder char row col + + String_ string row col -> + string_Encoder string row col + + Number number row col -> + numberCodecEncoder number row col + + Space space row col -> + spaceCodecEncoder space row col + + EndlessShader row col -> + endlessShaderEncoder row col + + ShaderProblem problem row col -> + shaderProblemEncoder problem row col + + IndentOperatorRight op row col -> + indentOperatorRightEncoder op row col + ) + |> Serialize.variant3 Let letCodec Serialize.int Serialize.int + |> Serialize.variant3 Case caseCodec Serialize.int Serialize.int + |> Serialize.variant3 If ifCodec Serialize.int Serialize.int + |> Serialize.variant3 List listCodec Serialize.int Serialize.int + |> Serialize.variant3 Record recordCodec Serialize.int Serialize.int + |> Serialize.variant3 Tuple tupleCodec Serialize.int Serialize.int + |> Serialize.variant3 Func funcCodec Serialize.int Serialize.int + |> Serialize.variant2 Dot Serialize.int Serialize.int + |> Serialize.variant2 Access Serialize.int Serialize.int + |> Serialize.variant3 OperatorRight Serialize.string Serialize.int Serialize.int + |> Serialize.variant3 OperatorReserved Compiler.Parse.Symbol.badOperatorCodec Serialize.int Serialize.int + |> Serialize.variant2 Start Serialize.int Serialize.int + |> Serialize.variant3 Char charCodec Serialize.int Serialize.int + |> Serialize.variant3 String_ stringCodec Serialize.int Serialize.int + |> Serialize.variant3 Number numberCodec Serialize.int Serialize.int + |> Serialize.variant3 Space spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 EndlessShader Serialize.int Serialize.int + |> Serialize.variant3 ShaderProblem Serialize.string Serialize.int Serialize.int + |> Serialize.variant3 IndentOperatorRight Serialize.string Serialize.int Serialize.int + |> Serialize.finishCustomType + + letEncoder : Let -> Encode.Value letEncoder let_ = case let_ of @@ -9532,6 +9912,11 @@ letDecoder = ) +letCodec : Codec e Let +letCodec = + Debug.todo "letCodec" + + caseEncoder : Case -> Encode.Value caseEncoder case_ = case case_ of @@ -9701,6 +10086,11 @@ caseDecoder = ) +caseCodec : Codec e Case +caseCodec = + Debug.todo "caseCodec" + + ifEncoder : If -> Encode.Value ifEncoder if_ = case if_ of @@ -9868,6 +10258,11 @@ ifDecoder = ) +ifCodec : Codec e If +ifCodec = + Debug.todo "ifCodec" + + listEncoder : List_ -> Encode.Value listEncoder list_ = case list_ of @@ -9971,6 +10366,11 @@ listDecoder = ) +listCodec : Codec e List_ +listCodec = + Debug.todo "listCodec" + + recordEncoder : Record -> Encode.Value recordEncoder record = case record of @@ -10122,6 +10522,11 @@ recordDecoder = ) +recordCodec : Codec e Record +recordCodec = + Debug.todo "recordCodec" + + tupleEncoder : Tuple -> Encode.Value tupleEncoder tuple = case tuple of @@ -10239,6 +10644,11 @@ tupleDecoder = ) +tupleCodec : Codec e Tuple +tupleCodec = + Debug.todo "tupleCodec" + + funcEncoder : Func -> Encode.Value funcEncoder func = case func of @@ -10344,6 +10754,11 @@ funcDecoder = ) +funcCodec : Codec e Func +funcCodec = + Debug.todo "funcCodec" + + charEncoder : Char -> Encode.Value charEncoder char = case char of @@ -10385,6 +10800,11 @@ charDecoder = ) +charCodec : Codec e Char +charCodec = + Debug.todo "charCodec" + + stringEncoder : String_ -> Encode.Value stringEncoder string_ = case string_ of @@ -10423,6 +10843,11 @@ stringDecoder = ) +stringCodec : Codec e String_ +stringCodec = + Debug.todo "stringCodec" + + numberEncoder : Number -> Encode.Value numberEncoder number = case number of @@ -10471,6 +10896,11 @@ numberDecoder = ) +numberCodec : Codec e Number +numberCodec = + Debug.todo "numberCodec" + + escapeEncoder : Escape -> Encode.Value escapeEncoder escape = case escape of diff --git a/src/Compiler/Reporting/Error/Type.elm b/src/Compiler/Reporting/Error/Type.elm index a558a8aca..232fd820b 100644 --- a/src/Compiler/Reporting/Error/Type.elm +++ b/src/Compiler/Reporting/Error/Type.elm @@ -8,6 +8,7 @@ module Compiler.Reporting.Error.Type exposing , PContext(..) , PExpected(..) , SubContext(..) + , errorCodec , errorDecoder , errorEncoder , ptypeReplace @@ -31,6 +32,7 @@ import Compiler.Type.Error as T import Data.Map as Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -2585,6 +2587,11 @@ errorDecoder = ) +errorCodec : Codec e Error +errorCodec = + Debug.todo "errorCodec" + + categoryEncoder : Category -> Encode.Value categoryEncoder category = case category of diff --git a/src/Compiler/Reporting/Render/Type/Localizer.elm b/src/Compiler/Reporting/Render/Type/Localizer.elm index bb39fcce3..5f2f81bb0 100644 --- a/src/Compiler/Reporting/Render/Type/Localizer.elm +++ b/src/Compiler/Reporting/Render/Type/Localizer.elm @@ -3,6 +3,7 @@ module Compiler.Reporting.Render.Type.Localizer exposing , empty , fromModule , fromNames + , localizerCodec , localizerDecoder , localizerEncoder , toChars @@ -20,6 +21,7 @@ import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode import Json.Encode as Encode +import Serialize exposing (Codec) @@ -141,6 +143,11 @@ localizerDecoder = Decode.map Localizer (DecodeX.assocListDict compare Decode.string importDecoder) +localizerCodec : Codec e Localizer +localizerCodec = + Debug.todo "localizerCodec" + + importEncoder : Import -> Encode.Value importEncoder import_ = Encode.object diff --git a/src/Compiler/Serialize.elm b/src/Compiler/Serialize.elm index 4270bae04..a385baca9 100644 --- a/src/Compiler/Serialize.elm +++ b/src/Compiler/Serialize.elm @@ -1,6 +1,12 @@ -module Compiler.Serialize exposing (assocListDict, everySet, nonempty) +module Compiler.Serialize exposing + ( assocListDict + , everySet + , nonempty + , oneOrMore + ) import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore exposing (OneOrMore) import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) import Serialize as S exposing (Codec) @@ -32,3 +38,8 @@ nonempty codec = Err S.DataCorrupted ) (\(NE.Nonempty x xs) -> x :: xs) + + +oneOrMore : Codec e a -> Codec e (OneOrMore a) +oneOrMore _ = + Debug.todo "oneOrMore" diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index a372bc815..d6fe4debe 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -59,6 +59,7 @@ module Utils.Main exposing , fpTakeDirectory , fpTakeExtension , fpTakeFileName + , httpExceptionContentCodec , httpExceptionContentDecoder , httpExceptionContentEncoder , httpHLocation @@ -128,6 +129,7 @@ module Utils.Main exposing , sequenceListMaybe , sequenceNonemptyListResult , shaAndArchiveDecoder + , someExceptionCodec , someExceptionDecoder , someExceptionEncoder , stateGet @@ -1327,6 +1329,11 @@ someExceptionDecoder = Decode.succeed SomeException +someExceptionCodec : Codec e SomeException +someExceptionCodec = + Debug.todo "someExceptionCodec" + + httpResponseEncoder : HttpResponse body -> Encode.Value httpResponseEncoder (HttpResponse httpResponse) = Encode.object @@ -1418,3 +1425,8 @@ httpExceptionContentDecoder = _ -> Decode.fail ("Failed to decode HttpExceptionContent's type: " ++ type_) ) + + +httpExceptionContentCodec : Codec e HttpExceptionContent +httpExceptionContentCodec = + Debug.todo "httpExceptionContentCodec" From 04e51e99f3fdb0d8e3d690d0d3e3ca641232ef8d Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Sun, 8 Dec 2024 15:17:02 +0000 Subject: [PATCH 4/7] WIP elm-serialize --- src/Compiler/Parse/Symbol.elm | 25 ++++++++++++++++++++++++- src/Utils/Main.elm | 7 ++++++- 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Parse/Symbol.elm b/src/Compiler/Parse/Symbol.elm index 76a6eb074..712c80331 100644 --- a/src/Compiler/Parse/Symbol.elm +++ b/src/Compiler/Parse/Symbol.elm @@ -154,4 +154,27 @@ badOperatorDecoder = badOperatorCodec : Codec e BadOperator badOperatorCodec = - Debug.todo "badOperatorCodec" + Serialize.customType + (\badDotEncoder badPipeEncoder badArrowEncoder badEqualsEncoder badHasTypeEncoder badOperator -> + case badOperator of + BadDot -> + badDotEncoder + + BadPipe -> + badPipeEncoder + + BadArrow -> + badArrowEncoder + + BadEquals -> + badEqualsEncoder + + BadHasType -> + badHasTypeEncoder + ) + |> Serialize.variant0 BadDot + |> Serialize.variant0 BadPipe + |> Serialize.variant0 BadArrow + |> Serialize.variant0 BadEquals + |> Serialize.variant0 BadHasType + |> Serialize.finishCustomType diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index 9af65225a..4cdc1f9d7 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -1163,7 +1163,12 @@ someExceptionDecoder = someExceptionCodec : Codec e SomeException someExceptionCodec = - Debug.todo "someExceptionCodec" + Serialize.customType + (\someExceptionCodecEncoder SomeException -> + someExceptionCodecEncoder + ) + |> Serialize.variant0 SomeException + |> Serialize.finishCustomType httpResponseEncoder : HttpResponse body -> Encode.Value From caa10b90f12ad60b95d230830278967e25fb6356 Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Wed, 11 Dec 2024 17:45:39 +0000 Subject: [PATCH 5/7] WIP elm-serialize --- elm.json | 9 +- src/Builder/Build.elm | 26 +- src/Builder/Deps/Registry.elm | 35 - src/Builder/Deps/Solver.elm | 55 - src/Builder/Elm/Details.elm | 92 +- src/Builder/File.elm | 14 - src/Builder/Http.elm | 75 - src/Builder/Reporting/Exit.elm | 313 -- src/Builder/Stuff.elm | 17 - src/Compiler/AST/Canonical.elm | 1187 ++--- src/Compiler/AST/Optimized.elm | 780 --- src/Compiler/AST/Source.elm | 1489 ++---- src/Compiler/AST/Utils/Shader.elm | 143 +- src/Compiler/Data/Index.elm | 14 - src/Compiler/Elm/Compiler/Type.elm | 114 +- src/Compiler/Elm/Compiler/Type/Extract.elm | 49 +- src/Compiler/Elm/Docs.elm | 166 +- src/Compiler/Elm/Interface.elm | 168 - src/Compiler/Elm/Kernel.elm | 95 - src/Compiler/Elm/ModuleName.elm | 31 - src/Compiler/Elm/Package.elm | 19 - src/Compiler/Elm/Version.elm | 43 - src/Compiler/Nitpick/PatternMatches.elm | 245 +- src/Compiler/Optimize/DecisionTree.elm | 151 - src/Compiler/Parse/Primitives.elm | 53 +- src/Compiler/Parse/Symbol.elm | 49 - src/Compiler/Reporting/Annotation.elm | 63 +- src/Compiler/Reporting/Error.elm | 116 - src/Compiler/Reporting/Error/Canonicalize.elm | 1152 ++--- src/Compiler/Reporting/Error/Docs.elm | 361 +- src/Compiler/Reporting/Error/Import.elm | 103 +- src/Compiler/Reporting/Error/Main.elm | 76 +- src/Compiler/Reporting/Error/Syntax.elm | 4273 +++-------------- src/Compiler/Reporting/Error/Type.elm | 919 +--- .../Reporting/Render/Type/Localizer.elm | 94 +- src/Compiler/Serialize.elm | 17 +- src/Compiler/Type/Error.elm | 347 +- src/Serialize.elm | 1947 ++++++++ src/Terminal/Publish.elm | 3 +- src/Utils/Main.elm | 46 +- 40 files changed, 4618 insertions(+), 10331 deletions(-) create mode 100644 src/Serialize.elm diff --git a/elm.json b/elm.json index 97501f22c..46473f748 100644 --- a/elm.json +++ b/elm.json @@ -6,10 +6,13 @@ "elm-version": "0.19.1", "dependencies": { "direct": { - "MartinSStewart/elm-serialize": "1.3.1", + "bburdette/toop": "1.2.0", + "danfishgold/base64-bytes": "1.1.0", "dasch/levenshtein": "1.0.3", + "elm/bytes": "1.0.8", "elm/core": "1.0.5", "elm/json": "1.1.3", + "elm/regex": "1.0.0", "elm/time": "1.0.0", "elm/url": "1.0.0", "elm-community/array-extra": "2.6.0", @@ -24,11 +27,7 @@ }, "indirect": { "andre-dietrich/parser-combinators": "4.1.0", - "bburdette/toop": "1.2.0", - "danfishgold/base64-bytes": "1.1.0", - "elm/bytes": "1.0.8", "elm/parser": "1.1.0", - "elm/regex": "1.0.0", "fredcy/elm-parseint": "2.0.1", "pilatch/flip": "1.0.0", "zwilias/elm-rosetree": "1.5.0" diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm index 8eef3ace2..b8ab7657a 100644 --- a/src/Builder/Build.elm +++ b/src/Builder/Build.elm @@ -8,7 +8,6 @@ module Builder.Build exposing , ReplArtifacts(..) , Root(..) , cachedInterfaceCodec - , cachedInterfaceDecoder , fromExposed , fromPaths , fromRepl @@ -49,7 +48,6 @@ import Compiler.Serialize as S import Data.Graph as Graph import Data.Map as Dict exposing (Dict) import Data.Set as EverySet -import Json.Decode as Decode import Serialize exposing (Codec) import System.IO as IO exposing (IO) import System.TypeCheck.IO as TypeCheck @@ -1873,12 +1871,12 @@ bResultCodec = Details.localCodec I.interfaceCodec Opt.localGraphCodec - (Serialize.maybe Docs.jsonModuleCodec) + (Serialize.maybe Docs.moduleCodec) |> Serialize.variant4 RSame Details.localCodec I.interfaceCodec Opt.localGraphCodec - (Serialize.maybe Docs.jsonModuleCodec) + (Serialize.maybe Docs.moduleCodec) |> Serialize.variant3 RCached Serialize.bool Serialize.int @@ -1997,26 +1995,6 @@ resultBuildProjectProblemRootInfoCodec = Serialize.result Exit.buildProjectProblemCodec rootInfoCodec -cachedInterfaceDecoder : Decode.Decoder CachedInterface -cachedInterfaceDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Unneeded" -> - Decode.succeed Unneeded - - "Loaded" -> - Decode.map Loaded (Decode.field "iface" I.interfaceDecoder) - - "Corrupted" -> - Decode.succeed Corrupted - - _ -> - Decode.fail ("Failed to decode CachedInterface's type: " ++ type_) - ) - - cachedInterfaceCodec : Codec e CachedInterface cachedInterfaceCodec = Serialize.customType diff --git a/src/Builder/Deps/Registry.elm b/src/Builder/Deps/Registry.elm index 35ba289a4..d8c588785 100644 --- a/src/Builder/Deps/Registry.elm +++ b/src/Builder/Deps/Registry.elm @@ -7,8 +7,6 @@ module Builder.Deps.Registry exposing , latest , read , registryCodec - , registryDecoder - , registryEncoder , update ) @@ -21,12 +19,9 @@ import Builder.Stuff as Stuff import Compiler.Elm.Package as Pkg import Compiler.Elm.Version as V import Compiler.Json.Decode as D -import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.IO as IO exposing (IO) @@ -43,21 +38,6 @@ type KnownVersions = KnownVersions V.Version (List V.Version) -knownVersionsDecoder : Decode.Decoder KnownVersions -knownVersionsDecoder = - Decode.map2 KnownVersions - (Decode.field "version" V.jsonDecoder) - (Decode.field "versions" (Decode.list V.jsonDecoder)) - - -knownVersionsEncoder : KnownVersions -> Encode.Value -knownVersionsEncoder (KnownVersions version versions) = - Encode.object - [ ( "version", V.jsonEncoder version ) - , ( "versions", Encode.list V.jsonEncoder versions ) - ] - - knownVersionsCodec : Codec e KnownVersions knownVersionsCodec = Serialize.customType @@ -262,21 +242,6 @@ post manager path decoder callback = -- ENCODERS and DECODERS -registryEncoder : Registry -> Encode.Value -registryEncoder (Registry size versions) = - Encode.object - [ ( "size", Encode.int size ) - , ( "packages", E.assocListDict Pkg.nameEncoder knownVersionsEncoder versions ) - ] - - -registryDecoder : Decode.Decoder Registry -registryDecoder = - Decode.map2 Registry - (Decode.field "size" Decode.int) - (Decode.field "packages" (D.assocListDict Pkg.compareName Pkg.nameDecoder knownVersionsDecoder)) - - registryCodec : Codec e Registry registryCodec = Serialize.customType diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index cc941aa51..15070ef03 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -8,8 +8,6 @@ module Builder.Deps.Solver exposing , State , addToApp , envCodec - , envDecoder - , envEncoder , initEnv , verify ) @@ -26,8 +24,6 @@ import Compiler.Elm.Package as Pkg import Compiler.Elm.Version as V import Compiler.Json.Decode as D import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.IO as IO exposing (IO) import Utils.Crash exposing (crash) @@ -596,25 +592,6 @@ foldM f b = -- ENCODERS and DECODERS -envEncoder : Env -> Encode.Value -envEncoder (Env cache manager connection registry) = - Encode.object - [ ( "cache", Stuff.packageCacheEncoder cache ) - , ( "manager", Http.managerEncoder manager ) - , ( "connection", connectionEncoder connection ) - , ( "registry", Registry.registryEncoder registry ) - ] - - -envDecoder : Decode.Decoder Env -envDecoder = - Decode.map4 Env - (Decode.field "cache" Stuff.packageCacheDecoder) - (Decode.field "manager" Http.managerDecoder) - (Decode.field "connection" connectionDecoder) - (Decode.field "registry" Registry.registryDecoder) - - envCodec : Codec e Env envCodec = Serialize.customType @@ -625,38 +602,6 @@ envCodec = |> Serialize.finishCustomType -connectionEncoder : Connection -> Encode.Value -connectionEncoder connection = - case connection of - Online manager -> - Encode.object - [ ( "type", Encode.string "Online" ) - , ( "manager", Http.managerEncoder manager ) - ] - - Offline -> - Encode.object - [ ( "type", Encode.string "Offline" ) - ] - - -connectionDecoder : Decode.Decoder Connection -connectionDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Online" -> - Decode.map Online (Decode.field "manager" Http.managerDecoder) - - "Offline" -> - Decode.succeed Offline - - _ -> - Decode.fail ("Failed to decode Connection's type: " ++ type_) - ) - - connectionCodec : Codec e Connection connectionCodec = Serialize.customType diff --git a/src/Builder/Elm/Details.elm b/src/Builder/Elm/Details.elm index cd91bd842..25b046476 100644 --- a/src/Builder/Elm/Details.elm +++ b/src/Builder/Elm/Details.elm @@ -8,13 +8,10 @@ module Builder.Elm.Details exposing , Status , ValidOutline(..) , detailsCodec - , detailsEncoder , load , loadInterfaces , loadObjects , localCodec - , localDecoder - , localEncoder , verifyInstall ) @@ -50,8 +47,6 @@ import Compiler.Reporting.Annotation as A import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.IO as IO exposing (IO) import System.TypeCheck.IO as TypeCheck @@ -1087,19 +1082,6 @@ endpointDecoder = -- ENCODERS and DECODERS -detailsEncoder : Details -> Encode.Value -detailsEncoder (Details oldTime outline buildID locals foreigns extras) = - Encode.object - [ ( "type", Encode.string "Details" ) - , ( "oldTime", File.timeEncoder oldTime ) - , ( "outline", validOutlineEncoder outline ) - , ( "buildID", Encode.int buildID ) - , ( "locals", E.assocListDict ModuleName.rawEncoder localEncoder locals ) - , ( "foreigns", E.assocListDict ModuleName.rawEncoder foreignEncoder foreigns ) - , ( "extras", extrasEncoder extras ) - ] - - detailsCodec : Codec (Serialize.Error e) Details detailsCodec = Serialize.customType @@ -1116,11 +1098,6 @@ detailsCodec = |> Serialize.finishCustomType -interfacesEncoder : Interfaces -> Encode.Value -interfacesEncoder = - E.assocListDict ModuleName.canonicalEncoder I.dependencyInterfaceEncoder - - interfacesCodec : Codec e Interfaces interfacesCodec = S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec I.dependencyInterfaceCodec @@ -1217,7 +1194,7 @@ dResultCodec = RKernelForeign -> rKernelForeignEncoder ) - |> Serialize.variant3 RLocal I.interfaceCodec Opt.localGraphCodec (Serialize.maybe Docs.jsonModuleCodec) + |> Serialize.variant3 RLocal I.interfaceCodec Opt.localGraphCodec (Serialize.maybe Docs.moduleCodec) |> Serialize.variant1 RForeign I.interfaceCodec |> Serialize.variant1 RKernelLocal (Serialize.list Kernel.chunkCodec) |> Serialize.variant0 RKernelForeign @@ -1229,30 +1206,6 @@ statusDictCodec = S.assocListDict compare ModuleName.rawCodec Utils.mVarCodec -localEncoder : Local -> Encode.Value -localEncoder (Local path time deps hasMain lastChange lastCompile) = - Encode.object - [ ( "type", Encode.string "Local" ) - , ( "path", Encode.string path ) - , ( "time", File.timeEncoder time ) - , ( "deps", Encode.list ModuleName.rawEncoder deps ) - , ( "hasMain", Encode.bool hasMain ) - , ( "lastChange", Encode.int lastChange ) - , ( "lastCompile", Encode.int lastCompile ) - ] - - -localDecoder : Decode.Decoder Local -localDecoder = - Decode.map6 Local - (Decode.field "path" Decode.string) - (Decode.field "time" File.timeDecoder) - (Decode.field "deps" (Decode.list ModuleName.rawDecoder)) - (Decode.field "hasMain" Decode.bool) - (Decode.field "lastChange" Decode.int) - (Decode.field "lastCompile" Decode.int) - - localCodec : Codec e Local localCodec = Serialize.customType @@ -1263,24 +1216,6 @@ localCodec = |> Serialize.finishCustomType -validOutlineEncoder : ValidOutline -> Encode.Value -validOutlineEncoder validOutline = - case validOutline of - ValidApp srcDirs -> - Encode.object - [ ( "type", Encode.string "ValidApp" ) - , ( "srcDirs", E.nonempty Outline.srcDirEncoder srcDirs ) - ] - - ValidPkg pkg exposedList exactDeps -> - Encode.object - [ ( "type", Encode.string "ValidPkg" ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "exposedList", Encode.list ModuleName.rawEncoder exposedList ) - , ( "exactDeps", E.assocListDict Pkg.nameEncoder V.versionEncoder exactDeps ) - ] - - validOutlineCodec : Codec (Serialize.Error e) ValidOutline validOutlineCodec = Serialize.customType @@ -1297,15 +1232,6 @@ validOutlineCodec = |> Serialize.finishCustomType -foreignEncoder : Foreign -> Encode.Value -foreignEncoder (Foreign dep deps) = - Encode.object - [ ( "type", Encode.string "Foreign" ) - , ( "dep", Pkg.nameEncoder dep ) - , ( "deps", Encode.list Pkg.nameEncoder deps ) - ] - - foreignCodec : Codec e Foreign foreignCodec = Serialize.customType @@ -1316,22 +1242,6 @@ foreignCodec = |> Serialize.finishCustomType -extrasEncoder : Extras -> Encode.Value -extrasEncoder extras = - case extras of - ArtifactsCached -> - Encode.object - [ ( "type", Encode.string "ArtifactsCached" ) - ] - - ArtifactsFresh ifaces objs -> - Encode.object - [ ( "type", Encode.string "ArtifactsFresh" ) - , ( "ifaces", interfacesEncoder ifaces ) - , ( "objs", Opt.globalGraphEncoder objs ) - ] - - extrasCodec : Codec e Extras extrasCodec = Serialize.customType diff --git a/src/Builder/File.elm b/src/Builder/File.elm index 7d197814b..45bd3b235 100644 --- a/src/Builder/File.elm +++ b/src/Builder/File.elm @@ -6,8 +6,6 @@ module Builder.File exposing , readUtf8 , remove , timeCodec - , timeDecoder - , timeEncoder , writeBinary , writeBuilder , writePackage @@ -16,8 +14,6 @@ module Builder.File exposing ) import Codec.Archive.Zip as Zip -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.IO as IO exposing (IO(..)) import Time @@ -190,16 +186,6 @@ remove path = -- ENCODERS and DECODERS -timeEncoder : Time -> Encode.Value -timeEncoder (Time posix) = - Encode.int (Time.posixToMillis posix) - - -timeDecoder : Decode.Decoder Time -timeDecoder = - Decode.map (Time << Time.millisToPosix) Decode.int - - timeCodec : Codec e Time timeCodec = Serialize.int |> Serialize.map (Time << Time.millisToPosix) (\(Time posix) -> Time.posixToMillis posix) diff --git a/src/Builder/Http.elm b/src/Builder/Http.elm index d4c47bfa9..368c961bb 100644 --- a/src/Builder/Http.elm +++ b/src/Builder/Http.elm @@ -6,16 +6,12 @@ module Builder.Http exposing , Sha , accept , errorCodec - , errorDecoder - , errorEncoder , filePart , get , getArchive , getManager , jsonPart , managerCodec - , managerDecoder - , managerEncoder , post , shaToChars , stringPart @@ -26,7 +22,6 @@ module Builder.Http exposing import Basics.Extra exposing (uncurry) import Codec.Archive.Zip as Zip import Compiler.Elm.Version as V -import Json.Decode as Decode import Json.Encode as Encode import Serialize exposing (Codec) import System.IO as IO exposing (IO(..)) @@ -42,25 +37,6 @@ type Manager = Manager -managerEncoder : Manager -> Encode.Value -managerEncoder _ = - Encode.object [ ( "type", Encode.string "Manager" ) ] - - -managerDecoder : Decode.Decoder Manager -managerDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Manager" -> - Decode.succeed Manager - - _ -> - Decode.fail "Failed to decode Http.Manager" - ) - - managerCodec : Codec e Manager managerCodec = Serialize.customType @@ -257,57 +233,6 @@ stringPart name string = -- ENCODERS and DECODERS -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - BadUrl url reason -> - Encode.object - [ ( "type", Encode.string "BadUrl" ) - , ( "url", Encode.string url ) - , ( "reason", Encode.string reason ) - ] - - BadHttp url httpExceptionContent -> - Encode.object - [ ( "type", Encode.string "BadHttp" ) - , ( "url", Encode.string url ) - , ( "httpExceptionContent", Utils.httpExceptionContentEncoder httpExceptionContent ) - ] - - BadMystery url someException -> - Encode.object - [ ( "type", Encode.string "BadMystery" ) - , ( "url", Encode.string url ) - , ( "someException", Utils.someExceptionEncoder someException ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "BadUrl" -> - Decode.map2 BadUrl - (Decode.field "url" Decode.string) - (Decode.field "reason" Decode.string) - - "BadHttp" -> - Decode.map2 BadHttp - (Decode.field "url" Decode.string) - (Decode.field "httpExceptionContent" Utils.httpExceptionContentDecoder) - - "BadMystery" -> - Decode.map2 BadMystery - (Decode.field "url" Decode.string) - (Decode.field "someException" Utils.someExceptionDecoder) - - _ -> - Decode.fail ("Failed to decode Error's type: " ++ type_) - ) - - errorCodec : Codec e Error errorCodec = Serialize.customType diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm index 5c24a79ed..3a0b645c7 100644 --- a/src/Builder/Reporting/Exit.elm +++ b/src/Builder/Reporting/Exit.elm @@ -18,15 +18,9 @@ module Builder.Reporting.Exit exposing , Repl(..) , Solver(..) , buildProblemCodec - , buildProblemDecoder - , buildProblemEncoder , buildProjectProblemCodec - , buildProjectProblemDecoder - , buildProjectProblemEncoder , bumpToReport , detailsBadDepCodec - , detailsBadDepDecoder - , detailsBadDepEncoder , diffToReport , initToReport , installToReport @@ -34,8 +28,6 @@ module Builder.Reporting.Exit exposing , newPackageOverview , publishToReport , registryProblemCodec - , registryProblemDecoder - , registryProblemEncoder , replToReport , toJson , toStderr @@ -62,8 +54,6 @@ import Compiler.Reporting.Error.Json as Json import Compiler.Reporting.Render.Code as Code import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) -import Json.Decode as CoreDecode -import Json.Encode as CoreEncode import Serialize exposing (Codec) import System.IO exposing (IO) import Utils.Main as Utils exposing (FilePath) @@ -2830,49 +2820,6 @@ replToReport problem = -- ENCODERS and DECODERS -detailsBadDepEncoder : DetailsBadDep -> CoreEncode.Value -detailsBadDepEncoder detailsBadDep = - case detailsBadDep of - BD_BadDownload pkg vsn packageProblem -> - CoreEncode.object - [ ( "type", CoreEncode.string "BD_BadDownload" ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "vsn", V.versionEncoder vsn ) - , ( "packageProblem", packageProblemEncoder packageProblem ) - ] - - BD_BadBuild pkg vsn fingerprint -> - CoreEncode.object - [ ( "type", CoreEncode.string "BD_BadBuild" ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "vsn", V.versionEncoder vsn ) - , ( "fingerprint", Encode.assocListDict Pkg.nameEncoder V.versionEncoder fingerprint ) - ] - - -detailsBadDepDecoder : CoreDecode.Decoder DetailsBadDep -detailsBadDepDecoder = - CoreDecode.field "type" CoreDecode.string - |> CoreDecode.andThen - (\type_ -> - case type_ of - "BD_BadDownload" -> - CoreDecode.map3 BD_BadDownload - (CoreDecode.field "pkg" Pkg.nameDecoder) - (CoreDecode.field "vsn" V.versionDecoder) - (CoreDecode.field "packageProblem" packageProblemDecoder) - - "BD_BadBuild" -> - CoreDecode.map3 BD_BadBuild - (CoreDecode.field "pkg" Pkg.nameDecoder) - (CoreDecode.field "vsn" V.versionDecoder) - (CoreDecode.field "fingerprint" (Decode.assocListDict Pkg.compareName Pkg.nameDecoder V.versionDecoder)) - - _ -> - CoreDecode.fail ("Failed to decode DetailsBadDep's type: " ++ type_) - ) - - detailsBadDepCodec : Codec e DetailsBadDep detailsBadDepCodec = Serialize.customType @@ -2889,44 +2836,6 @@ detailsBadDepCodec = |> Serialize.finishCustomType -buildProblemEncoder : BuildProblem -> CoreEncode.Value -buildProblemEncoder buildProblem = - case buildProblem of - BuildBadModules root e es -> - CoreEncode.object - [ ( "type", CoreEncode.string "BuildBadModules" ) - , ( "root", CoreEncode.string root ) - , ( "e", Error.moduleEncoder e ) - , ( "es", CoreEncode.list Error.jsonToJson es ) - ] - - BuildProjectProblem problem -> - CoreEncode.object - [ ( "type", CoreEncode.string "BuildProjectProblem" ) - , ( "problem", buildProjectProblemEncoder problem ) - ] - - -buildProblemDecoder : CoreDecode.Decoder BuildProblem -buildProblemDecoder = - CoreDecode.field "type" CoreDecode.string - |> CoreDecode.andThen - (\type_ -> - case type_ of - "BuildBadModules" -> - CoreDecode.map3 BuildBadModules - (CoreDecode.field "root" CoreDecode.string) - (CoreDecode.field "e" Error.moduleDecoder) - (CoreDecode.field "es" (CoreDecode.list Error.moduleDecoder)) - - "BuildProjectProblem" -> - CoreDecode.map BuildProjectProblem (CoreDecode.field "problem" buildProjectProblemDecoder) - - _ -> - CoreDecode.fail ("Failed to decode BuildProblem's type: " ++ type_) - ) - - buildProblemCodec : Codec (Serialize.Error e) BuildProblem buildProblemCodec = Serialize.customType @@ -2943,127 +2852,6 @@ buildProblemCodec = |> Serialize.finishCustomType -buildProjectProblemEncoder : BuildProjectProblem -> CoreEncode.Value -buildProjectProblemEncoder buildProjectProblem = - case buildProjectProblem of - BP_PathUnknown path -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_PathUnknown" ) - , ( "path", CoreEncode.string path ) - ] - - BP_WithBadExtension path -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_WithBadExtension" ) - , ( "path", CoreEncode.string path ) - ] - - BP_WithAmbiguousSrcDir path srcDir1 srcDir2 -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_WithAmbiguousSrcDir" ) - , ( "path", CoreEncode.string path ) - , ( "srcDir1", CoreEncode.string srcDir1 ) - , ( "srcDir2", CoreEncode.string srcDir2 ) - ] - - BP_MainPathDuplicate path1 path2 -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_MainPathDuplicate" ) - , ( "path1", CoreEncode.string path1 ) - , ( "path2", CoreEncode.string path2 ) - ] - - BP_RootNameDuplicate name outsidePath otherPath -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_RootNameDuplicate" ) - , ( "name", ModuleName.rawEncoder name ) - , ( "outsidePath", CoreEncode.string outsidePath ) - , ( "otherPath", CoreEncode.string otherPath ) - ] - - BP_RootNameInvalid givenPath srcDir names -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_RootNameInvalid" ) - , ( "givenPath", CoreEncode.string givenPath ) - , ( "srcDir", CoreEncode.string srcDir ) - , ( "names", CoreEncode.list CoreEncode.string names ) - ] - - BP_CannotLoadDependencies -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_CannotLoadDependencies" ) - ] - - BP_Cycle name names -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_Cycle" ) - , ( "name", ModuleName.rawEncoder name ) - , ( "names", CoreEncode.list ModuleName.rawEncoder names ) - ] - - BP_MissingExposed problems -> - CoreEncode.object - [ ( "type", CoreEncode.string "BP_MissingExposed" ) - , ( "problems", Encode.nonempty (Encode.jsonPair ModuleName.rawEncoder Import.problemEncoder) problems ) - ] - - -buildProjectProblemDecoder : CoreDecode.Decoder BuildProjectProblem -buildProjectProblemDecoder = - CoreDecode.field "type" CoreDecode.string - |> CoreDecode.andThen - (\type_ -> - case type_ of - "BP_PathUnknown" -> - CoreDecode.map BP_PathUnknown (CoreDecode.field "path" CoreDecode.string) - - "BP_WithBadExtension" -> - CoreDecode.map BP_WithBadExtension (CoreDecode.field "path" CoreDecode.string) - - "BP_WithAmbiguousSrcDir" -> - CoreDecode.map3 BP_WithAmbiguousSrcDir - (CoreDecode.field "path" CoreDecode.string) - (CoreDecode.field "srcDir1" CoreDecode.string) - (CoreDecode.field "srcDir2" CoreDecode.string) - - "BP_MainPathDuplicate" -> - CoreDecode.map2 BP_MainPathDuplicate - (CoreDecode.field "path1" CoreDecode.string) - (CoreDecode.field "path2" CoreDecode.string) - - "BP_RootNameDuplicate" -> - CoreDecode.map3 BP_RootNameDuplicate - (CoreDecode.field "name" ModuleName.rawDecoder) - (CoreDecode.field "outsidePath" CoreDecode.string) - (CoreDecode.field "otherPath" CoreDecode.string) - - "BP_RootNameInvalid" -> - CoreDecode.map3 BP_RootNameInvalid - (CoreDecode.field "givenPath" CoreDecode.string) - (CoreDecode.field "srcDir" CoreDecode.string) - (CoreDecode.field "names" (CoreDecode.list CoreDecode.string)) - - "BP_CannotLoadDependencies" -> - CoreDecode.succeed BP_CannotLoadDependencies - - "BP_Cycle" -> - CoreDecode.map2 BP_Cycle - (CoreDecode.field "name" ModuleName.rawDecoder) - (CoreDecode.field "names" (CoreDecode.list ModuleName.rawDecoder)) - - "BP_MissingExposed" -> - CoreDecode.map BP_MissingExposed - (CoreDecode.field "problems" - (Decode.nonempty - (Decode.jsonPair ModuleName.rawDecoder Import.problemDecoder) - ) - ) - - _ -> - CoreDecode.fail ("Failed to decode BuildProjectProblem's type: " ++ type_) - ) - - buildProjectProblemCodec : Codec (Serialize.Error e) BuildProjectProblem buildProjectProblemCodec = Serialize.customType @@ -3108,42 +2896,6 @@ buildProjectProblemCodec = |> Serialize.finishCustomType -registryProblemEncoder : RegistryProblem -> CoreEncode.Value -registryProblemEncoder registryProblem = - case registryProblem of - RP_Http err -> - CoreEncode.object - [ ( "type", CoreEncode.string "RP_Http" ) - , ( "err", Http.errorEncoder err ) - ] - - RP_Data url body -> - CoreEncode.object - [ ( "type", CoreEncode.string "RP_Data" ) - , ( "url", CoreEncode.string url ) - , ( "body", CoreEncode.string body ) - ] - - -registryProblemDecoder : CoreDecode.Decoder RegistryProblem -registryProblemDecoder = - CoreDecode.field "type" CoreDecode.string - |> CoreDecode.andThen - (\type_ -> - case type_ of - "RP_Http" -> - CoreDecode.map RP_Http (CoreDecode.field "err" Http.errorDecoder) - - "RP_Data" -> - CoreDecode.map2 RP_Data - (CoreDecode.field "url" CoreDecode.string) - (CoreDecode.field "body" CoreDecode.string) - - _ -> - CoreDecode.fail ("Failed to decode RegistryProblem's type: " ++ type_) - ) - - registryProblemCodec : Codec e RegistryProblem registryProblemCodec = Serialize.customType @@ -3160,71 +2912,6 @@ registryProblemCodec = |> Serialize.finishCustomType -packageProblemEncoder : PackageProblem -> CoreEncode.Value -packageProblemEncoder packageProblem = - case packageProblem of - PP_BadEndpointRequest httpError -> - CoreEncode.object - [ ( "type", CoreEncode.string "PP_BadEndpointRequest" ) - , ( "httpError", Http.errorEncoder httpError ) - ] - - PP_BadEndpointContent url -> - CoreEncode.object - [ ( "type", CoreEncode.string "PP_BadEndpointContent" ) - , ( "url", CoreEncode.string url ) - ] - - PP_BadArchiveRequest httpError -> - CoreEncode.object - [ ( "type", CoreEncode.string "PP_BadArchiveRequest" ) - , ( "httpError", Http.errorEncoder httpError ) - ] - - PP_BadArchiveContent url -> - CoreEncode.object - [ ( "type", CoreEncode.string "PP_BadArchiveContent" ) - , ( "url", CoreEncode.string url ) - ] - - PP_BadArchiveHash url expectedHash actualHash -> - CoreEncode.object - [ ( "type", CoreEncode.string "PP_BadArchiveHash" ) - , ( "url", CoreEncode.string url ) - , ( "expectedHash", CoreEncode.string expectedHash ) - , ( "actualHash", CoreEncode.string actualHash ) - ] - - -packageProblemDecoder : CoreDecode.Decoder PackageProblem -packageProblemDecoder = - CoreDecode.field "type" CoreDecode.string - |> CoreDecode.andThen - (\type_ -> - case type_ of - "PP_BadEndpointRequest" -> - CoreDecode.map PP_BadEndpointRequest (CoreDecode.field "httpError" Http.errorDecoder) - - "PP_BadEndpointContent" -> - CoreDecode.map PP_BadEndpointContent (CoreDecode.field "url" CoreDecode.string) - - "PP_BadArchiveRequest" -> - CoreDecode.map PP_BadArchiveRequest (CoreDecode.field "httpError" Http.errorDecoder) - - "PP_BadArchiveContent" -> - CoreDecode.map PP_BadArchiveContent (CoreDecode.field "url" CoreDecode.string) - - "PP_BadArchiveHash" -> - CoreDecode.map3 PP_BadArchiveHash - (CoreDecode.field "url" CoreDecode.string) - (CoreDecode.field "expectedHash" CoreDecode.string) - (CoreDecode.field "actualHash" CoreDecode.string) - - _ -> - CoreDecode.fail ("Failed to decode PackageProblem's type: " ++ type_) - ) - - packageProblemCodec : Codec e PackageProblem packageProblemCodec = Serialize.customType diff --git a/src/Builder/Stuff.elm b/src/Builder/Stuff.elm index eeee77d94..45aea8da5 100644 --- a/src/Builder/Stuff.elm +++ b/src/Builder/Stuff.elm @@ -11,8 +11,6 @@ module Builder.Stuff exposing , objects , package , packageCacheCodec - , packageCacheDecoder - , packageCacheEncoder , prepublishDir , registry , withRegistryLock @@ -22,8 +20,6 @@ module Builder.Stuff exposing import Compiler.Elm.ModuleName as ModuleName import Compiler.Elm.Package as Pkg import Compiler.Elm.Version as V -import Json.Decode as Decode -import Json.Encode as Encode import Prelude import Serialize exposing (Codec) import System.IO as IO exposing (IO) @@ -202,19 +198,6 @@ getElmHome = -- ENCODERS and DECODERS -packageCacheEncoder : PackageCache -> Encode.Value -packageCacheEncoder (PackageCache dir) = - Encode.object - [ ( "type", Encode.string "PackageCache" ) - , ( "dir", Encode.string dir ) - ] - - -packageCacheDecoder : Decode.Decoder PackageCache -packageCacheDecoder = - Decode.map PackageCache (Decode.field "dir" Decode.string) - - packageCacheCodec : Codec e PackageCache packageCacheCodec = Serialize.customType diff --git a/src/Compiler/AST/Canonical.elm b/src/Compiler/AST/Canonical.elm index 9e59bf0bc..2f82c4b43 100644 --- a/src/Compiler/AST/Canonical.elm +++ b/src/Compiler/AST/Canonical.elm @@ -25,23 +25,12 @@ module Compiler.AST.Canonical exposing , Type(..) , Union(..) , aliasCodec - , aliasDecoder - , aliasEncoder , annotationCodec - , annotationDecoder - , annotationEncoder , ctorOptsCodec - , ctorOptsDecoder - , ctorOptsEncoder - , fieldUpdateDecoder - , fieldUpdateEncoder + , fieldUpdateCodec , fieldsToList , typeCodec - , typeDecoder - , typeEncoder , unionCodec - , unionDecoder - , unionEncoder ) {- Creating a canonical AST means finding the home module for all variables. @@ -69,13 +58,9 @@ import Compiler.AST.Utils.Shader as Shader import Compiler.Data.Index as Index import Compiler.Data.Name exposing (Name) import Compiler.Elm.ModuleName as ModuleName -import Compiler.Json.Decode as D -import Compiler.Json.Encode as E import Compiler.Reporting.Annotation as A import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO as IO @@ -326,22 +311,6 @@ type Manager -- ENCODERS and DECODERS -annotationEncoder : Annotation -> Encode.Value -annotationEncoder (Forall freeVars tipe) = - Encode.object - [ ( "type", Encode.string "Forall" ) - , ( "freeVars", freeVarsEncoder freeVars ) - , ( "tipe", typeEncoder tipe ) - ] - - -annotationDecoder : Decode.Decoder Annotation -annotationDecoder = - Decode.map2 Forall - (Decode.field "freeVars" freeVarsDecoder) - (Decode.field "tipe" typeDecoder) - - annotationCodec : Codec e Annotation annotationCodec = Serialize.customType @@ -352,36 +321,11 @@ annotationCodec = |> Serialize.finishCustomType -freeVarsEncoder : FreeVars -> Encode.Value -freeVarsEncoder = - E.assocListDict Encode.string (\_ -> Encode.object []) - - -freeVarsDecoder : Decode.Decoder FreeVars -freeVarsDecoder = - D.assocListDict compare Decode.string (Decode.succeed ()) - - freeVarsCodec : Codec e FreeVars freeVarsCodec = S.assocListDict compare Serialize.string Serialize.unit -aliasEncoder : Alias -> Encode.Value -aliasEncoder (Alias vars tipe) = - Encode.object - [ ( "vars", Encode.list Encode.string vars ) - , ( "tipe", typeEncoder tipe ) - ] - - -aliasDecoder : Decode.Decoder Alias -aliasDecoder = - Decode.map2 Alias - (Decode.field "vars" (Decode.list Decode.string)) - (Decode.field "tipe" typeDecoder) - - aliasCodec : Codec e Alias aliasCodec = Serialize.customType @@ -392,107 +336,6 @@ aliasCodec = |> Serialize.finishCustomType -typeEncoder : Type -> Encode.Value -typeEncoder type_ = - case type_ of - TLambda a b -> - Encode.object - [ ( "type", Encode.string "TLambda" ) - , ( "a", typeEncoder a ) - , ( "b", typeEncoder b ) - ] - - TVar name -> - Encode.object - [ ( "type", Encode.string "TVar" ) - , ( "name", Encode.string name ) - ] - - TType home name args -> - Encode.object - [ ( "type", Encode.string "TType" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "args", Encode.list typeEncoder args ) - ] - - TRecord fields ext -> - Encode.object - [ ( "type", Encode.string "TRecord" ) - , ( "fields", E.assocListDict Encode.string fieldTypeEncoder fields ) - , ( "ext", E.maybe Encode.string ext ) - ] - - TUnit -> - Encode.object - [ ( "type", Encode.string "TUnit" ) - ] - - TTuple a b maybeC -> - Encode.object - [ ( "type", Encode.string "TTuple" ) - , ( "a", typeEncoder a ) - , ( "b", typeEncoder b ) - , ( "maybeC", E.maybe typeEncoder maybeC ) - ] - - TAlias home name args tipe -> - Encode.object - [ ( "type", Encode.string "TAlias" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "args", Encode.list (E.jsonPair Encode.string typeEncoder) args ) - , ( "tipe", aliasTypeEncoder tipe ) - ] - - -typeDecoder : Decode.Decoder Type -typeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "TLambda" -> - Decode.map2 TLambda - (Decode.field "a" typeDecoder) - (Decode.field "b" typeDecoder) - - "TVar" -> - Decode.map TVar - (Decode.field "name" Decode.string) - - "TType" -> - Decode.map3 TType - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list typeDecoder)) - - "TRecord" -> - Decode.map2 TRecord - (Decode.field "fields" (D.assocListDict compare Decode.string fieldTypeDecoder)) - (Decode.field "ext" (Decode.maybe Decode.string)) - - "TUnit" -> - Decode.succeed TUnit - - "TTuple" -> - Decode.map3 TTuple - (Decode.field "a" typeDecoder) - (Decode.field "b" typeDecoder) - (Decode.field "maybeC" (Decode.maybe typeDecoder)) - - "TAlias" -> - Decode.map4 TAlias - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list (D.jsonPair Decode.string typeDecoder))) - (Decode.field "tipe" aliasTypeDecoder) - - _ -> - Decode.fail ("Unknown Type's type: " ++ type_) - ) - - typeCodec : Codec e Type typeCodec = Serialize.customType @@ -529,22 +372,6 @@ typeCodec = |> Serialize.finishCustomType -fieldTypeEncoder : FieldType -> Encode.Value -fieldTypeEncoder (FieldType index tipe) = - Encode.object - [ ( "type", Encode.string "FieldType" ) - , ( "index", Encode.int index ) - , ( "tipe", typeEncoder tipe ) - ] - - -fieldTypeDecoder : Decode.Decoder FieldType -fieldTypeDecoder = - Decode.map2 FieldType - (Decode.field "index" Decode.int) - (Decode.field "tipe" typeDecoder) - - fieldTypeCodec : Codec e FieldType fieldTypeCodec = Serialize.customType @@ -555,41 +382,6 @@ fieldTypeCodec = |> Serialize.finishCustomType -aliasTypeEncoder : AliasType -> Encode.Value -aliasTypeEncoder aliasType = - case aliasType of - Holey tipe -> - Encode.object - [ ( "type", Encode.string "Holey" ) - , ( "tipe", typeEncoder tipe ) - ] - - Filled tipe -> - Encode.object - [ ( "type", Encode.string "Filled" ) - , ( "tipe", typeEncoder tipe ) - ] - - -aliasTypeDecoder : Decode.Decoder AliasType -aliasTypeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Holey" -> - Decode.map Holey - (Decode.field "tipe" typeDecoder) - - "Filled" -> - Decode.map Filled - (Decode.field "tipe" typeDecoder) - - _ -> - Decode.fail ("Unknown AliasType's type: " ++ type_) - ) - - aliasTypeCodec : Codec e AliasType aliasTypeCodec = Serialize.customType @@ -606,26 +398,6 @@ aliasTypeCodec = |> Serialize.finishCustomType -unionEncoder : Union -> Encode.Value -unionEncoder (Union vars ctors numAlts opts) = - Encode.object - [ ( "type", Encode.string "Union" ) - , ( "vars", Encode.list Encode.string vars ) - , ( "ctors", Encode.list ctorEncoder ctors ) - , ( "numAlts", Encode.int numAlts ) - , ( "opts", ctorOptsEncoder opts ) - ] - - -unionDecoder : Decode.Decoder Union -unionDecoder = - Decode.map4 Union - (Decode.field "vars" (Decode.list Decode.string)) - (Decode.field "ctors" (Decode.list ctorDecoder)) - (Decode.field "numAlts" Decode.int) - (Decode.field "opts" ctorOptsDecoder) - - unionCodec : Codec e Union unionCodec = Serialize.customType @@ -640,26 +412,6 @@ unionCodec = |> Serialize.finishCustomType -ctorEncoder : Ctor -> Encode.Value -ctorEncoder (Ctor ctor index numArgs args) = - Encode.object - [ ( "type", Encode.string "Ctor" ) - , ( "ctor", Encode.string ctor ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "numArgs", Encode.int numArgs ) - , ( "args", Encode.list typeEncoder args ) - ] - - -ctorDecoder : Decode.Decoder Ctor -ctorDecoder = - Decode.map4 Ctor - (Decode.field "ctor" Decode.string) - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "numArgs" Decode.int) - (Decode.field "args" (Decode.list typeDecoder)) - - ctorCodec : Codec e Ctor ctorCodec = Serialize.customType @@ -674,39 +426,6 @@ ctorCodec = |> Serialize.finishCustomType -ctorOptsEncoder : CtorOpts -> Encode.Value -ctorOptsEncoder ctorOpts = - case ctorOpts of - Normal -> - Encode.string "Normal" - - Enum -> - Encode.string "Enum" - - Unbox -> - Encode.string "Unbox" - - -ctorOptsDecoder : Decode.Decoder CtorOpts -ctorOptsDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "Normal" -> - Decode.succeed Normal - - "Enum" -> - Decode.succeed Enum - - "Unbox" -> - Decode.succeed Unbox - - _ -> - Decode.fail ("Unknown CtorOpts: " ++ str) - ) - - ctorOptsCodec : Codec e CtorOpts ctorOptsCodec = Serialize.customType @@ -727,635 +446,295 @@ ctorOptsCodec = |> Serialize.finishCustomType -fieldUpdateEncoder : FieldUpdate -> Encode.Value -fieldUpdateEncoder (FieldUpdate fieldRegion expr) = - Encode.object - [ ( "type", Encode.string "FieldUpdate" ) - , ( "fieldRegion", A.regionEncoder fieldRegion ) - , ( "expr", exprEncoder expr ) - ] - - -fieldUpdateDecoder : Decode.Decoder FieldUpdate -fieldUpdateDecoder = - Decode.map2 FieldUpdate - (Decode.field "fieldRegion" A.regionDecoder) - (Decode.field "expr" exprDecoder) - - -exprEncoder : Expr -> Encode.Value -exprEncoder = - A.locatedEncoder expr_Encoder - - -exprDecoder : Decode.Decoder Expr -exprDecoder = - A.locatedDecoder expr_Decoder - - -expr_Encoder : Expr_ -> Encode.Value -expr_Encoder expr_ = - case expr_ of - VarLocal name -> - Encode.object - [ ( "type", Encode.string "VarLocal" ) - , ( "name", Encode.string name ) - ] - - VarTopLevel home name -> - Encode.object - [ ( "type", Encode.string "VarTopLevel" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - ] - - VarKernel home name -> - Encode.object - [ ( "type", Encode.string "VarKernel" ) - , ( "home", Encode.string home ) - , ( "name", Encode.string name ) - ] - - VarForeign home name annotation -> - Encode.object - [ ( "type", Encode.string "VarForeign" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "annotation", annotationEncoder annotation ) - ] - - VarCtor opts home name index annotation -> - Encode.object - [ ( "type", Encode.string "VarCtor" ) - , ( "opts", ctorOptsEncoder opts ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "annotation", annotationEncoder annotation ) - ] - - VarDebug home name annotation -> - Encode.object - [ ( "type", Encode.string "VarDebug" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "annotation", annotationEncoder annotation ) - ] - - VarOperator op home name annotation -> - Encode.object - [ ( "type", Encode.string "VarOperator" ) - , ( "op", Encode.string op ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "annotation", annotationEncoder annotation ) - ] - - Chr chr -> - Encode.object - [ ( "type", Encode.string "Chr" ) - , ( "chr", Encode.string chr ) - ] - - Str str -> - Encode.object - [ ( "type", Encode.string "Str" ) - , ( "str", Encode.string str ) - ] - - Int int -> - Encode.object - [ ( "type", Encode.string "Int" ) - , ( "int", Encode.int int ) - ] - - Float float -> - Encode.object - [ ( "type", Encode.string "Float" ) - , ( "float", Encode.float float ) - ] - - List entries -> - Encode.object - [ ( "type", Encode.string "List" ) - , ( "entries", Encode.list exprEncoder entries ) - ] - - Negate expr -> - Encode.object - [ ( "type", Encode.string "Negate" ) - , ( "expr", exprEncoder expr ) - ] - - Binop op home name annotation left right -> - Encode.object - [ ( "type", Encode.string "Binop" ) - , ( "op", Encode.string op ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "annotation", annotationEncoder annotation ) - , ( "left", exprEncoder left ) - , ( "right", exprEncoder right ) - ] - - Lambda args body -> - Encode.object - [ ( "type", Encode.string "Lambda" ) - , ( "args", Encode.list patternEncoder args ) - , ( "body", exprEncoder body ) - ] - - Call func args -> - Encode.object - [ ( "type", Encode.string "Call" ) - , ( "func", exprEncoder func ) - , ( "args", Encode.list exprEncoder args ) - ] - - If branches finally -> - Encode.object - [ ( "type", Encode.string "If" ) - , ( "branches", Encode.list (E.jsonPair exprEncoder exprEncoder) branches ) - , ( "finally", exprEncoder finally ) - ] - - Let def body -> - Encode.object - [ ( "type", Encode.string "Let" ) - , ( "def", defEncoder def ) - , ( "body", exprEncoder body ) - ] - - LetRec defs body -> - Encode.object - [ ( "type", Encode.string "LetRec" ) - , ( "defs", Encode.list defEncoder defs ) - , ( "body", exprEncoder body ) - ] - - LetDestruct pattern expr body -> - Encode.object - [ ( "type", Encode.string "LetDestruct" ) - , ( "pattern", patternEncoder pattern ) - , ( "expr", exprEncoder expr ) - , ( "body", exprEncoder body ) - ] - - Case expr branches -> - Encode.object - [ ( "type", Encode.string "Case" ) - , ( "expr", exprEncoder expr ) - , ( "branches", Encode.list caseBranchEncoder branches ) - ] - - Accessor field -> - Encode.object - [ ( "type", Encode.string "Accessor" ) - , ( "field", Encode.string field ) - ] - - Access record field -> - Encode.object - [ ( "type", Encode.string "Access" ) - , ( "record", exprEncoder record ) - , ( "field", A.locatedEncoder Encode.string field ) - ] - - Update name record updates -> - Encode.object - [ ( "type", Encode.string "Update" ) - , ( "name", Encode.string name ) - , ( "record", exprEncoder record ) - , ( "updates", E.assocListDict Encode.string fieldUpdateEncoder updates ) - ] - - Record fields -> - Encode.object - [ ( "type", Encode.string "Record" ) - , ( "fields", E.assocListDict Encode.string exprEncoder fields ) - ] - - Unit -> - Encode.object - [ ( "type", Encode.string "Unit" ) - ] - - Tuple a b maybeC -> - Encode.object - [ ( "type", Encode.string "Tuple" ) - , ( "a", exprEncoder a ) - , ( "b", exprEncoder b ) - , ( "maybeC", E.maybe exprEncoder maybeC ) - ] - - Shader src types -> - Encode.object - [ ( "type", Encode.string "Shader" ) - , ( "src", Shader.sourceEncoder src ) - , ( "types", Shader.typesEncoder types ) - ] - - -expr_Decoder : Decode.Decoder Expr_ -expr_Decoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "VarLocal" -> - Decode.map VarLocal (Decode.field "name" Decode.string) - - "VarTopLevel" -> - Decode.map2 VarTopLevel - (Decode.field "moduleName" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - - "VarKernel" -> - Decode.map2 VarKernel - (Decode.field "home" Decode.string) - (Decode.field "name" Decode.string) - - "VarForeign" -> - Decode.map3 VarForeign - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "annotation" annotationDecoder) - - "VarCtor" -> - Decode.map5 VarCtor - (Decode.field "opts" ctorOptsDecoder) - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "annotation" annotationDecoder) - - "VarDebug" -> - Decode.map3 VarDebug - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "annotation" annotationDecoder) - - "VarOperator" -> - Decode.map4 VarOperator - (Decode.field "op" Decode.string) - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "annotation" annotationDecoder) - - "Chr" -> - Decode.map Chr (Decode.field "chr" Decode.string) - - "Str" -> - Decode.map Str (Decode.field "str" Decode.string) - - "Int" -> - Decode.map Int (Decode.field "int" Decode.int) - - "Float" -> - Decode.map Float (Decode.field "float" Decode.float) - - "List" -> - Decode.map List (Decode.field "entries" (Decode.list exprDecoder)) - - "Negate" -> - Decode.map Negate (Decode.field "expr" exprDecoder) - - "Binop" -> - Decode.map6 Binop - (Decode.field "op" Decode.string) - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "annotation" annotationDecoder) - (Decode.field "left" exprDecoder) - (Decode.field "right" exprDecoder) - - "Lambda" -> - Decode.map2 Lambda - (Decode.field "args" (Decode.list patternDecoder)) - (Decode.field "body" exprDecoder) - - "Call" -> - Decode.map2 Call - (Decode.field "func" exprDecoder) - (Decode.field "args" (Decode.list exprDecoder)) - - "If" -> - Decode.map2 If - (Decode.field "branches" (Decode.list (D.jsonPair exprDecoder exprDecoder))) - (Decode.field "finally" exprDecoder) - - "Let" -> - Decode.map2 Let - (Decode.field "def" defDecoder) - (Decode.field "body" exprDecoder) - - "LetRec" -> - Decode.map2 LetRec - (Decode.field "defs" (Decode.list defDecoder)) - (Decode.field "body" exprDecoder) - - "LetDestruct" -> - Decode.map3 LetDestruct - (Decode.field "pattern" patternDecoder) - (Decode.field "expr" exprDecoder) - (Decode.field "body" exprDecoder) - - "Case" -> - Decode.map2 Case - (Decode.field "expr" exprDecoder) - (Decode.field "branches" (Decode.list caseBranchDecoder)) - - "Accessor" -> - Decode.map Accessor (Decode.field "field" Decode.string) - - "Access" -> - Decode.map2 Access - (Decode.field "record" exprDecoder) - (Decode.field "field" (A.locatedDecoder Decode.string)) - - "Update" -> - Decode.map3 Update - (Decode.field "name" Decode.string) - (Decode.field "record" exprDecoder) - (Decode.field "updates" (D.assocListDict compare Decode.string fieldUpdateDecoder)) - - "Record" -> - Decode.map Record - (Decode.field "fields" (D.assocListDict compare Decode.string exprDecoder)) - - "Unit" -> - Decode.succeed Unit - - "Tuple" -> - Decode.map3 Tuple - (Decode.field "a" exprDecoder) - (Decode.field "b" exprDecoder) - (Decode.field "maybeC" (Decode.maybe exprDecoder)) - - "Shader" -> - Decode.map2 Shader - (Decode.field "src" Shader.sourceDecoder) - (Decode.field "types" Shader.typesDecoder) - - _ -> - Decode.fail ("Unknown Expr_'s type: " ++ type_) - ) +fieldUpdateCodec : Codec e FieldUpdate +fieldUpdateCodec = + Serialize.customType + (\fieldUpdateCodecEncoder (FieldUpdate fieldRegion expr) -> + fieldUpdateCodecEncoder fieldRegion expr + ) + |> Serialize.variant2 FieldUpdate A.regionCodec exprCodec + |> Serialize.finishCustomType + + +exprCodec : Codec e Expr +exprCodec = + A.locatedCodec (Serialize.lazy (\() -> expr_Codec)) + + +expr_Codec : Codec e Expr_ +expr_Codec = + Serialize.customType + (\varLocalEncoder varTopLevelEncoder varKernelEncoder varForeignEncoder varCtorEncoder varDebugEncoder varOperatorEncoder chrEncoder strEncoder intEncoder floatEncoder listEncoder negateEncoder binopEncoder lambdaEncoder callEncoder ifEncoder letEncoder letRecEncoder letDestructEncoder caseEncoder accessorEncoder accessEncoder updateEncoder recordEncoder unitEncoder tupleEncoder shaderEncoder value -> + case value of + VarLocal name -> + varLocalEncoder name + + VarTopLevel home name -> + varTopLevelEncoder home name + + VarKernel home name -> + varKernelEncoder home name + + VarForeign home name annotation -> + varForeignEncoder home name annotation + + VarCtor opts home name index annotation -> + varCtorEncoder opts home name index annotation + + VarDebug home name annotation -> + varDebugEncoder home name annotation + + VarOperator op home name annotation -> + varOperatorEncoder op home name annotation + + Chr chr -> + chrEncoder chr + Str str -> + strEncoder str -patternEncoder : Pattern -> Encode.Value -patternEncoder = - A.locatedEncoder pattern_Encoder - - -patternDecoder : Decode.Decoder Pattern -patternDecoder = - A.locatedDecoder pattern_Decoder - - -pattern_Encoder : Pattern_ -> Encode.Value -pattern_Encoder pattern_ = - case pattern_ of - PAnything -> - Encode.object - [ ( "type", Encode.string "PAnything" ) - ] - - PVar name -> - Encode.object - [ ( "type", Encode.string "PVar" ) - , ( "name", Encode.string name ) - ] - - PRecord names -> - Encode.object - [ ( "type", Encode.string "PRecord" ) - , ( "names", Encode.list Encode.string names ) - ] - - PAlias pattern name -> - Encode.object - [ ( "type", Encode.string "PAlias" ) - , ( "pattern", patternEncoder pattern ) - , ( "name", Encode.string name ) - ] - - PUnit -> - Encode.object - [ ( "type", Encode.string "PUnit" ) - ] - - PTuple pattern1 pattern2 maybePattern3 -> - Encode.object - [ ( "type", Encode.string "PTuple" ) - , ( "pattern1", patternEncoder pattern1 ) - , ( "pattern2", patternEncoder pattern2 ) - , ( "pattern3", E.maybe patternEncoder maybePattern3 ) - ] - - PList patterns -> - Encode.object - [ ( "type", Encode.string "PList" ) - , ( "patterns", Encode.list patternEncoder patterns ) - ] - - PCons pattern1 pattern2 -> - Encode.object - [ ( "type", Encode.string "PCons" ) - , ( "pattern1", patternEncoder pattern1 ) - , ( "pattern2", patternEncoder pattern2 ) - ] - - PBool union bool -> - Encode.object - [ ( "type", Encode.string "PBool" ) - , ( "union", unionEncoder union ) - , ( "bool", Encode.bool bool ) - ] - - PChr chr -> - Encode.object - [ ( "type", Encode.string "PChr" ) - , ( "chr", Encode.string chr ) - ] - - PStr str -> - Encode.object - [ ( "type", Encode.string "PStr" ) - , ( "str", Encode.string str ) - ] - - PInt int -> - Encode.object - [ ( "type", Encode.string "PInt" ) - , ( "int", Encode.int int ) - ] - - PCtor { home, type_, union, name, index, args } -> - Encode.object - [ ( "type", Encode.string "PCtor" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "type_", Encode.string type_ ) - , ( "union", unionEncoder union ) - , ( "name", Encode.string name ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "args", Encode.list patternCtorArgEncoder args ) - ] - - -pattern_Decoder : Decode.Decoder Pattern_ -pattern_Decoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\patternType -> - case patternType of - "PAnything" -> - Decode.succeed PAnything - - "PVar" -> - Decode.map PVar - (Decode.field "name" Decode.string) - - "PRecord" -> - Decode.map PRecord - (Decode.field "names" (Decode.list Decode.string)) - - "PAlias" -> - Decode.map2 PAlias - (Decode.field "pattern" patternDecoder) - (Decode.field "name" Decode.string) - - "PUnit" -> - Decode.succeed PUnit - - "PTuple" -> - Decode.map3 PTuple - (Decode.field "pattern1" patternDecoder) - (Decode.field "pattern2" patternDecoder) - (Decode.field "pattern3" (Decode.maybe patternDecoder)) - - "PList" -> - Decode.map PList - (Decode.field "patterns" (Decode.list patternDecoder)) - - "PCons" -> - Decode.map2 PCons - (Decode.field "pattern1" patternDecoder) - (Decode.field "pattern2" patternDecoder) - - "PBool" -> - Decode.map2 PBool - (Decode.field "union" unionDecoder) - (Decode.field "bool" Decode.bool) - - "PChr" -> - Decode.map PChr (Decode.field "chr" Decode.string) - - "PStr" -> - Decode.map PStr (Decode.field "str" Decode.string) - - "PInt" -> - Decode.map PInt (Decode.field "int" Decode.int) - - "PCtor" -> - Decode.map6 - (\home type_ union name index args -> - PCtor - { home = home - , type_ = type_ - , union = union - , name = name - , index = index - , args = args - } - ) - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "type_" Decode.string) - (Decode.field "union" unionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "args" (Decode.list patternCtorArgDecoder)) - - _ -> - Decode.fail ("Unknown Pattern_'s type: " ++ patternType) + Int int -> + intEncoder int + + Float float -> + floatEncoder float + + List entries -> + listEncoder entries + + Negate expr -> + negateEncoder expr + + Binop op home name annotation left right -> + binopEncoder op home name annotation left right + + Lambda args body -> + lambdaEncoder args body + + Call func args -> + callEncoder func args + + If branches finally -> + ifEncoder branches finally + + Let def body -> + letEncoder def body + + LetRec defs body -> + letRecEncoder defs body + + LetDestruct pattern expr body -> + letDestructEncoder pattern expr body + + Case expr branches -> + caseEncoder expr branches + + Accessor field -> + accessorEncoder field + + Access record field -> + accessEncoder record field + + Update name record updates -> + updateEncoder name record updates + + Record fields -> + recordEncoder fields + + Unit -> + unitEncoder + + Tuple a b maybeC -> + tupleEncoder a b maybeC + + Shader src types -> + shaderEncoder src types + ) + |> Serialize.variant1 VarLocal Serialize.string + |> Serialize.variant2 VarTopLevel ModuleName.canonicalCodec Serialize.string + |> Serialize.variant2 VarKernel Serialize.string Serialize.string + |> Serialize.variant3 VarForeign ModuleName.canonicalCodec Serialize.string annotationCodec + |> Serialize.variant5 + VarCtor + ctorOptsCodec + ModuleName.canonicalCodec + Serialize.string + Index.zeroBasedCodec + annotationCodec + |> Serialize.variant3 VarDebug ModuleName.canonicalCodec Serialize.string annotationCodec + |> Serialize.variant4 VarOperator Serialize.string ModuleName.canonicalCodec Serialize.string annotationCodec + |> Serialize.variant1 Chr Serialize.string + |> Serialize.variant1 Str Serialize.string + |> Serialize.variant1 Int Serialize.int + |> Serialize.variant1 Float Serialize.float + |> Serialize.variant1 List (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + |> Serialize.variant1 Negate (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant6 + Binop + Serialize.string + ModuleName.canonicalCodec + Serialize.string + annotationCodec + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Lambda + (Serialize.list (A.locatedCodec pattern_Codec)) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Call + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + |> Serialize.variant2 + If + (Serialize.list + (Serialize.tuple + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + ) ) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 Let defCodec exprCodec + |> Serialize.variant2 LetRec (Serialize.list defCodec) (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant3 + LetDestruct + (A.locatedCodec pattern_Codec) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Case + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (Serialize.list caseBranchCodec) + |> Serialize.variant1 Accessor Serialize.string + |> Serialize.variant2 + Access + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec Serialize.string) + |> Serialize.variant3 + 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)))) + |> Serialize.variant0 Unit + |> Serialize.variant3 + Tuple + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (Serialize.maybe (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + |> Serialize.variant2 Shader Shader.sourceCodec Shader.typesCodec + |> Serialize.finishCustomType + + +patternCodec : Codec e Pattern +patternCodec = + A.locatedCodec (Serialize.lazy (\() -> pattern_Codec)) -patternCtorArgEncoder : PatternCtorArg -> Encode.Value -patternCtorArgEncoder (PatternCtorArg index srcType pattern) = - Encode.object - [ ( "type", Encode.string "PatternCtorArg" ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "srcType", typeEncoder srcType ) - , ( "pattern", patternEncoder pattern ) - ] - - -patternCtorArgDecoder : Decode.Decoder PatternCtorArg -patternCtorArgDecoder = - Decode.map3 PatternCtorArg - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "srcType" typeDecoder) - (Decode.field "pattern" patternDecoder) - - -defEncoder : Def -> Encode.Value -defEncoder def = - case def of - Def name args expr -> - Encode.object - [ ( "type", Encode.string "Def" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "args", Encode.list patternEncoder args ) - , ( "expr", exprEncoder expr ) - ] - - TypedDef name freeVars typedArgs expr srcResultType -> - Encode.object - [ ( "type", Encode.string "TypedDef" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "freeVars", freeVarsEncoder freeVars ) - , ( "typedArgs", Encode.list (E.jsonPair patternEncoder typeEncoder) typedArgs ) - , ( "expr", exprEncoder expr ) - , ( "srcResultType", typeEncoder srcResultType ) - ] - - -defDecoder : Decode.Decoder Def -defDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Def" -> - Decode.map3 Def - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "args" (Decode.list patternDecoder)) - (Decode.field "expr" exprDecoder) - - "TypedDef" -> - Decode.map5 TypedDef - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "freeVars" freeVarsDecoder) - (Decode.field "typedArgs" (Decode.list (D.jsonPair patternDecoder typeDecoder))) - (Decode.field "expr" exprDecoder) - (Decode.field "srcResultType" typeDecoder) - - _ -> - Decode.fail ("Unknown Def's type: " ++ type_) +pattern_Codec : Codec e Pattern_ +pattern_Codec = + Serialize.customType + (\pAnythingEncoder pVarEncoder pRecordEncoder pAliasEncoder pUnitEncoder pTupleEncoder pListEncoder pConsEncoder pBoolEncoder pChrEncoder pStrEncoder pIntEncoder pCtorEncoder value -> + case value of + PAnything -> + pAnythingEncoder + + PVar name -> + pVarEncoder name + + PRecord names -> + pRecordEncoder names + + PAlias pattern name -> + pAliasEncoder pattern name + + PUnit -> + pUnitEncoder + + PTuple pattern1 pattern2 maybePattern3 -> + pTupleEncoder pattern1 pattern2 maybePattern3 + + PList patterns -> + pListEncoder patterns + + PCons pattern1 pattern2 -> + pConsEncoder pattern1 pattern2 + + PBool union bool -> + pBoolEncoder union bool + + PChr chr -> + pChrEncoder chr + + PStr str -> + pStrEncoder str + + PInt int -> + pIntEncoder int + + PCtor ctor -> + pCtorEncoder ctor + ) + |> Serialize.variant0 PAnything + |> Serialize.variant1 PVar Serialize.string + |> Serialize.variant1 PRecord (Serialize.list Serialize.string) + |> Serialize.variant2 PAlias patternCodec Serialize.string + |> Serialize.variant0 PUnit + |> Serialize.variant3 PTuple patternCodec patternCodec (Serialize.maybe patternCodec) + |> Serialize.variant1 PList (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec)))) + |> Serialize.variant2 PCons patternCodec patternCodec + |> Serialize.variant2 PBool unionCodec Serialize.bool + |> Serialize.variant1 PChr Serialize.string + |> Serialize.variant1 PStr Serialize.string + |> Serialize.variant1 PInt Serialize.int + |> Serialize.variant1 + PCtor + (Serialize.record + (\home type_ union name index args -> + { home = home, type_ = type_, union = union, name = name, index = index, args = args } + ) + |> Serialize.field .home ModuleName.canonicalCodec + |> Serialize.field .type_ Serialize.string + |> Serialize.field .union unionCodec + |> Serialize.field .name Serialize.string + |> Serialize.field .index Index.zeroBasedCodec + |> Serialize.field .args (Serialize.list patternCtorArgCodec) + |> Serialize.finishRecord ) + |> Serialize.finishCustomType + + +patternCtorArgCodec : Codec e PatternCtorArg +patternCtorArgCodec = + Serialize.customType + (\patternCtorArgCodecEncoder (PatternCtorArg index srcType pattern) -> + patternCtorArgCodecEncoder index srcType pattern + ) + |> Serialize.variant3 PatternCtorArg Index.zeroBasedCodec typeCodec patternCodec + |> Serialize.finishCustomType -caseBranchEncoder : CaseBranch -> Encode.Value -caseBranchEncoder (CaseBranch pattern expr) = - Encode.object - [ ( "type", Encode.string "CaseBranch" ) - , ( "pattern", patternEncoder pattern ) - , ( "expr", exprEncoder expr ) - ] +defCodec : Codec e Def +defCodec = + Serialize.customType + (\defCodecEncoder typedDefEncoder def -> + case def of + Def name args expr -> + defCodecEncoder name args expr + + TypedDef name freeVars typedArgs expr srcResultType -> + typedDefEncoder name freeVars typedArgs expr srcResultType + ) + |> Serialize.variant3 Def (A.locatedCodec Serialize.string) (Serialize.list patternCodec) exprCodec + |> Serialize.variant5 TypedDef (A.locatedCodec Serialize.string) freeVarsCodec (Serialize.list (Serialize.tuple patternCodec typeCodec)) exprCodec typeCodec + |> Serialize.finishCustomType -caseBranchDecoder : Decode.Decoder CaseBranch -caseBranchDecoder = - Decode.map2 CaseBranch - (Decode.field "pattern" patternDecoder) - (Decode.field "expr" exprDecoder) +caseBranchCodec : Codec e CaseBranch +caseBranchCodec = + Serialize.customType + (\caseBranchCodecEncoder (CaseBranch pattern expr) -> + caseBranchCodecEncoder pattern expr + ) + |> Serialize.variant2 CaseBranch patternCodec exprCodec + |> Serialize.finishCustomType diff --git a/src/Compiler/AST/Optimized.elm b/src/Compiler/AST/Optimized.elm index a102ea392..978a60096 100644 --- a/src/Compiler/AST/Optimized.elm +++ b/src/Compiler/AST/Optimized.elm @@ -17,11 +17,7 @@ module Compiler.AST.Optimized exposing , compareGlobal , empty , globalGraphCodec - , globalGraphDecoder - , globalGraphEncoder , localGraphCodec - , localGraphDecoder - , localGraphEncoder , toKernelGlobal ) @@ -32,15 +28,11 @@ import Compiler.Data.Name as Name exposing (Name) import Compiler.Elm.Kernel as K import Compiler.Elm.ModuleName as ModuleName import Compiler.Elm.Package as Pkg -import Compiler.Json.Decode as D -import Compiler.Json.Encode as E import Compiler.Optimize.DecisionTree as DT import Compiler.Reporting.Annotation as A import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO as IO @@ -248,22 +240,6 @@ toKernelGlobal shortName = -- ENCODERS and DECODERS -globalGraphEncoder : GlobalGraph -> Encode.Value -globalGraphEncoder (GlobalGraph nodes fields) = - Encode.object - [ ( "type", Encode.string "GlobalGraph" ) - , ( "nodes", E.assocListDict globalEncoder nodeEncoder nodes ) - , ( "fields", E.assocListDict Encode.string Encode.int fields ) - ] - - -globalGraphDecoder : Decode.Decoder GlobalGraph -globalGraphDecoder = - Decode.map2 GlobalGraph - (Decode.field "nodes" (D.assocListDict compareGlobal globalDecoder nodeDecoder)) - (Decode.field "fields" (D.assocListDict compare Decode.string Decode.int)) - - globalGraphCodec : Codec e GlobalGraph globalGraphCodec = Serialize.customType @@ -274,24 +250,6 @@ globalGraphCodec = |> Serialize.finishCustomType -localGraphEncoder : LocalGraph -> Encode.Value -localGraphEncoder (LocalGraph main nodes fields) = - Encode.object - [ ( "type", Encode.string "LocalGraph" ) - , ( "main", E.maybe mainEncoder main ) - , ( "nodes", E.assocListDict globalEncoder nodeEncoder nodes ) - , ( "fields", E.assocListDict Encode.string Encode.int fields ) - ] - - -localGraphDecoder : Decode.Decoder LocalGraph -localGraphDecoder = - Decode.map3 LocalGraph - (Decode.field "main" (Decode.maybe mainDecoder)) - (Decode.field "nodes" (D.assocListDict compareGlobal globalDecoder nodeDecoder)) - (Decode.field "fields" (D.assocListDict compare Decode.string Decode.int)) - - localGraphCodec : Codec e LocalGraph localGraphCodec = Serialize.customType @@ -305,41 +263,6 @@ localGraphCodec = |> Serialize.finishCustomType -mainEncoder : Main -> Encode.Value -mainEncoder main_ = - case main_ of - Static -> - Encode.object - [ ( "type", Encode.string "Static" ) - ] - - Dynamic msgType decoder -> - Encode.object - [ ( "type", Encode.string "Dynamic" ) - , ( "msgType", Can.typeEncoder msgType ) - , ( "decoder", exprEncoder decoder ) - ] - - -mainDecoder : Decode.Decoder Main -mainDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Static" -> - Decode.succeed Static - - "Dynamic" -> - Decode.map2 Dynamic - (Decode.field "msgType" Can.typeDecoder) - (Decode.field "decoder" exprDecoder) - - _ -> - Decode.fail ("Unknown Main's type: " ++ type_) - ) - - mainCodec : Codec c Main mainCodec = Serialize.customType @@ -356,22 +279,6 @@ mainCodec = |> Serialize.finishCustomType -globalEncoder : Global -> Encode.Value -globalEncoder (Global home name) = - Encode.object - [ ( "type", Encode.string "Global" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - ] - - -globalDecoder : Decode.Decoder Global -globalDecoder = - Decode.map2 Global - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - - globalCodec : Codec e Global globalCodec = Serialize.customType @@ -382,147 +289,6 @@ globalCodec = |> Serialize.finishCustomType -nodeEncoder : Node -> Encode.Value -nodeEncoder node = - case node of - Define expr deps -> - Encode.object - [ ( "type", Encode.string "Define" ) - , ( "expr", exprEncoder expr ) - , ( "deps", E.everySet globalEncoder deps ) - ] - - DefineTailFunc argNames body deps -> - Encode.object - [ ( "type", Encode.string "DefineTailFunc" ) - , ( "argNames", Encode.list Encode.string argNames ) - , ( "body", exprEncoder body ) - , ( "deps", E.everySet globalEncoder deps ) - ] - - Ctor index arity -> - Encode.object - [ ( "type", Encode.string "Ctor" ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "arity", Encode.int arity ) - ] - - Enum index -> - Encode.object - [ ( "type", Encode.string "Enum" ) - , ( "index", Index.zeroBasedEncoder index ) - ] - - Box -> - Encode.object - [ ( "type", Encode.string "Box" ) - ] - - Link linkedGlobal -> - Encode.object - [ ( "type", Encode.string "Link" ) - , ( "linkedGlobal", globalEncoder linkedGlobal ) - ] - - Cycle names values functions deps -> - Encode.object - [ ( "type", Encode.string "Cycle" ) - , ( "names", Encode.list Encode.string names ) - , ( "values", Encode.list (E.jsonPair Encode.string exprEncoder) values ) - , ( "functions", Encode.list defEncoder functions ) - , ( "deps", E.everySet globalEncoder deps ) - ] - - Manager effectsType -> - Encode.object - [ ( "type", Encode.string "Manager" ) - , ( "effectsType", effectsTypeEncoder effectsType ) - ] - - Kernel chunks deps -> - Encode.object - [ ( "type", Encode.string "Kernel" ) - , ( "chunks", Encode.list K.chunkEncoder chunks ) - , ( "deps", E.everySet globalEncoder deps ) - ] - - PortIncoming decoder deps -> - Encode.object - [ ( "type", Encode.string "PortIncoming" ) - , ( "decoder", exprEncoder decoder ) - , ( "deps", E.everySet globalEncoder deps ) - ] - - PortOutgoing encoder deps -> - Encode.object - [ ( "type", Encode.string "PortOutgoing" ) - , ( "encoder", exprEncoder encoder ) - , ( "deps", E.everySet globalEncoder deps ) - ] - - -nodeDecoder : Decode.Decoder Node -nodeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Define" -> - Decode.map2 Define - (Decode.field "expr" exprDecoder) - (Decode.field "deps" (D.everySet compareGlobal globalDecoder)) - - "DefineTailFunc" -> - Decode.map3 DefineTailFunc - (Decode.field "argNames" (Decode.list Decode.string)) - (Decode.field "body" exprDecoder) - (Decode.field "deps" (D.everySet compareGlobal globalDecoder)) - - "Ctor" -> - Decode.map2 Ctor - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "arity" Decode.int) - - "Enum" -> - Decode.map Enum - (Decode.field "index" Index.zeroBasedDecoder) - - "Box" -> - Decode.succeed Box - - "Link" -> - Decode.map Link (Decode.field "linkedGlobal" globalDecoder) - - "Cycle" -> - Decode.map4 Cycle - (Decode.field "names" (Decode.list Decode.string)) - (Decode.field "values" (Decode.list (D.jsonPair Decode.string exprDecoder))) - (Decode.field "functions" (Decode.list defDecoder)) - (Decode.field "deps" (D.everySet compareGlobal globalDecoder)) - - "Manager" -> - Decode.map Manager (Decode.field "effectsType" effectsTypeDecoder) - - "Kernel" -> - Decode.map2 Kernel - (Decode.field "chunks" (Decode.list K.chunkDecoder)) - (Decode.field "deps" (D.everySet compareGlobal globalDecoder)) - - "PortIncoming" -> - Decode.map2 PortIncoming - (Decode.field "decoder" exprDecoder) - (Decode.field "deps" (D.everySet compareGlobal globalDecoder)) - - "PortOutgoing" -> - Decode.map2 PortOutgoing - (Decode.field "encoder" exprDecoder) - (Decode.field "deps" (D.everySet compareGlobal globalDecoder)) - - _ -> - Decode.fail ("Unknown Node's type: " ++ type_) - ) - - nodeCodec : Codec e Node nodeCodec = Serialize.customType @@ -575,320 +341,6 @@ nodeCodec = |> Serialize.finishCustomType -exprEncoder : Expr -> Encode.Value -exprEncoder expr = - case expr of - Bool value -> - Encode.object - [ ( "type", Encode.string "Bool" ) - , ( "value", Encode.bool value ) - ] - - Chr value -> - Encode.object - [ ( "type", Encode.string "Chr" ) - , ( "value", Encode.string value ) - ] - - Str value -> - Encode.object - [ ( "type", Encode.string "Str" ) - , ( "value", Encode.string value ) - ] - - Int value -> - Encode.object - [ ( "type", Encode.string "Int" ) - , ( "value", Encode.int value ) - ] - - Float value -> - Encode.object - [ ( "type", Encode.string "Float" ) - , ( "value", Encode.float value ) - ] - - VarLocal value -> - Encode.object - [ ( "type", Encode.string "VarLocal" ) - , ( "value", Encode.string value ) - ] - - VarGlobal value -> - Encode.object - [ ( "type", Encode.string "VarGlobal" ) - , ( "value", globalEncoder value ) - ] - - VarEnum global index -> - Encode.object - [ ( "type", Encode.string "VarEnum" ) - , ( "global", globalEncoder global ) - , ( "index", Index.zeroBasedEncoder index ) - ] - - VarBox value -> - Encode.object - [ ( "type", Encode.string "VarBox" ) - , ( "value", globalEncoder value ) - ] - - VarCycle home name -> - Encode.object - [ ( "type", Encode.string "VarCycle" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - ] - - VarDebug name home region unhandledValueName -> - Encode.object - [ ( "type", Encode.string "VarDebug" ) - , ( "name", Encode.string name ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "region", A.regionEncoder region ) - , ( "unhandledValueName", E.maybe Encode.string unhandledValueName ) - ] - - VarKernel home name -> - Encode.object - [ ( "type", Encode.string "VarKernel" ) - , ( "home", Encode.string home ) - , ( "name", Encode.string name ) - ] - - List value -> - Encode.object - [ ( "type", Encode.string "List" ) - , ( "value", Encode.list exprEncoder value ) - ] - - Function args body -> - Encode.object - [ ( "type", Encode.string "Function" ) - , ( "args", Encode.list Encode.string args ) - , ( "body", exprEncoder body ) - ] - - Call func args -> - Encode.object - [ ( "type", Encode.string "Call" ) - , ( "func", exprEncoder func ) - , ( "args", Encode.list exprEncoder args ) - ] - - TailCall name args -> - Encode.object - [ ( "type", Encode.string "TailCall" ) - , ( "name", Encode.string name ) - , ( "args", Encode.list (E.jsonPair Encode.string exprEncoder) args ) - ] - - If branches final -> - Encode.object - [ ( "type", Encode.string "If" ) - , ( "branches", Encode.list (E.jsonPair exprEncoder exprEncoder) branches ) - , ( "final", exprEncoder final ) - ] - - Let def body -> - Encode.object - [ ( "type", Encode.string "Let" ) - , ( "def", defEncoder def ) - , ( "body", exprEncoder body ) - ] - - Destruct destructor body -> - Encode.object - [ ( "type", Encode.string "Destruct" ) - , ( "destructor", destructorEncoder destructor ) - , ( "body", exprEncoder body ) - ] - - Case label root decider jumps -> - Encode.object - [ ( "type", Encode.string "Case" ) - , ( "label", Encode.string label ) - , ( "root", Encode.string root ) - , ( "decider", deciderEncoder choiceEncoder decider ) - , ( "jumps", Encode.list (E.jsonPair Encode.int exprEncoder) jumps ) - ] - - Accessor field -> - Encode.object - [ ( "type", Encode.string "Accessor" ) - , ( "field", Encode.string field ) - ] - - Access record field -> - Encode.object - [ ( "type", Encode.string "Access" ) - , ( "record", exprEncoder record ) - , ( "field", Encode.string field ) - ] - - Update record fields -> - Encode.object - [ ( "type", Encode.string "Update" ) - , ( "record", exprEncoder record ) - , ( "fields", E.assocListDict Encode.string exprEncoder fields ) - ] - - Record value -> - Encode.object - [ ( "type", Encode.string "Record" ) - , ( "value", E.assocListDict Encode.string exprEncoder value ) - ] - - Unit -> - Encode.object - [ ( "type", Encode.string "Unit" ) - ] - - Tuple a b maybeC -> - Encode.object - [ ( "type", Encode.string "Tuple" ) - , ( "a", exprEncoder a ) - , ( "b", exprEncoder b ) - , ( "maybeC", E.maybe exprEncoder maybeC ) - ] - - Shader src attributes uniforms -> - Encode.object - [ ( "type", Encode.string "Shader" ) - , ( "src", Shader.sourceEncoder src ) - , ( "attributes", E.everySet Encode.string attributes ) - , ( "uniforms", E.everySet Encode.string uniforms ) - ] - - -exprDecoder : Decode.Decoder Expr -exprDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Bool" -> - Decode.map Bool (Decode.field "value" Decode.bool) - - "Chr" -> - Decode.map Chr (Decode.field "value" Decode.string) - - "Str" -> - Decode.map Str (Decode.field "value" Decode.string) - - "Int" -> - Decode.map Int (Decode.field "value" Decode.int) - - "Float" -> - Decode.map Float (Decode.field "value" Decode.float) - - "VarLocal" -> - Decode.map VarLocal (Decode.field "value" Decode.string) - - "VarGlobal" -> - Decode.map VarGlobal (Decode.field "value" globalDecoder) - - "VarEnum" -> - Decode.map2 VarEnum - (Decode.field "global" globalDecoder) - (Decode.field "index" Index.zeroBasedDecoder) - - "VarBox" -> - Decode.map VarBox (Decode.field "value" globalDecoder) - - "VarCycle" -> - Decode.map2 VarCycle - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - - "VarDebug" -> - Decode.map4 VarDebug - (Decode.field "name" Decode.string) - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "region" A.regionDecoder) - (Decode.field "unhandledValueName" (Decode.maybe Decode.string)) - - "VarKernel" -> - Decode.map2 VarKernel - (Decode.field "home" Decode.string) - (Decode.field "name" Decode.string) - - "List" -> - Decode.map List (Decode.field "value" (Decode.list exprDecoder)) - - "Function" -> - Decode.map2 Function - (Decode.field "args" (Decode.list Decode.string)) - (Decode.field "body" exprDecoder) - - "Call" -> - Decode.map2 Call - (Decode.field "func" exprDecoder) - (Decode.field "args" (Decode.list exprDecoder)) - - "TailCall" -> - Decode.map2 TailCall - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list (D.jsonPair Decode.string exprDecoder))) - - "If" -> - Decode.map2 If - (Decode.field "branches" (Decode.list (D.jsonPair exprDecoder exprDecoder))) - (Decode.field "final" exprDecoder) - - "Let" -> - Decode.map2 Let - (Decode.field "def" defDecoder) - (Decode.field "body" exprDecoder) - - "Destruct" -> - Decode.map2 Destruct - (Decode.field "destructor" destructorDecoder) - (Decode.field "body" exprDecoder) - - "Case" -> - Decode.map4 Case - (Decode.field "label" Decode.string) - (Decode.field "root" Decode.string) - (Decode.field "decider" (deciderDecoder choiceDecoder)) - (Decode.field "jumps" (Decode.list (D.jsonPair Decode.int exprDecoder))) - - "Accessor" -> - Decode.map Accessor (Decode.field "field" Decode.string) - - "Access" -> - Decode.map2 Access - (Decode.field "record" exprDecoder) - (Decode.field "field" Decode.string) - - "Update" -> - Decode.map2 Update - (Decode.field "record" exprDecoder) - (Decode.field "fields" (D.assocListDict compare Decode.string exprDecoder)) - - "Record" -> - Decode.map Record (Decode.field "value" (D.assocListDict compare Decode.string exprDecoder)) - - "Unit" -> - Decode.succeed Unit - - "Tuple" -> - Decode.map3 Tuple - (Decode.field "a" exprDecoder) - (Decode.field "b" exprDecoder) - (Decode.field "maybeC" (Decode.maybe exprDecoder)) - - "Shader" -> - Decode.map3 Shader - (Decode.field "src" Shader.sourceDecoder) - (Decode.field "attributes" (D.everySet compare Decode.string)) - (Decode.field "uniforms" (D.everySet compare Decode.string)) - - _ -> - Decode.fail ("Unknown Expr's type: " ++ type_) - ) - - exprCodec : Codec e Expr exprCodec = Serialize.customType @@ -1005,47 +457,6 @@ exprCodec = |> Serialize.finishCustomType -defEncoder : Def -> Encode.Value -defEncoder def = - case def of - Def name expr -> - Encode.object - [ ( "type", Encode.string "Def" ) - , ( "name", Encode.string name ) - , ( "expr", exprEncoder expr ) - ] - - TailDef name args expr -> - Encode.object - [ ( "type", Encode.string "TailDef" ) - , ( "name", Encode.string name ) - , ( "args", Encode.list Encode.string args ) - , ( "expr", exprEncoder expr ) - ] - - -defDecoder : Decode.Decoder Def -defDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Def" -> - Decode.map2 Def - (Decode.field "name" Decode.string) - (Decode.field "expr" exprDecoder) - - "TailDef" -> - Decode.map3 TailDef - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list Decode.string)) - (Decode.field "expr" exprDecoder) - - _ -> - Decode.fail ("Unknown Def's type: " ++ type_) - ) - - defCodec : Codec e Def defCodec = Serialize.customType @@ -1062,22 +473,6 @@ defCodec = |> Serialize.finishCustomType -destructorEncoder : Destructor -> Encode.Value -destructorEncoder (Destructor name path) = - Encode.object - [ ( "type", Encode.string "Destructor" ) - , ( "name", Encode.string name ) - , ( "path", pathEncoder path ) - ] - - -destructorDecoder : Decode.Decoder Destructor -destructorDecoder = - Decode.map2 Destructor - (Decode.field "name" Decode.string) - (Decode.field "path" pathDecoder) - - destructorCodec : Codec e Destructor destructorCodec = Serialize.customType @@ -1088,58 +483,6 @@ destructorCodec = |> Serialize.finishCustomType -deciderEncoder : (a -> Encode.Value) -> Decider a -> Encode.Value -deciderEncoder encoder decider = - case decider of - Leaf value -> - Encode.object - [ ( "type", Encode.string "Leaf" ) - , ( "value", encoder value ) - ] - - Chain testChain success failure -> - Encode.object - [ ( "type", Encode.string "Chain" ) - , ( "testChain", Encode.list (E.jsonPair DT.pathEncoder DT.testEncoder) testChain ) - , ( "success", deciderEncoder encoder success ) - , ( "failure", deciderEncoder encoder failure ) - ] - - FanOut path edges fallback -> - Encode.object - [ ( "type", Encode.string "FanOut" ) - , ( "path", DT.pathEncoder path ) - , ( "edges", Encode.list (E.jsonPair DT.testEncoder (deciderEncoder encoder)) edges ) - , ( "fallback", deciderEncoder encoder fallback ) - ] - - -deciderDecoder : Decode.Decoder a -> Decode.Decoder (Decider a) -deciderDecoder decoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Leaf" -> - Decode.map Leaf (Decode.field "value" decoder) - - "Chain" -> - Decode.map3 Chain - (Decode.field "testChain" (Decode.list (D.jsonPair DT.pathDecoder DT.testDecoder))) - (Decode.field "success" (deciderDecoder decoder)) - (Decode.field "failure" (deciderDecoder decoder)) - - "FanOut" -> - Decode.map3 FanOut - (Decode.field "path" DT.pathDecoder) - (Decode.field "edges" (Decode.list (D.jsonPair DT.testDecoder (deciderDecoder decoder)))) - (Decode.field "fallback" (deciderDecoder decoder)) - - _ -> - Decode.fail ("Unknown Decider's type: " ++ type_) - ) - - deciderCodec : Codec e a -> Codec e (Decider a) deciderCodec codec = Serialize.customType @@ -1160,39 +503,6 @@ deciderCodec codec = |> Serialize.finishCustomType -choiceEncoder : Choice -> Encode.Value -choiceEncoder choice = - case choice of - Inline value -> - Encode.object - [ ( "type", Encode.string "Inline" ) - , ( "value", exprEncoder value ) - ] - - Jump value -> - Encode.object - [ ( "type", Encode.string "Jump" ) - , ( "value", Encode.int value ) - ] - - -choiceDecoder : Decode.Decoder Choice -choiceDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Inline" -> - Decode.map Inline (Decode.field "value" exprDecoder) - - "Jump" -> - Decode.map Jump (Decode.field "value" Decode.int) - - _ -> - Decode.fail ("Unknown Choice's type: " ++ type_) - ) - - choiceCodec : Codec e Choice choiceCodec = Serialize.customType @@ -1209,63 +519,6 @@ choiceCodec = |> Serialize.finishCustomType -pathEncoder : Path -> Encode.Value -pathEncoder path = - case path of - Index index subPath -> - Encode.object - [ ( "type", Encode.string "Index" ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "subPath", pathEncoder subPath ) - ] - - Field field subPath -> - Encode.object - [ ( "type", Encode.string "Field" ) - , ( "field", Encode.string field ) - , ( "subPath", pathEncoder subPath ) - ] - - Unbox subPath -> - Encode.object - [ ( "type", Encode.string "Unbox" ) - , ( "subPath", pathEncoder subPath ) - ] - - Root name -> - Encode.object - [ ( "type", Encode.string "Root" ) - , ( "name", Encode.string name ) - ] - - -pathDecoder : Decode.Decoder Path -pathDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Index" -> - Decode.map2 Index - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "subPath" pathDecoder) - - "Field" -> - Decode.map2 Field - (Decode.field "field" Decode.string) - (Decode.field "subPath" pathDecoder) - - "Unbox" -> - Decode.map Unbox (Decode.field "subPath" pathDecoder) - - "Root" -> - Decode.map Root (Decode.field "name" Decode.string) - - _ -> - Decode.fail ("Unknown Path's type: " ++ type_) - ) - - pathCodec : Codec e Path pathCodec = Serialize.customType @@ -1290,39 +543,6 @@ pathCodec = |> Serialize.finishCustomType -effectsTypeEncoder : EffectsType -> Encode.Value -effectsTypeEncoder effectsType = - case effectsType of - Cmd -> - Encode.string "Cmd" - - Sub -> - Encode.string "Sub" - - Fx -> - Encode.string "Fx" - - -effectsTypeDecoder : Decode.Decoder EffectsType -effectsTypeDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "Cmd" -> - Decode.succeed Cmd - - "Sub" -> - Decode.succeed Sub - - "Fx" -> - Decode.succeed Fx - - _ -> - Decode.fail ("Unknown EffectsType: " ++ str) - ) - - effectsTypeCodec : Codec e EffectsType effectsTypeCodec = Serialize.customType diff --git a/src/Compiler/AST/Source.elm b/src/Compiler/AST/Source.elm index b0739990e..54296950c 100644 --- a/src/Compiler/AST/Source.elm +++ b/src/Compiler/AST/Source.elm @@ -24,20 +24,14 @@ module Compiler.AST.Source exposing , getImportName , getName , moduleCodec - , moduleDecoder - , moduleEncoder - , typeDecoder - , typeEncoder + , typeCodec ) import Compiler.AST.Utils.Binop as Binop import Compiler.AST.Utils.Shader as Shader import Compiler.Data.Name as Name exposing (Name) -import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P import Compiler.Reporting.Annotation as A -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -222,1057 +216,536 @@ type Privacy -- ENCODERS and DECODERS -typeEncoder : Type -> Encode.Value -typeEncoder = - A.locatedEncoder internalTypeEncoder - - -typeDecoder : Decode.Decoder Type -typeDecoder = - A.locatedDecoder internalTypeDecoder - - -internalTypeEncoder : Type_ -> Encode.Value -internalTypeEncoder type_ = - case type_ of - TLambda arg result -> - Encode.object - [ ( "type", Encode.string "TLambda" ) - , ( "arg", typeEncoder arg ) - , ( "result", typeEncoder result ) - ] - - TVar name -> - Encode.object - [ ( "type", Encode.string "TVar" ) - , ( "name", Encode.string name ) - ] - - TType region name args -> - Encode.object - [ ( "type", Encode.string "TType" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "args", Encode.list typeEncoder args ) - ] - - TTypeQual region home name args -> - Encode.object - [ ( "type", Encode.string "TTypeQual" ) - , ( "region", A.regionEncoder region ) - , ( "home", Encode.string home ) - , ( "name", Encode.string name ) - , ( "args", Encode.list typeEncoder args ) - ] - - TRecord fields ext -> - Encode.object - [ ( "type", Encode.string "TRecord" ) - , ( "fields", Encode.list (E.jsonPair (A.locatedEncoder Encode.string) typeEncoder) fields ) - , ( "ext", E.maybe (A.locatedEncoder Encode.string) ext ) - ] - - TUnit -> - Encode.object - [ ( "type", Encode.string "TUnit" ) - ] - - TTuple a b cs -> - Encode.object - [ ( "type", Encode.string "TTuple" ) - , ( "a", typeEncoder a ) - , ( "b", typeEncoder b ) - , ( "cs", Encode.list typeEncoder cs ) - ] - - -internalTypeDecoder : Decode.Decoder Type_ -internalTypeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "TLambda" -> - Decode.map2 TLambda - (Decode.field "arg" typeDecoder) - (Decode.field "result" typeDecoder) - - "TVar" -> - Decode.map TVar (Decode.field "name" Decode.string) - - "TType" -> - Decode.map3 TType - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list typeDecoder)) - - "TTypeQual" -> - Decode.map4 TTypeQual - (Decode.field "region" A.regionDecoder) - (Decode.field "home" Decode.string) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list typeDecoder)) - - "TRecord" -> - Decode.map2 TRecord - (Decode.field "fields" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" (A.locatedDecoder Decode.string)) - (Decode.field "b" typeDecoder) - ) - ) - ) - (Decode.field "ext" (Decode.maybe (A.locatedDecoder Decode.string))) - - "TUnit" -> - Decode.succeed TUnit - - "TTuple" -> - Decode.map3 TTuple - (Decode.field "a" typeDecoder) - (Decode.field "b" typeDecoder) - (Decode.field "cs" (Decode.list typeDecoder)) - - _ -> - Decode.fail ("Failed to decode Type_'s type: " ++ type_) - ) +typeCodec : Codec e Type +typeCodec = + A.locatedCodec type_Codec + + +type_Codec : Codec e Type_ +type_Codec = + Serialize.customType + (\tLambdaEncoder tVarEncoder tTypeEncoder tTypeQualEncoder tRecordEncoder tUnitEncoder tTupleEncoder value -> + case value of + TLambda arg result -> + tLambdaEncoder arg result + + TVar name -> + tVarEncoder name + + TType region name args -> + tTypeEncoder region name args + + TTypeQual region home name args -> + tTypeQualEncoder region home name args + TRecord fields ext -> + tRecordEncoder fields ext -moduleEncoder : Module -> Encode.Value -moduleEncoder (Module maybeName exports docs imports values unions aliases binops effects) = - Encode.object - [ ( "type", Encode.string "Module" ) - , ( "maybeName", E.maybe (A.locatedEncoder Encode.string) maybeName ) - , ( "exports", A.locatedEncoder exposingEncoder exports ) - , ( "docs", docsEncoder docs ) - , ( "imports", Encode.list importEncoder imports ) - , ( "values", Encode.list (A.locatedEncoder valueEncoder) values ) - , ( "unions", Encode.list (A.locatedEncoder unionEncoder) unions ) - , ( "aliases", Encode.list (A.locatedEncoder aliasEncoder) aliases ) - , ( "binops", Encode.list (A.locatedEncoder infixEncoder) binops ) - , ( "effects", effectsEncoder effects ) - ] - - -moduleDecoder : Decode.Decoder Module -moduleDecoder = - Decode.map8 (\( maybeName, exports ) -> Module maybeName exports) - (Decode.map2 Tuple.pair - (Decode.field "maybeName" (Decode.maybe (A.locatedDecoder Decode.string))) - (Decode.field "exports" (A.locatedDecoder exposingDecoder)) + TUnit -> + tUnitEncoder + + TTuple a b cs -> + tTupleEncoder a b cs ) - (Decode.field "docs" docsDecoder) - (Decode.field "imports" (Decode.list importDecoder)) - (Decode.field "values" (Decode.list (A.locatedDecoder valueDecoder))) - (Decode.field "unions" (Decode.list (A.locatedDecoder unionDecoder))) - (Decode.field "aliases" (Decode.list (A.locatedDecoder aliasDecoder))) - (Decode.field "binops" (Decode.list (A.locatedDecoder infixDecoder))) - (Decode.field "effects" effectsDecoder) + |> Serialize.variant2 + TLambda + (A.locatedCodec (Serialize.lazy (\() -> type_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> type_Codec))) + |> Serialize.variant1 TVar Serialize.string + |> Serialize.variant3 + TType + A.regionCodec + Serialize.string + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> type_Codec)))) + |> Serialize.variant4 + TTypeQual + A.regionCodec + Serialize.string + Serialize.string + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> type_Codec)))) + |> Serialize.variant2 + TRecord + (Serialize.list + (Serialize.tuple (A.locatedCodec Serialize.string) (A.locatedCodec (Serialize.lazy (\() -> type_Codec)))) + ) + (Serialize.maybe (A.locatedCodec Serialize.string)) + |> Serialize.variant0 TUnit + |> Serialize.variant3 + TTuple + (A.locatedCodec (Serialize.lazy (\() -> type_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> type_Codec))) + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> type_Codec)))) + |> Serialize.finishCustomType moduleCodec : Codec e Module moduleCodec = - Debug.todo "moduleCodec" - - -exposingEncoder : Exposing -> Encode.Value -exposingEncoder exposing_ = - case exposing_ of - Open -> - Encode.object - [ ( "type", Encode.string "Open" ) - ] - - Explicit exposedList -> - Encode.object - [ ( "type", Encode.string "Explicit" ) - , ( "exposedList", Encode.list exposedEncoder exposedList ) - ] - - -exposingDecoder : Decode.Decoder Exposing -exposingDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Open" -> - Decode.succeed Open - - "Explicit" -> - Decode.map Explicit (Decode.field "exposedList" (Decode.list exposedDecoder)) - - _ -> - Decode.fail ("Failed to decode Exposing's type: " ++ type_) - ) - + Serialize.customType + (\moduleCodecEncoder (Module maybeName exports docs imports values unions aliases binops effects) -> + moduleCodecEncoder maybeName exports docs imports values unions aliases binops effects + ) + |> Serialize.variant9 + Module + (Serialize.maybe (A.locatedCodec Serialize.string)) + (A.locatedCodec exposingCodec) + docsCodec + (Serialize.list importCodec) + (Serialize.list (A.locatedCodec valueCodec)) + (Serialize.list (A.locatedCodec unionCodec)) + (Serialize.list (A.locatedCodec aliasCodec)) + (Serialize.list (A.locatedCodec infixCodec)) + effectsCodec + |> Serialize.finishCustomType + + +exposingCodec : Codec e Exposing +exposingCodec = + Serialize.customType + (\openEncoder explicitEncoder value -> + case value of + Open -> + openEncoder + + Explicit exposedList -> + explicitEncoder exposedList + ) + |> Serialize.variant0 Open + |> Serialize.variant1 Explicit (Serialize.list exposedCodec) + |> Serialize.finishCustomType -docsEncoder : Docs -> Encode.Value -docsEncoder docs = - case docs of - NoDocs region -> - Encode.object - [ ( "type", Encode.string "NoDocs" ) - , ( "region", A.regionEncoder region ) - ] - - YesDocs overview comments -> - Encode.object - [ ( "type", Encode.string "YesDocs" ) - , ( "overview", commentEncoder overview ) - , ( "comments", Encode.list (E.jsonPair Encode.string commentEncoder) comments ) - ] - - -docsDecoder : Decode.Decoder Docs -docsDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NoDocs" -> - Decode.map NoDocs (Decode.field "region" A.regionDecoder) - - "YesDocs" -> - Decode.map2 YesDocs - (Decode.field "overview" commentDecoder) - (Decode.field "comments" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" Decode.string) - (Decode.field "b" commentDecoder) - ) - ) - ) - - _ -> - Decode.fail ("Failed to decode Docs's type: " ++ type_) - ) +docsCodec : Codec e Docs +docsCodec = + Serialize.customType + (\noDocsEncoder yesDocsEncoder value -> + case value of + NoDocs region -> + noDocsEncoder region -importEncoder : Import -> Encode.Value -importEncoder (Import importName maybeAlias exposing_) = - Encode.object - [ ( "type", Encode.string "Import" ) - , ( "importName", A.locatedEncoder Encode.string importName ) - , ( "maybeAlias", E.maybe Encode.string maybeAlias ) - , ( "exposing", exposingEncoder exposing_ ) - ] - - -importDecoder : Decode.Decoder Import -importDecoder = - Decode.map3 Import - (Decode.field "importName" (A.locatedDecoder Decode.string)) - (Decode.field "maybeAlias" (Decode.maybe Decode.string)) - (Decode.field "exposing" exposingDecoder) - - -valueEncoder : Value -> Encode.Value -valueEncoder (Value name srcArgs body maybeType) = - Encode.object - [ ( "type", Encode.string "Value" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "srcArgs", Encode.list patternEncoder srcArgs ) - , ( "body", exprEncoder body ) - , ( "maybeType", E.maybe typeEncoder maybeType ) - ] - - -valueDecoder : Decode.Decoder Value -valueDecoder = - Decode.map4 Value - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "srcArgs" (Decode.list patternDecoder)) - (Decode.field "body" exprDecoder) - (Decode.field "maybeType" (Decode.maybe typeDecoder)) - - -unionEncoder : Union -> Encode.Value -unionEncoder (Union name args constructors) = - Encode.object - [ ( "type", Encode.string "Union" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "args", Encode.list (A.locatedEncoder Encode.string) args ) - , ( "constructors", Encode.list (E.jsonPair (A.locatedEncoder Encode.string) (Encode.list typeEncoder)) constructors ) - ] - - -unionDecoder : Decode.Decoder Union -unionDecoder = - Decode.map3 Union - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "args" (Decode.list (A.locatedDecoder Decode.string))) - (Decode.field "constructors" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" (A.locatedDecoder Decode.string)) - (Decode.field "b" (Decode.list typeDecoder)) - ) - ) + YesDocs overview comments -> + yesDocsEncoder overview comments ) + |> Serialize.variant1 NoDocs A.regionCodec + |> Serialize.variant2 YesDocs commentCodec (Serialize.list (Serialize.tuple Serialize.string commentCodec)) + |> Serialize.finishCustomType -aliasEncoder : Alias -> Encode.Value -aliasEncoder (Alias name args tipe) = - Encode.object - [ ( "type", Encode.string "Alias" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "args", Encode.list (A.locatedEncoder Encode.string) args ) - , ( "tipe", typeEncoder tipe ) - ] - - -aliasDecoder : Decode.Decoder Alias -aliasDecoder = - Decode.map3 Alias - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "args" (Decode.list (A.locatedDecoder Decode.string))) - (Decode.field "tipe" typeDecoder) - - -infixEncoder : Infix -> Encode.Value -infixEncoder (Infix op associativity precedence name) = - Encode.object - [ ( "type", Encode.string "Infix" ) - , ( "op", Encode.string op ) - , ( "associativity", Binop.associativityEncoder associativity ) - , ( "precedence", Binop.precedenceEncoder precedence ) - , ( "name", Encode.string name ) - ] - - -infixDecoder : Decode.Decoder Infix -infixDecoder = - Decode.map4 Infix - (Decode.field "op" Decode.string) - (Decode.field "associativity" Binop.associativityDecoder) - (Decode.field "precedence" Binop.precedenceDecoder) - (Decode.field "name" Decode.string) - - -effectsEncoder : Effects -> Encode.Value -effectsEncoder effects = - case effects of - NoEffects -> - Encode.object - [ ( "type", Encode.string "NoEffects" ) - ] - - Ports ports -> - Encode.object - [ ( "type", Encode.string "Ports" ) - , ( "ports", Encode.list portEncoder ports ) - ] - - Manager region manager -> - Encode.object - [ ( "type", Encode.string "Manager" ) - , ( "region", A.regionEncoder region ) - , ( "manager", managerEncoder manager ) - ] - - -effectsDecoder : Decode.Decoder Effects -effectsDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NoEffects" -> - Decode.succeed NoEffects - - "Ports" -> - Decode.map Ports (Decode.field "ports" (Decode.list portDecoder)) - - "Manager" -> - Decode.map2 Manager - (Decode.field "region" A.regionDecoder) - (Decode.field "manager" managerDecoder) - - _ -> - Decode.fail ("Failed to decode Effects' type: " ++ type_) - ) +importCodec : Codec e Import +importCodec = + Serialize.customType + (\importCodecEncoder (Import importName maybeAlias exposing_) -> + importCodecEncoder importName maybeAlias exposing_ + ) + |> Serialize.variant3 Import (A.locatedCodec Serialize.string) (Serialize.maybe Serialize.string) exposingCodec + |> Serialize.finishCustomType -commentEncoder : Comment -> Encode.Value -commentEncoder (Comment snippet) = - P.snippetEncoder snippet +valueCodec : Codec e Value +valueCodec = + Serialize.customType + (\valueCodecEncoder (Value name srcArgs body maybeType) -> + valueCodecEncoder name srcArgs body maybeType + ) + |> Serialize.variant4 + Value + (A.locatedCodec Serialize.string) + (Serialize.list (A.locatedCodec pattern_Codec)) + (A.locatedCodec expr_Codec) + (Serialize.maybe (A.locatedCodec type_Codec)) + |> Serialize.finishCustomType + + +unionCodec : Codec e Union +unionCodec = + Serialize.customType + (\unionCodecEncoder (Union name args constructors) -> + unionCodecEncoder name args constructors + ) + |> Serialize.variant3 + Union + (A.locatedCodec Serialize.string) + (Serialize.list (A.locatedCodec Serialize.string)) + (Serialize.list + (Serialize.tuple (A.locatedCodec Serialize.string) (Serialize.list (A.locatedCodec type_Codec))) + ) + |> Serialize.finishCustomType -commentDecoder : Decode.Decoder Comment -commentDecoder = - Decode.map Comment P.snippetDecoder +aliasCodec : Codec e Alias +aliasCodec = + Serialize.customType + (\aliasCodecEncoder (Alias name args tipe) -> + aliasCodecEncoder name args tipe + ) + |> Serialize.variant3 + Alias + (A.locatedCodec Serialize.string) + (Serialize.list (A.locatedCodec Serialize.string)) + (A.locatedCodec type_Codec) + |> Serialize.finishCustomType + + +infixCodec : Codec e Infix +infixCodec = + Serialize.customType + (\infixCodecEncoder (Infix op associativity precedence name) -> + infixCodecEncoder op associativity precedence name + ) + |> Serialize.variant4 Infix Serialize.string Binop.associativityCodec Binop.precedenceCodec Serialize.string + |> Serialize.finishCustomType -portEncoder : Port -> Encode.Value -portEncoder (Port name tipe) = - Encode.object - [ ( "type", Encode.string "Port" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "tipe", typeEncoder tipe ) - ] +effectsCodec : Codec e Effects +effectsCodec = + Serialize.customType + (\noEffectsEncoder portsEncoder managerCodecEncoder value -> + case value of + NoEffects -> + noEffectsEncoder + Ports ports -> + portsEncoder ports -portDecoder : Decode.Decoder Port -portDecoder = - Decode.map2 Port - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "tipe" typeDecoder) + Manager region manager -> + managerCodecEncoder region manager + ) + |> Serialize.variant0 NoEffects + |> Serialize.variant1 Ports (Serialize.list portCodec) + |> Serialize.variant2 Manager A.regionCodec managerCodec + |> Serialize.finishCustomType -managerEncoder : Manager -> Encode.Value -managerEncoder manager = - case manager of - Cmd cmdType -> - Encode.object - [ ( "type", Encode.string "Cmd" ) - , ( "cmdType", A.locatedEncoder Encode.string cmdType ) - ] +commentCodec : Codec e Comment +commentCodec = + Serialize.customType + (\commentCodecEncoder (Comment snippet) -> + commentCodecEncoder snippet + ) + |> Serialize.variant1 Comment P.snippetCodec + |> Serialize.finishCustomType - Sub subType -> - Encode.object - [ ( "type", Encode.string "Sub" ) - , ( "subType", A.locatedEncoder Encode.string subType ) - ] - Fx cmdType subType -> - Encode.object - [ ( "type", Encode.string "Fx" ) - , ( "cmdType", A.locatedEncoder Encode.string cmdType ) - , ( "subType", A.locatedEncoder Encode.string subType ) - ] +portCodec : Codec e Port +portCodec = + Serialize.customType + (\portCodecEncoder (Port name tipe) -> + portCodecEncoder name tipe + ) + |> Serialize.variant2 Port (A.locatedCodec Serialize.string) (A.locatedCodec type_Codec) + |> Serialize.finishCustomType -managerDecoder : Decode.Decoder Manager -managerDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Cmd" -> - Decode.map Cmd (Decode.field "cmdType" (A.locatedDecoder Decode.string)) +managerCodec : Codec e Manager +managerCodec = + Serialize.customType + (\cmdEncoder subEncoder fxEncoder value -> + case value of + Cmd cmdType -> + cmdEncoder cmdType - "Sub" -> - Decode.map Sub (Decode.field "subType" (A.locatedDecoder Decode.string)) + Sub subType -> + subEncoder subType - "Fx" -> - Decode.map2 Fx - (Decode.field "cmdType" (A.locatedDecoder Decode.string)) - (Decode.field "subType" (A.locatedDecoder Decode.string)) + Fx cmdType subType -> + fxEncoder cmdType subType + ) + |> Serialize.variant1 Cmd (A.locatedCodec Serialize.string) + |> Serialize.variant1 Sub (A.locatedCodec Serialize.string) + |> Serialize.variant2 Fx (A.locatedCodec Serialize.string) (A.locatedCodec Serialize.string) + |> Serialize.finishCustomType - _ -> - Decode.fail ("Failed to decode Manager's type: " ++ type_) - ) +exposedCodec : Codec e Exposed +exposedCodec = + Serialize.customType + (\lowerEncoder upperEncoder operatorEncoder value -> + case value of + Lower name -> + lowerEncoder name -exposedEncoder : Exposed -> Encode.Value -exposedEncoder exposed = - case exposed of - Lower name -> - Encode.object - [ ( "type", Encode.string "Lower" ) - , ( "name", A.locatedEncoder Encode.string name ) - ] - - Upper name dotDotRegion -> - Encode.object - [ ( "type", Encode.string "Upper" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "dotDotRegion", privacyEncoder dotDotRegion ) - ] - - Operator region name -> - Encode.object - [ ( "type", Encode.string "Operator" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - ] - - -exposedDecoder : Decode.Decoder Exposed -exposedDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Lower" -> - Decode.map Lower (Decode.field "name" (A.locatedDecoder Decode.string)) - - "Upper" -> - Decode.map2 Upper - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "dotDotRegion" privacyDecoder) - - "Operator" -> - Decode.map2 Operator - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - - _ -> - Decode.fail ("Failed to decode Exposed's type: " ++ type_) - ) + Upper name dotDotRegion -> + upperEncoder name dotDotRegion + Operator region name -> + operatorEncoder region name + ) + |> Serialize.variant1 Lower (A.locatedCodec Serialize.string) + |> Serialize.variant2 Upper (A.locatedCodec Serialize.string) privacyCodec + |> Serialize.variant2 Operator A.regionCodec Serialize.string + |> Serialize.finishCustomType + + +privacyCodec : Codec e Privacy +privacyCodec = + Serialize.customType + (\publicEncoder privateEncoder value -> + case value of + Public region -> + publicEncoder region + + Private -> + privateEncoder + ) + |> Serialize.variant1 Public A.regionCodec + |> Serialize.variant0 Private + |> Serialize.finishCustomType -privacyEncoder : Privacy -> Encode.Value -privacyEncoder privacy = - case privacy of - Public region -> - Encode.object - [ ( "type", Encode.string "Public" ) - , ( "region", A.regionEncoder region ) - ] - Private -> - Encode.object - [ ( "type", Encode.string "Private" ) - ] +patternCodec : Codec e Pattern +patternCodec = + A.locatedCodec pattern_Codec -privacyDecoder : Decode.Decoder Privacy -privacyDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Public" -> - Decode.map Public (Decode.field "region" A.regionDecoder) +pattern_Codec : Codec e Pattern_ +pattern_Codec = + Serialize.customType + (\pAnythingEncoder pVarEncoder pRecordEncoder pAliasEncoder pUnitEncoder pTupleEncoder pCtorEncoder pCtorQualEncoder pListEncoder pConsEncoder pChrEncoder pStrEncoder pIntEncoder value -> + case value of + PAnything -> + pAnythingEncoder - "Private" -> - Decode.succeed Private + PVar name -> + pVarEncoder name - _ -> - Decode.fail ("Failed to decode Privacy's type: " ++ type_) - ) + PRecord fields -> + pRecordEncoder fields + PAlias aliasPattern name -> + pAliasEncoder aliasPattern name -patternEncoder : Pattern -> Encode.Value -patternEncoder = - A.locatedEncoder pattern_Encoder - - -patternDecoder : Decode.Decoder Pattern -patternDecoder = - A.locatedDecoder pattern_Decoder - - -pattern_Encoder : Pattern_ -> Encode.Value -pattern_Encoder pattern_ = - case pattern_ of - PAnything -> - Encode.object - [ ( "type", Encode.string "PAnything" ) - ] - - PVar name -> - Encode.object - [ ( "type", Encode.string "PVar" ) - , ( "name", Encode.string name ) - ] - - PRecord fields -> - Encode.object - [ ( "type", Encode.string "PRecord" ) - , ( "fields", Encode.list (A.locatedEncoder Encode.string) fields ) - ] - - PAlias aliasPattern name -> - Encode.object - [ ( "type", Encode.string "PAlias" ) - , ( "aliasPattern", patternEncoder aliasPattern ) - , ( "name", A.locatedEncoder Encode.string name ) - ] - - PUnit -> - Encode.object - [ ( "type", Encode.string "PUnit" ) - ] - - PTuple a b cs -> - Encode.object - [ ( "type", Encode.string "PTuple" ) - , ( "a", patternEncoder a ) - , ( "b", patternEncoder b ) - , ( "cs", Encode.list patternEncoder cs ) - ] - - PCtor nameRegion name patterns -> - Encode.object - [ ( "type", Encode.string "PCtor" ) - , ( "nameRegion", A.regionEncoder nameRegion ) - , ( "name", Encode.string name ) - , ( "patterns", Encode.list patternEncoder patterns ) - ] - - PCtorQual nameRegion home name patterns -> - Encode.object - [ ( "type", Encode.string "PCtorQual" ) - , ( "nameRegion", A.regionEncoder nameRegion ) - , ( "home", Encode.string home ) - , ( "name", Encode.string name ) - , ( "patterns", Encode.list patternEncoder patterns ) - ] - - PList patterns -> - Encode.object - [ ( "type", Encode.string "PList" ) - , ( "patterns", Encode.list patternEncoder patterns ) - ] - - PCons hd tl -> - Encode.object - [ ( "type", Encode.string "PCons" ) - , ( "hd", patternEncoder hd ) - , ( "tl", patternEncoder tl ) - ] - - PChr chr -> - Encode.object - [ ( "type", Encode.string "PChr" ) - , ( "chr", Encode.string chr ) - ] - - PStr str -> - Encode.object - [ ( "type", Encode.string "PStr" ) - , ( "str", Encode.string str ) - ] - - PInt int -> - Encode.object - [ ( "type", Encode.string "PInt" ) - , ( "int", Encode.int int ) - ] - - -pattern_Decoder : Decode.Decoder Pattern_ -pattern_Decoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PAnything" -> - Decode.succeed PAnything - - "PVar" -> - Decode.map PVar (Decode.field "name" Decode.string) - - "PRecord" -> - Decode.map PRecord (Decode.field "fields" (Decode.list (A.locatedDecoder Decode.string))) - - "PAlias" -> - Decode.map2 PAlias - (Decode.field "aliasPattern" patternDecoder) - (Decode.field "name" (A.locatedDecoder Decode.string)) - - "PUnit" -> - Decode.succeed PUnit - - "PTuple" -> - Decode.map3 PTuple - (Decode.field "a" patternDecoder) - (Decode.field "b" patternDecoder) - (Decode.field "cs" (Decode.list patternDecoder)) - - "PCtor" -> - Decode.map3 PCtor - (Decode.field "nameRegion" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "patterns" (Decode.list patternDecoder)) - - "PCtorQual" -> - Decode.map4 PCtorQual - (Decode.field "nameRegion" A.regionDecoder) - (Decode.field "home" Decode.string) - (Decode.field "name" Decode.string) - (Decode.field "patterns" (Decode.list patternDecoder)) - - "PList" -> - Decode.map PList (Decode.field "patterns" (Decode.list patternDecoder)) - - "PCons" -> - Decode.map2 PCons - (Decode.field "hd" patternDecoder) - (Decode.field "tl" patternDecoder) - - "PChr" -> - Decode.map PChr (Decode.field "chr" Decode.string) - - "PStr" -> - Decode.map PStr (Decode.field "str" Decode.string) - - "PInt" -> - Decode.map PInt (Decode.field "int" Decode.int) - - _ -> - Decode.fail ("Failed to decode Pattern_'s type: " ++ type_) - ) + PUnit -> + pUnitEncoder + PTuple a b cs -> + pTupleEncoder a b cs -exprEncoder : Expr -> Encode.Value -exprEncoder = - A.locatedEncoder expr_Encoder - - -exprDecoder : Decode.Decoder Expr -exprDecoder = - A.locatedDecoder expr_Decoder - - -expr_Encoder : Expr_ -> Encode.Value -expr_Encoder expr_ = - case expr_ of - Chr char -> - Encode.object - [ ( "type", Encode.string "Chr" ) - , ( "char", Encode.string char ) - ] - - Str string -> - Encode.object - [ ( "type", Encode.string "Str" ) - , ( "string", Encode.string string ) - ] - - Int int -> - Encode.object - [ ( "type", Encode.string "Int" ) - , ( "int", Encode.int int ) - ] - - Float float -> - Encode.object - [ ( "type", Encode.string "Float" ) - , ( "float", Encode.float float ) - ] - - Var varType name -> - Encode.object - [ ( "type", Encode.string "Var" ) - , ( "varType", varTypeEncoder varType ) - , ( "name", Encode.string name ) - ] - - VarQual varType prefix name -> - Encode.object - [ ( "type", Encode.string "VarQual" ) - , ( "varType", varTypeEncoder varType ) - , ( "prefix", Encode.string prefix ) - , ( "name", Encode.string name ) - ] - - List list -> - Encode.object - [ ( "type", Encode.string "List" ) - , ( "list", Encode.list exprEncoder list ) - ] - - Op op -> - Encode.object - [ ( "type", Encode.string "Op" ) - , ( "op", Encode.string op ) - ] - - Negate expr -> - Encode.object - [ ( "type", Encode.string "Negate" ) - , ( "expr", exprEncoder expr ) - ] - - Binops ops final -> - Encode.object - [ ( "type", Encode.string "Binops" ) - , ( "ops", Encode.list (E.jsonPair exprEncoder (A.locatedEncoder Encode.string)) ops ) - , ( "final", exprEncoder final ) - ] - - Lambda srcArgs body -> - Encode.object - [ ( "type", Encode.string "Lambda" ) - , ( "srcArgs", Encode.list patternEncoder srcArgs ) - , ( "body", exprEncoder body ) - ] - - Call func args -> - Encode.object - [ ( "type", Encode.string "Call" ) - , ( "func", exprEncoder func ) - , ( "args", Encode.list exprEncoder args ) - ] - - If branches finally -> - Encode.object - [ ( "type", Encode.string "If" ) - , ( "branches", Encode.list (E.jsonPair exprEncoder exprEncoder) branches ) - , ( "finally", exprEncoder finally ) - ] - - Let defs expr -> - Encode.object - [ ( "type", Encode.string "Let" ) - , ( "defs", Encode.list (A.locatedEncoder defEncoder) defs ) - , ( "expr", exprEncoder expr ) - ] - - Case expr branches -> - Encode.object - [ ( "type", Encode.string "Case" ) - , ( "expr", exprEncoder expr ) - , ( "branches", Encode.list (E.jsonPair patternEncoder exprEncoder) branches ) - ] - - Accessor field -> - Encode.object - [ ( "type", Encode.string "Accessor" ) - , ( "field", Encode.string field ) - ] - - Access record field -> - Encode.object - [ ( "type", Encode.string "Access" ) - , ( "record", exprEncoder record ) - , ( "field", A.locatedEncoder Encode.string field ) - ] - - Update name fields -> - Encode.object - [ ( "type", Encode.string "Update" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "fields", Encode.list (E.jsonPair (A.locatedEncoder Encode.string) exprEncoder) fields ) - ] - - Record fields -> - Encode.object - [ ( "type", Encode.string "Record" ) - , ( "fields", Encode.list (E.jsonPair (A.locatedEncoder Encode.string) exprEncoder) fields ) - ] - - Unit -> - Encode.object - [ ( "type", Encode.string "Unit" ) - ] - - Tuple a b cs -> - Encode.object - [ ( "type", Encode.string "Tuple" ) - , ( "a", exprEncoder a ) - , ( "b", exprEncoder b ) - , ( "cs", Encode.list exprEncoder cs ) - ] - - Shader src tipe -> - Encode.object - [ ( "type", Encode.string "Shader" ) - , ( "src", Shader.sourceEncoder src ) - , ( "tipe", Shader.typesEncoder tipe ) - ] - - -expr_Decoder : Decode.Decoder Expr_ -expr_Decoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Chr" -> - Decode.map Chr (Decode.field "char" Decode.string) - - "Str" -> - Decode.map Str (Decode.field "string" Decode.string) - - "Int" -> - Decode.map Int (Decode.field "int" Decode.int) - - "Float" -> - Decode.map Float (Decode.field "float" Decode.float) - - "Var" -> - Decode.map2 Var - (Decode.field "varType" varTypeDecoder) - (Decode.field "name" Decode.string) - - "VarQual" -> - Decode.map3 VarQual - (Decode.field "varType" varTypeDecoder) - (Decode.field "prefix" Decode.string) - (Decode.field "name" Decode.string) - - "List" -> - Decode.map List (Decode.field "list" (Decode.list exprDecoder)) - - "Op" -> - Decode.map Op (Decode.field "op" Decode.string) - - "Negate" -> - Decode.map Negate (Decode.field "expr" exprDecoder) - - "Binops" -> - Decode.map2 Binops - (Decode.field "ops" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" exprDecoder) - (Decode.field "b" (A.locatedDecoder Decode.string)) - ) - ) - ) - (Decode.field "final" exprDecoder) - - "Lambda" -> - Decode.map2 Lambda - (Decode.field "srcArgs" (Decode.list patternDecoder)) - (Decode.field "body" exprDecoder) - - "Call" -> - Decode.map2 Call - (Decode.field "func" exprDecoder) - (Decode.field "args" (Decode.list exprDecoder)) - - "If" -> - Decode.map2 If - (Decode.field "branches" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" exprDecoder) - (Decode.field "b" exprDecoder) - ) - ) - ) - (Decode.field "finally" exprDecoder) - - "Let" -> - Decode.map2 Let - (Decode.field "defs" (Decode.list (A.locatedDecoder defDecoder))) - (Decode.field "expr" exprDecoder) - - "Case" -> - Decode.map2 Case - (Decode.field "expr" exprDecoder) - (Decode.field "branches" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" patternDecoder) - (Decode.field "b" exprDecoder) - ) - ) - ) - - "Accessor" -> - Decode.map Accessor (Decode.field "field" Decode.string) - - "Access" -> - Decode.map2 Access - (Decode.field "record" exprDecoder) - (Decode.field "field" (A.locatedDecoder Decode.string)) - - "Update" -> - Decode.map2 Update - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "fields" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" (A.locatedDecoder Decode.string)) - (Decode.field "b" exprDecoder) - ) - ) - ) - - "Record" -> - Decode.map Record - (Decode.field "fields" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.field "a" (A.locatedDecoder Decode.string)) - (Decode.field "b" exprDecoder) - ) - ) - ) - - "Unit" -> - Decode.succeed Unit - - "Tuple" -> - Decode.map3 Tuple - (Decode.field "a" exprDecoder) - (Decode.field "b" exprDecoder) - (Decode.field "cs" (Decode.list exprDecoder)) - - "Shader" -> - Decode.map2 Shader - (Decode.field "src" Shader.sourceDecoder) - (Decode.field "tipe" Shader.typesDecoder) - - _ -> - Decode.fail ("Failed to decode Expr_'s type: " ++ type_) - ) + PCtor nameRegion name patterns -> + pCtorEncoder nameRegion name patterns + PCtorQual nameRegion home name patterns -> + pCtorQualEncoder nameRegion home name patterns -varTypeEncoder : VarType -> Encode.Value -varTypeEncoder varType = - case varType of - LowVar -> - Encode.string "LowVar" + PList patterns -> + pListEncoder patterns - CapVar -> - Encode.string "CapVar" + PCons hd tl -> + pConsEncoder hd tl + PChr chr -> + pChrEncoder chr -varTypeDecoder : Decode.Decoder VarType -varTypeDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "LowVar" -> - Decode.succeed LowVar + PStr str -> + pStrEncoder str - "CapVar" -> - Decode.succeed CapVar + PInt int -> + pIntEncoder int + ) + |> Serialize.variant0 PAnything + |> Serialize.variant1 PVar Serialize.string + |> Serialize.variant1 PRecord (Serialize.list (A.locatedCodec Serialize.string)) + |> Serialize.variant2 + PAlias + (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec))) + (A.locatedCodec Serialize.string) + |> Serialize.variant0 PUnit + |> Serialize.variant3 + PTuple + (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec))) + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec)))) + |> Serialize.variant3 + PCtor + A.regionCodec + Serialize.string + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec)))) + |> Serialize.variant4 + PCtorQual + A.regionCodec + Serialize.string + Serialize.string + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec)))) + |> Serialize.variant1 PList (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec)))) + |> Serialize.variant2 + PCons + (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> pattern_Codec))) + |> Serialize.variant1 PChr Serialize.string + |> Serialize.variant1 PStr Serialize.string + |> Serialize.variant1 PInt Serialize.int + |> Serialize.finishCustomType + + +exprCodec : Codec e Expr +exprCodec = + A.locatedCodec (Serialize.lazy (\() -> expr_Codec)) + + +expr_Codec : Codec e Expr_ +expr_Codec = + Serialize.customType + (\chrEncoder strEncoder intEncoder floatEncoder varEncoder varQualEncoder listEncoder opEncoder negateEncoder binopsEncoder lambdaEncoder callEncoder ifEncoder letEncoder caseEncoder accessorEncoder accessEncoder updateEncoder recordEncoder unitEncoder tupleEncoder shaderEncoder value -> + case value of + Chr char -> + chrEncoder char + + Str string -> + strEncoder string + + Int int -> + intEncoder int + + Float float -> + floatEncoder float + + Var varType name -> + varEncoder varType name + + VarQual varType prefix name -> + varQualEncoder varType prefix name + + List list -> + listEncoder list + + Op op -> + opEncoder op + + Negate expr -> + negateEncoder expr + + Binops ops final -> + binopsEncoder ops final + + Lambda srcArgs body -> + lambdaEncoder srcArgs body + + Call func args -> + callEncoder func args + + If branches finally -> + ifEncoder branches finally + + Let defs expr -> + letEncoder defs expr + + Case expr branches -> + caseEncoder expr branches + + Accessor field -> + accessorEncoder field + + Access record field -> + accessEncoder record field + + Update name fields -> + updateEncoder name fields + + Record fields -> + recordEncoder fields + + Unit -> + unitEncoder + + Tuple a b cs -> + tupleEncoder a b cs - _ -> - Decode.fail ("Unknown VarType: " ++ str) + Shader src tipe -> + shaderEncoder src tipe + ) + |> Serialize.variant1 Chr Serialize.string + |> Serialize.variant1 Str Serialize.string + |> Serialize.variant1 Int Serialize.int + |> Serialize.variant1 Float Serialize.float + |> Serialize.variant2 Var varTypeCodec Serialize.string + |> Serialize.variant3 VarQual varTypeCodec Serialize.string Serialize.string + |> Serialize.variant1 List (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + |> Serialize.variant1 Op Serialize.string + |> Serialize.variant1 Negate (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Binops + (Serialize.list + (Serialize.tuple (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) (A.locatedCodec Serialize.string)) + ) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Lambda + (Serialize.list (A.locatedCodec pattern_Codec)) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Call + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + |> Serialize.variant2 + If + (Serialize.list + (Serialize.tuple + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + ) + ) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Let + (Serialize.list (A.locatedCodec defCodec)) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + |> Serialize.variant2 + Case + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (Serialize.list + (Serialize.tuple (A.locatedCodec pattern_Codec) (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + ) + |> Serialize.variant1 Accessor Serialize.string + |> Serialize.variant2 + Access + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec Serialize.string) + |> Serialize.variant2 + Update + (A.locatedCodec Serialize.string) + (Serialize.list + (Serialize.tuple (A.locatedCodec Serialize.string) (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) ) + |> Serialize.variant1 + Record + (Serialize.list + (Serialize.tuple (A.locatedCodec Serialize.string) (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + ) + |> Serialize.variant0 Unit + |> Serialize.variant3 + Tuple + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (A.locatedCodec (Serialize.lazy (\() -> expr_Codec))) + (Serialize.list (A.locatedCodec (Serialize.lazy (\() -> expr_Codec)))) + |> Serialize.variant2 Shader Shader.sourceCodec Shader.typesCodec + |> Serialize.finishCustomType + + +varTypeCodec : Codec e VarType +varTypeCodec = + Serialize.customType + (\lowVarEncoder capVarEncoder value -> + case value of + LowVar -> + lowVarEncoder + + CapVar -> + capVarEncoder + ) + |> Serialize.variant0 LowVar + |> Serialize.variant0 CapVar + |> Serialize.finishCustomType -defEncoder : Def -> Encode.Value -defEncoder def = - case def of - Define name srcArgs body maybeType -> - Encode.object - [ ( "type", Encode.string "Define" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "srcArgs", Encode.list patternEncoder srcArgs ) - , ( "body", exprEncoder body ) - , ( "maybeType", E.maybe typeEncoder maybeType ) - ] - - Destruct pattern body -> - Encode.object - [ ( "type", Encode.string "Destruct" ) - , ( "pattern", patternEncoder pattern ) - , ( "body", exprEncoder body ) - ] - - -defDecoder : Decode.Decoder Def -defDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Define" -> - Decode.map4 Define - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "srcArgs" (Decode.list patternDecoder)) - (Decode.field "body" exprDecoder) - (Decode.field "maybeType" (Decode.maybe typeDecoder)) - - "Destruct" -> - Decode.map2 Destruct - (Decode.field "pattern" patternDecoder) - (Decode.field "body" exprDecoder) - - _ -> - Decode.fail ("Failed to decode Def's type: " ++ type_) - ) +defCodec : Codec e Def +defCodec = + Serialize.customType + (\defineEncoder destructEncoder value -> + case value of + Define name srcArgs body maybeType -> + defineEncoder name srcArgs body maybeType + + Destruct pattern body -> + destructEncoder pattern body + ) + |> Serialize.variant4 Define (A.locatedCodec Serialize.string) (Serialize.list patternCodec) exprCodec (Serialize.maybe typeCodec) + |> Serialize.variant2 Destruct patternCodec exprCodec + |> Serialize.finishCustomType diff --git a/src/Compiler/AST/Utils/Shader.elm b/src/Compiler/AST/Utils/Shader.elm index 71a0cad1e..26154953d 100644 --- a/src/Compiler/AST/Utils/Shader.elm +++ b/src/Compiler/AST/Utils/Shader.elm @@ -4,18 +4,13 @@ module Compiler.AST.Utils.Shader exposing , Types(..) , fromString , sourceCodec - , sourceDecoder - , sourceEncoder , toJsStringBuilder - , typesDecoder - , typesEncoder + , typesCodec ) import Compiler.Data.Name exposing (Name) -import Compiler.Json.Encode as E -import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode +import Compiler.Serialize as S +import Data.Map exposing (Dict) import Serialize exposing (Codec) @@ -101,108 +96,56 @@ escape = -- ENCODERS and DECODERS -sourceEncoder : Source -> Encode.Value -sourceEncoder (Source src) = - Encode.string src - - -sourceDecoder : Decode.Decoder Source -sourceDecoder = - Decode.map Source Decode.string - - sourceCodec : Codec e Source sourceCodec = Serialize.string |> Serialize.map Source (\(Source src) -> src) -typesEncoder : Types -> Encode.Value -typesEncoder (Types attribute uniform varying) = - Encode.object - [ ( "type", Encode.string "Types" ) - , ( "attribute", E.assocListDict Encode.string typeEncoder attribute ) - , ( "uniform", E.assocListDict Encode.string typeEncoder uniform ) - , ( "varying", E.assocListDict Encode.string typeEncoder varying ) - ] - - -typesDecoder : Decode.Decoder Types -typesDecoder = - Decode.map3 Types - (Decode.field "attribute" (assocListDict compare Decode.string typeDecoder)) - (Decode.field "uniform" (assocListDict compare Decode.string typeDecoder)) - (Decode.field "varying" (assocListDict compare Decode.string typeDecoder)) - - -typeEncoder : Type -> Encode.Value -typeEncoder type_ = - case type_ of - Int -> - Encode.string "Int" - - Float -> - Encode.string "Float" - - V2 -> - Encode.string "V2" - - V3 -> - Encode.string "V3" - - V4 -> - Encode.string "V4" - - M4 -> - Encode.string "M4" - - Texture -> - Encode.string "Texture" - - -typeDecoder : Decode.Decoder Type -typeDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "Int" -> - Decode.succeed Int - - "Float" -> - Decode.succeed Float - - "V2" -> - Decode.succeed V2 - - "V3" -> - Decode.succeed V3 - - "V4" -> - Decode.succeed V4 - - "M4" -> - Decode.succeed M4 - - "Texture" -> - Decode.succeed Texture +typesCodec : Codec e Types +typesCodec = + Serialize.customType + (\typesCodecEncoder (Types attribute uniform varying) -> + typesCodecEncoder attribute uniform varying + ) + |> Serialize.variant3 + Types + (S.assocListDict compare Serialize.string typeCodec) + (S.assocListDict compare Serialize.string typeCodec) + (S.assocListDict compare Serialize.string typeCodec) + |> Serialize.finishCustomType - _ -> - Decode.fail ("Unknown Type: " ++ str) - ) +typeCodec : Codec e Type +typeCodec = + Serialize.customType + (\intEncoder floatEncoder v2Encoder v3Encoder v4Encoder m4Encoder textureEncoder value -> + case value of + Int -> + intEncoder + Float -> + floatEncoder --- COPIED FROM JSON.DECODEX + V2 -> + v2Encoder + V3 -> + v3Encoder -assocListDict : (k -> k -> Order) -> Decode.Decoder k -> Decode.Decoder v -> Decode.Decoder (Dict k v) -assocListDict keyComparison keyDecoder valueDecoder = - Decode.list (jsonPair keyDecoder valueDecoder) - |> Decode.map (Dict.fromList keyComparison) + V4 -> + v4Encoder + M4 -> + m4Encoder -jsonPair : Decode.Decoder a -> Decode.Decoder b -> Decode.Decoder ( a, b ) -jsonPair firstDecoder secondDecoder = - Decode.map2 Tuple.pair - (Decode.field "a" firstDecoder) - (Decode.field "b" secondDecoder) + Texture -> + textureEncoder + ) + |> Serialize.variant0 Int + |> Serialize.variant0 Float + |> Serialize.variant0 V2 + |> Serialize.variant0 V3 + |> Serialize.variant0 V4 + |> Serialize.variant0 M4 + |> Serialize.variant0 Texture + |> Serialize.finishCustomType diff --git a/src/Compiler/Data/Index.elm b/src/Compiler/Data/Index.elm index 9d49b8b1e..6b83e7012 100644 --- a/src/Compiler/Data/Index.elm +++ b/src/Compiler/Data/Index.elm @@ -10,12 +10,8 @@ module Compiler.Data.Index exposing , toHuman , toMachine , zeroBasedCodec - , zeroBasedDecoder - , zeroBasedEncoder ) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -105,16 +101,6 @@ indexedZipWithHelp func index listX listY revListZ = -- ENCODERS and DECODERS -zeroBasedEncoder : ZeroBased -> Encode.Value -zeroBasedEncoder (ZeroBased zeroBased) = - Encode.int zeroBased - - -zeroBasedDecoder : Decode.Decoder ZeroBased -zeroBasedDecoder = - Decode.map ZeroBased Decode.int - - zeroBasedCodec : Codec e ZeroBased zeroBasedCodec = Serialize.int |> Serialize.map ZeroBased (\(ZeroBased zeroBased) -> zeroBased) diff --git a/src/Compiler/Elm/Compiler/Type.elm b/src/Compiler/Elm/Compiler/Type.elm index a26cebd72..6f4cd625f 100644 --- a/src/Compiler/Elm/Compiler/Type.elm +++ b/src/Compiler/Elm/Compiler/Type.elm @@ -3,11 +3,10 @@ module Compiler.Elm.Compiler.Type exposing , DebugMetadata(..) , Type(..) , Union(..) + , codec , decoder , encode , encodeMetadata - , jsonDecoder - , jsonEncoder , toDoc ) @@ -22,8 +21,7 @@ import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D import Compiler.Reporting.Render.Type as RT import Compiler.Reporting.Render.Type.Localizer as L -import Json.Decode as Decode -import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) @@ -202,84 +200,40 @@ toVariantObject ( name, args ) = -- ENCODERS and DECODERS -jsonEncoder : Type -> Encode.Value -jsonEncoder type_ = - case type_ of - Lambda arg body -> - Encode.object - [ ( "type", Encode.string "Lambda" ) - , ( "arg", jsonEncoder arg ) - , ( "body", jsonEncoder body ) - ] +codec : Codec e Type +codec = + Serialize.customType + (\lambdaEncoder varEncoder typeEncoder recordEncoder unitEncoder tupleEncoder value -> + case value of + Lambda arg body -> + lambdaEncoder arg body - Var name -> - Encode.object - [ ( "type", Encode.string "Var" ) - , ( "name", Encode.string name ) - ] + Var name -> + varEncoder name - Type name args -> - Encode.object - [ ( "type", Encode.string "Type" ) - , ( "name", Encode.string name ) - , ( "args", Encode.list jsonEncoder args ) - ] + Type name args -> + typeEncoder name args - Record fields ext -> - Encode.object - [ ( "type", Encode.string "Record" ) - , ( "fields", Encode.list (E.jsonPair Encode.string jsonEncoder) fields ) - , ( "ext", E.maybe Encode.string ext ) - ] + Record fields ext -> + recordEncoder fields ext - Unit -> - Encode.object - [ ( "type", Encode.string "Unit" ) - ] + Unit -> + unitEncoder - Tuple a b cs -> - Encode.object - [ ( "type", Encode.string "Tuple" ) - , ( "a", jsonEncoder a ) - , ( "b", jsonEncoder b ) - , ( "cs", Encode.list jsonEncoder cs ) - ] - - -jsonDecoder : Decode.Decoder Type -jsonDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Lambda" -> - Decode.map2 Lambda - (Decode.field "arg" jsonDecoder) - (Decode.field "body" jsonDecoder) - - "Var" -> - Decode.map Var - (Decode.field "name" Decode.string) - - "Type" -> - Decode.map2 Type - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list jsonDecoder)) - - "Record" -> - Decode.map2 Record - (Decode.field "fields" (Decode.list (D.jsonPair Decode.string jsonDecoder))) - (Decode.field "ext" (Decode.maybe Decode.string)) - - "Unit" -> - Decode.succeed Unit - - "Tuple" -> - Decode.map3 Tuple - (Decode.field "a" jsonDecoder) - (Decode.field "b" jsonDecoder) - (Decode.field "cs" (Decode.list jsonDecoder)) - - _ -> - Decode.fail ("Failed to decode Type's type: " ++ type_) - ) + Tuple a b cs -> + tupleEncoder a b cs + ) + |> Serialize.variant2 Lambda (Serialize.lazy (\() -> codec)) (Serialize.lazy (\() -> codec)) + |> Serialize.variant1 Var Serialize.string + |> Serialize.variant2 Type Serialize.string (Serialize.list (Serialize.lazy (\() -> codec))) + |> Serialize.variant2 + Record + (Serialize.list (Serialize.tuple Serialize.string (Serialize.lazy (\() -> codec)))) + (Serialize.maybe Serialize.string) + |> Serialize.variant0 Unit + |> Serialize.variant3 + Tuple + (Serialize.lazy (\() -> codec)) + (Serialize.lazy (\() -> codec)) + (Serialize.list (Serialize.lazy (\() -> codec))) + |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/Compiler/Type/Extract.elm b/src/Compiler/Elm/Compiler/Type/Extract.elm index 17a133e51..b879b17b7 100644 --- a/src/Compiler/Elm/Compiler/Type/Extract.elm +++ b/src/Compiler/Elm/Compiler/Type/Extract.elm @@ -8,8 +8,6 @@ module Compiler.Elm.Compiler.Type.Extract exposing , merge , mergeMany , typesCodec - , typesDecoder - , typesEncoder ) import Compiler.AST.Canonical as Can @@ -19,12 +17,9 @@ import Compiler.Data.Name as Name import Compiler.Elm.Compiler.Type as T import Compiler.Elm.Interface as I import Compiler.Elm.ModuleName as ModuleName -import Compiler.Json.Decode as D -import Compiler.Json.Encode as E +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode -import Json.Encode as Encode import Maybe.Extra as Maybe import Serialize exposing (Codec) import System.TypeCheck.IO as IO @@ -317,32 +312,24 @@ tupleTraverse f ( a, b ) = -- ENCODERS and DECODERS -typesEncoder : Types -> Encode.Value -typesEncoder (Types types) = - E.assocListDict ModuleName.canonicalEncoder types_Encoder types - - -typesDecoder : Decode.Decoder Types -typesDecoder = - Decode.map Types (D.assocListDict ModuleName.compareCanonical ModuleName.canonicalDecoder types_Decoder) - - typesCodec : Codec e Types typesCodec = - Debug.todo "typesCodec" - - -types_Encoder : Types_ -> Encode.Value -types_Encoder (Types_ unionInfo aliasInfo) = - Encode.object - [ ( "type", Encode.string "Types_" ) - , ( "unionInfo", E.assocListDict Encode.string Can.unionEncoder unionInfo ) - , ( "aliasInfo", E.assocListDict Encode.string Can.aliasEncoder aliasInfo ) - ] + Serialize.customType + (\typesCodecEncoder (Types types) -> + typesCodecEncoder types + ) + |> Serialize.variant1 Types (S.assocListDict ModuleName.compareCanonical ModuleName.canonicalCodec types_Codec) + |> Serialize.finishCustomType -types_Decoder : Decode.Decoder Types_ -types_Decoder = - Decode.map2 Types_ - (Decode.field "unionInfo" (D.assocListDict compare Decode.string Can.unionDecoder)) - (Decode.field "aliasInfo" (D.assocListDict compare Decode.string Can.aliasDecoder)) +types_Codec : Codec e Types_ +types_Codec = + Serialize.customType + (\types_CodecEncoder (Types_ unionInfo aliasInfo) -> + types_CodecEncoder unionInfo aliasInfo + ) + |> Serialize.variant2 + Types_ + (S.assocListDict compare Serialize.string Can.unionCodec) + (S.assocListDict compare Serialize.string Can.aliasCodec) + |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/Docs.elm b/src/Compiler/Elm/Docs.elm index b6e41c609..fed8d27e1 100644 --- a/src/Compiler/Elm/Docs.elm +++ b/src/Compiler/Elm/Docs.elm @@ -11,11 +11,7 @@ module Compiler.Elm.Docs exposing , encode , fromModule , jsonCodec - , jsonDecoder - , jsonEncoder - , jsonModuleCodec - , jsonModuleDecoder - , jsonModuleEncoder + , moduleCodec ) import Basics.Extra exposing (flip) @@ -38,9 +34,8 @@ import Compiler.Parse.Variable as Var import Compiler.Reporting.Annotation as A import Compiler.Reporting.Error.Docs as E import Compiler.Reporting.Result as Result +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO as IO import Utils.Main as Utils @@ -774,112 +769,67 @@ addDef types def = -- ENCODERS and DECODERS -jsonEncoder : Documentation -> Encode.Value -jsonEncoder = - E.toJsonValue << encode - - -jsonDecoder : Decode.Decoder Documentation -jsonDecoder = - Decode.map toDict (Decode.list jsonModuleDecoder) - - jsonCodec : Codec e Documentation jsonCodec = - Debug.todo "jsonCodec" - - -jsonModuleEncoder : Module -> Encode.Value -jsonModuleEncoder (Module name comment unions aliases values binops) = - Encode.object - [ ( "name", Encode.string name ) - , ( "comment", Encode.string comment ) - , ( "unions", E.assocListDict Encode.string jsonUnionEncoder unions ) - , ( "aliases", E.assocListDict Encode.string jsonAliasEncoder aliases ) - , ( "values", E.assocListDict Encode.string jsonValueEncoder values ) - , ( "binops", E.assocListDict Encode.string jsonBinopEncoder binops ) - ] - - -jsonModuleDecoder : Decode.Decoder Module -jsonModuleDecoder = - Decode.map6 Module - (Decode.field "name" Decode.string) - (Decode.field "comment" Decode.string) - (Decode.field "unions" (D.assocListDict compare Decode.string jsonUnionDecoder)) - (Decode.field "aliases" (D.assocListDict compare Decode.string jsonAliasDecoder)) - (Decode.field "values" (D.assocListDict compare Decode.string jsonValueDecoder)) - (Decode.field "binops" (D.assocListDict compare Decode.string jsonBinopDecoder)) - - -jsonModuleCodec : Codec e Module -jsonModuleCodec = - Debug.todo "jsonModuleCodec" - - -jsonUnionEncoder : Union -> Encode.Value -jsonUnionEncoder (Union comment args cases) = - Encode.object - [ ( "comment", Encode.string comment ) - , ( "args", Encode.list Encode.string args ) - , ( "cases", Encode.list (E.jsonPair Encode.string (Encode.list Type.jsonEncoder)) cases ) - ] - - -jsonUnionDecoder : Decode.Decoder Union -jsonUnionDecoder = - Decode.map3 Union - (Decode.field "comment" Decode.string) - (Decode.field "args" (Decode.list Decode.string)) - (Decode.field "cases" (Decode.list (D.jsonPair Decode.string (Decode.list Type.jsonDecoder)))) + S.assocListDict compare Serialize.string moduleCodec -jsonAliasEncoder : Alias -> Encode.Value -jsonAliasEncoder (Alias comment args type_) = - Encode.object - [ ( "comment", Encode.string comment ) - , ( "args", Encode.list Encode.string args ) - , ( "type", Type.jsonEncoder type_ ) - ] - - -jsonAliasDecoder : Decode.Decoder Alias -jsonAliasDecoder = - Decode.map3 Alias - (Decode.field "comment" Decode.string) - (Decode.field "args" (Decode.list Decode.string)) - (Decode.field "type" Type.jsonDecoder) - - -jsonValueEncoder : Value -> Encode.Value -jsonValueEncoder (Value comment type_) = - Encode.object - [ ( "comment", Encode.string comment ) - , ( "type", Type.jsonEncoder type_ ) - ] - - -jsonValueDecoder : Decode.Decoder Value -jsonValueDecoder = - Decode.map2 Value - (Decode.field "comment" Decode.string) - (Decode.field "type" Type.jsonDecoder) +moduleCodec : Codec e Module +moduleCodec = + Serialize.customType + (\moduleEncoder (Module name comment unions aliases values binops) -> + moduleEncoder name comment unions aliases values binops + ) + |> Serialize.variant6 + 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) + |> Serialize.finishCustomType + + +unionCodec : Codec e Union +unionCodec = + Serialize.customType + (\unionEncoder (Union comment args cases) -> + unionEncoder comment args cases + ) + |> Serialize.variant3 + Union + Serialize.string + (Serialize.list Serialize.string) + (Serialize.list (Serialize.tuple Serialize.string (Serialize.list Type.codec))) + |> Serialize.finishCustomType + + +aliasCodec : Codec e Alias +aliasCodec = + Serialize.customType + (\aliasEncoder (Alias comment args type_) -> + aliasEncoder comment args type_ + ) + |> Serialize.variant3 Alias Serialize.string (Serialize.list Serialize.string) Type.codec + |> Serialize.finishCustomType -jsonBinopEncoder : Binop -> Encode.Value -jsonBinopEncoder (Binop comment type_ associativity precedence) = - Encode.object - [ ( "comment", Encode.string comment ) - , ( "type", Type.jsonEncoder type_ ) - , ( "associativity", Binop.associativityEncoder associativity ) - , ( "precedence", Binop.precedenceEncoder precedence ) - ] +valueCodec : Codec e Value +valueCodec = + Serialize.customType + (\valueEncoder (Value comment type_) -> + valueEncoder comment type_ + ) + |> Serialize.variant2 Value Serialize.string Type.codec + |> Serialize.finishCustomType -jsonBinopDecoder : Decode.Decoder Binop -jsonBinopDecoder = - Decode.map4 Binop - (Decode.field "comment" Decode.string) - (Decode.field "type" Type.jsonDecoder) - (Decode.field "associativity" Binop.associativityDecoder) - (Decode.field "precedence" Binop.precedenceDecoder) +binopCodec : Codec e Binop +binopCodec = + Serialize.customType + (\binopEncoder (Binop comment type_ associativity precedence) -> + binopEncoder comment type_ associativity precedence + ) + |> Serialize.variant4 Binop Serialize.string Type.codec Binop.associativityCodec Binop.precedenceCodec + |> Serialize.finishCustomType diff --git a/src/Compiler/Elm/Interface.elm b/src/Compiler/Elm/Interface.elm index 0348c5d2a..10b92eaf3 100644 --- a/src/Compiler/Elm/Interface.elm +++ b/src/Compiler/Elm/Interface.elm @@ -5,14 +5,10 @@ module Compiler.Elm.Interface exposing , Interface(..) , Union(..) , dependencyInterfaceCodec - , dependencyInterfaceDecoder - , dependencyInterfaceEncoder , extractAlias , extractUnion , fromModule , interfaceCodec - , interfaceDecoder - , interfaceEncoder , private , privatize , public @@ -24,13 +20,9 @@ import Compiler.AST.Canonical as Can import Compiler.AST.Utils.Binop as Binop import Compiler.Data.Name as Name import Compiler.Elm.Package as Pkg -import Compiler.Json.Decode as D -import Compiler.Json.Encode as E import Compiler.Reporting.Annotation as A import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import Utils.Crash exposing (crash) import Utils.Main as Utils @@ -211,28 +203,6 @@ privatize di = -- ENCODERS and DECODERS -interfaceEncoder : Interface -> Encode.Value -interfaceEncoder (Interface home values unions aliases binops) = - Encode.object - [ ( "type", Encode.string "Interface" ) - , ( "home", Pkg.nameEncoder home ) - , ( "values", E.assocListDict Encode.string Can.annotationEncoder values ) - , ( "unions", E.assocListDict Encode.string unionEncoder unions ) - , ( "aliases", E.assocListDict Encode.string aliasEncoder aliases ) - , ( "binops", E.assocListDict Encode.string binopEncoder binops ) - ] - - -interfaceDecoder : Decode.Decoder Interface -interfaceDecoder = - Decode.map5 Interface - (Decode.field "home" Pkg.nameDecoder) - (Decode.field "values" (D.assocListDict compare Decode.string Can.annotationDecoder)) - (Decode.field "unions" (D.assocListDict compare Decode.string unionDecoder)) - (Decode.field "aliases" (D.assocListDict compare Decode.string aliasDecoder)) - (Decode.field "binops" (D.assocListDict compare Decode.string binopDecoder)) - - interfaceCodec : Codec e Interface interfaceCodec = Serialize.customType @@ -248,51 +218,6 @@ interfaceCodec = |> Serialize.finishCustomType -unionEncoder : Union -> Encode.Value -unionEncoder union_ = - case union_ of - OpenUnion union -> - Encode.object - [ ( "type", Encode.string "OpenUnion" ) - , ( "union", Can.unionEncoder union ) - ] - - ClosedUnion union -> - Encode.object - [ ( "type", Encode.string "ClosedUnion" ) - , ( "union", Can.unionEncoder union ) - ] - - PrivateUnion union -> - Encode.object - [ ( "type", Encode.string "ClosedUnion" ) - , ( "union", Can.unionEncoder union ) - ] - - -unionDecoder : Decode.Decoder Union -unionDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "OpenUnion" -> - Decode.map OpenUnion - (Decode.field "union" Can.unionDecoder) - - "ClosedUnion" -> - Decode.map ClosedUnion - (Decode.field "union" Can.unionDecoder) - - "PrivateUnion" -> - Decode.map ClosedUnion - (Decode.field "union" Can.unionDecoder) - - _ -> - Decode.fail ("Unknown Union's type: " ++ type_) - ) - - unionCodec : Codec e Union unionCodec = Serialize.customType @@ -313,41 +238,6 @@ unionCodec = |> Serialize.finishCustomType -aliasEncoder : Alias -> Encode.Value -aliasEncoder aliasValue = - case aliasValue of - PublicAlias alias_ -> - Encode.object - [ ( "type", Encode.string "PublicAlias" ) - , ( "alias", Can.aliasEncoder alias_ ) - ] - - PrivateAlias alias_ -> - Encode.object - [ ( "type", Encode.string "PrivateAlias" ) - , ( "alias", Can.aliasEncoder alias_ ) - ] - - -aliasDecoder : Decode.Decoder Alias -aliasDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PublicAlias" -> - Decode.map PublicAlias - (Decode.field "alias" Can.aliasDecoder) - - "PrivateAlias" -> - Decode.map PrivateAlias - (Decode.field "alias" Can.aliasDecoder) - - _ -> - Decode.fail ("Unknown Alias' type: " ++ type_) - ) - - aliasCodec : Codec e Alias aliasCodec = Serialize.customType @@ -364,26 +254,6 @@ aliasCodec = |> Serialize.finishCustomType -binopEncoder : Binop -> Encode.Value -binopEncoder (Binop name annotation associativity precedence) = - Encode.object - [ ( "type", Encode.string "Binop" ) - , ( "name", Encode.string name ) - , ( "annotation", Can.annotationEncoder annotation ) - , ( "associativity", Binop.associativityEncoder associativity ) - , ( "precedence", Binop.precedenceEncoder precedence ) - ] - - -binopDecoder : Decode.Decoder Binop -binopDecoder = - Decode.map4 Binop - (Decode.field "name" Decode.string) - (Decode.field "annotation" Can.annotationDecoder) - (Decode.field "associativity" Binop.associativityDecoder) - (Decode.field "precedence" Binop.precedenceDecoder) - - binopCodec : Codec e Binop binopCodec = Serialize.customType @@ -394,44 +264,6 @@ binopCodec = |> Serialize.finishCustomType -dependencyInterfaceEncoder : DependencyInterface -> Encode.Value -dependencyInterfaceEncoder dependencyInterface = - case dependencyInterface of - Public i -> - Encode.object - [ ( "type", Encode.string "Public" ) - , ( "i", interfaceEncoder i ) - ] - - Private pkg unions aliases -> - Encode.object - [ ( "type", Encode.string "Private" ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "unions", E.assocListDict Encode.string Can.unionEncoder unions ) - , ( "aliases", E.assocListDict Encode.string Can.aliasEncoder aliases ) - ] - - -dependencyInterfaceDecoder : Decode.Decoder DependencyInterface -dependencyInterfaceDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Public" -> - Decode.map Public (Decode.field "i" interfaceDecoder) - - "Private" -> - Decode.map3 Private - (Decode.field "pkg" Pkg.nameDecoder) - (Decode.field "unions" (D.assocListDict compare Decode.string Can.unionDecoder)) - (Decode.field "aliases" (D.assocListDict compare Decode.string Can.aliasDecoder)) - - _ -> - Decode.fail ("Failed to decode DependencyInterface's type: " ++ type_) - ) - - dependencyInterfaceCodec : Codec e DependencyInterface dependencyInterfaceCodec = Serialize.customType diff --git a/src/Compiler/Elm/Kernel.elm b/src/Compiler/Elm/Kernel.elm index 5a8942660..70d81bcb9 100644 --- a/src/Compiler/Elm/Kernel.elm +++ b/src/Compiler/Elm/Kernel.elm @@ -3,8 +3,6 @@ module Compiler.Elm.Kernel exposing , Content(..) , Foreigns , chunkCodec - , chunkDecoder - , chunkEncoder , countFields , fromByteString ) @@ -19,8 +17,6 @@ import Compiler.Parse.Space as Space import Compiler.Parse.Variable as Var import Compiler.Reporting.Annotation as A import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO as IO import Utils.Crash exposing (crash) @@ -419,97 +415,6 @@ toName exposed = -- ENCODERS and DECODERS -chunkEncoder : Chunk -> Encode.Value -chunkEncoder chunk = - case chunk of - JS javascript -> - Encode.object - [ ( "type", Encode.string "JS" ) - , ( "javascript", Encode.string javascript ) - ] - - ElmVar home name -> - Encode.object - [ ( "type", Encode.string "ElmVar" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - ] - - JsVar home name -> - Encode.object - [ ( "type", Encode.string "JsVar" ) - , ( "home", Encode.string home ) - , ( "name", Encode.string name ) - ] - - ElmField name -> - Encode.object - [ ( "type", Encode.string "ElmField" ) - , ( "name", Encode.string name ) - ] - - JsField int -> - Encode.object - [ ( "type", Encode.string "JsField" ) - , ( "int", Encode.int int ) - ] - - JsEnum int -> - Encode.object - [ ( "type", Encode.string "JsEnum" ) - , ( "int", Encode.int int ) - ] - - Debug -> - Encode.object - [ ( "type", Encode.string "Debug" ) - ] - - Prod -> - Encode.object - [ ( "type", Encode.string "Prod" ) - ] - - -chunkDecoder : Decode.Decoder Chunk -chunkDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "JS" -> - Decode.map JS (Decode.field "javascript" Decode.string) - - "ElmVar" -> - Decode.map2 ElmVar - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - - "JsVar" -> - Decode.map2 JsVar - (Decode.field "home" Decode.string) - (Decode.field "name" Decode.string) - - "ElmField" -> - Decode.map ElmField (Decode.field "name" Decode.string) - - "JsField" -> - Decode.map JsField (Decode.field "int" Decode.int) - - "JsEnum" -> - Decode.map JsEnum (Decode.field "int" Decode.int) - - "Debug" -> - Decode.succeed Debug - - "Prod" -> - Decode.succeed Prod - - _ -> - Decode.fail ("Unknown Chunk's type: " ++ type_) - ) - - chunkCodec : Codec e Chunk chunkCodec = Serialize.customType diff --git a/src/Compiler/Elm/ModuleName.elm b/src/Compiler/Elm/ModuleName.elm index 8509afe54..23d76b282 100644 --- a/src/Compiler/Elm/ModuleName.elm +++ b/src/Compiler/Elm/ModuleName.elm @@ -3,8 +3,6 @@ module Compiler.Elm.ModuleName exposing , array , basics , canonicalCodec - , canonicalDecoder - , canonicalEncoder , char , cmd , compareCanonical @@ -19,8 +17,6 @@ module Compiler.Elm.ModuleName exposing , maybe , platform , rawCodec - , rawDecoder - , rawEncoder , result , string , sub @@ -42,8 +38,6 @@ import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P import Compiler.Parse.Variable as Var -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO exposing (Canonical(..)) @@ -317,21 +311,6 @@ matrix4 = -- ENCODERS and DECODERS -canonicalEncoder : Canonical -> Encode.Value -canonicalEncoder (Canonical pkgName name) = - Encode.object - [ ( "pkgName", Pkg.nameEncoder pkgName ) - , ( "name", Encode.string name ) - ] - - -canonicalDecoder : Decode.Decoder Canonical -canonicalDecoder = - Decode.map2 Canonical - (Decode.field "pkgName" Pkg.nameDecoder) - (Decode.field "name" Decode.string) - - canonicalCodec : Codec e Canonical canonicalCodec = Serialize.customType @@ -342,16 +321,6 @@ canonicalCodec = |> Serialize.finishCustomType -rawEncoder : Raw -> Encode.Value -rawEncoder = - Encode.string - - -rawDecoder : Decode.Decoder Raw -rawDecoder = - Decode.string - - rawCodec : Codec e Raw rawCodec = Serialize.string diff --git a/src/Compiler/Elm/Package.elm b/src/Compiler/Elm/Package.elm index c3fcc8279..9bfa85907 100644 --- a/src/Compiler/Elm/Package.elm +++ b/src/Compiler/Elm/Package.elm @@ -15,8 +15,6 @@ module Compiler.Elm.Package exposing , keyDecoder , linearAlgebra , nameCodec - , nameDecoder - , nameEncoder , nearbyNames , parser , suggestions @@ -33,8 +31,6 @@ import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P exposing (Col, Row) import Compiler.Reporting.Suggest as Suggest import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -371,21 +367,6 @@ chompName isGoodChar src pos end prevWasDash = -- ENCODERS and DECODERS -nameEncoder : Name -> Encode.Value -nameEncoder ( author, project ) = - Encode.object - [ ( "author", Encode.string author ) - , ( "project", Encode.string project ) - ] - - -nameDecoder : Decode.Decoder Name -nameDecoder = - Decode.map2 Tuple.pair - (Decode.field "author" Decode.string) - (Decode.field "project" Decode.string) - - nameCodec : Codec e Name nameCodec = Serialize.customType diff --git a/src/Compiler/Elm/Version.elm b/src/Compiler/Elm/Version.elm index 206960ffc..9e76ac67d 100644 --- a/src/Compiler/Elm/Version.elm +++ b/src/Compiler/Elm/Version.elm @@ -8,8 +8,6 @@ module Compiler.Elm.Version exposing , decoder , encode , jsonCodec - , jsonDecoder - , jsonEncoder , major , max , maxVersion @@ -18,15 +16,11 @@ module Compiler.Elm.Version exposing , parser , toChars , versionCodec - , versionDecoder - , versionEncoder ) import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P exposing (Col, Row) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -230,25 +224,6 @@ isDigit word = -- ENCODERS and DECODERS -jsonEncoder : Version -> Encode.Value -jsonEncoder version = - Encode.string (toChars version) - - -jsonDecoder : Decode.Decoder Version -jsonDecoder = - Decode.string - |> Decode.andThen - (\str -> - case P.fromByteString parser Tuple.pair str of - Ok version -> - Decode.succeed version - - Err _ -> - Decode.fail "failed to parse version" - ) - - jsonCodec : Codec e Version jsonCodec = Serialize.customType @@ -259,24 +234,6 @@ jsonCodec = |> Serialize.finishCustomType -versionEncoder : Version -> Encode.Value -versionEncoder (Version major_ minor patch) = - Encode.object - [ ( "type", Encode.string "Version" ) - , ( "major", Encode.int major_ ) - , ( "minor", Encode.int minor ) - , ( "patch", Encode.int patch ) - ] - - -versionDecoder : Decode.Decoder Version -versionDecoder = - Decode.map3 Version - (Decode.field "major" Decode.int) - (Decode.field "minor" Decode.int) - (Decode.field "patch" Decode.int) - - versionCodec : Codec e Version versionCodec = Serialize.customType diff --git a/src/Compiler/Nitpick/PatternMatches.elm b/src/Compiler/Nitpick/PatternMatches.elm index 1ed49135f..c88d021be 100644 --- a/src/Compiler/Nitpick/PatternMatches.elm +++ b/src/Compiler/Nitpick/PatternMatches.elm @@ -5,8 +5,6 @@ module Compiler.Nitpick.PatternMatches exposing , Pattern(..) , check , errorCodec - , errorDecoder - , errorEncoder ) {- The algorithm used here comes from "Warnings for Pattern Matching" @@ -23,8 +21,6 @@ import Compiler.Data.NonEmptyList as NE import Compiler.Elm.ModuleName as ModuleName import Compiler.Reporting.Annotation as A import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import List.Extra as List import Prelude import Serialize exposing (Codec) @@ -714,170 +710,81 @@ collectCtorsHelp ctors row = -- ENCODERS and DECODERS -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - Incomplete region context unhandled -> - Encode.object - [ ( "type", Encode.string "Incomplete" ) - , ( "region", A.regionEncoder region ) - , ( "context", contextEncoder context ) - , ( "unhandled", Encode.list patternEncoder unhandled ) - ] - - Redundant caseRegion patternRegion index -> - Encode.object - [ ( "type", Encode.string "Redundant" ) - , ( "caseRegion", A.regionEncoder caseRegion ) - , ( "patternRegion", A.regionEncoder patternRegion ) - , ( "index", Encode.int index ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Incomplete" -> - Decode.map3 Incomplete - (Decode.field "region" A.regionDecoder) - (Decode.field "context" contextDecoder) - (Decode.field "unhandled" (Decode.list patternDecoder)) - - "Redundant" -> - Decode.map3 Redundant - (Decode.field "caseRegion" A.regionDecoder) - (Decode.field "patternRegion" A.regionDecoder) - (Decode.field "index" Decode.int) - - _ -> - Decode.fail ("Unknown Error's type: " ++ type_) - ) - - errorCodec : Codec e Error errorCodec = - Debug.todo "errorCodec" - - -contextEncoder : Context -> Encode.Value -contextEncoder context = - case context of - BadArg -> - Encode.string "BadArg" - - BadDestruct -> - Encode.string "BadDestruct" - - BadCase -> - Encode.string "BadCase" - - -contextDecoder : Decode.Decoder Context -contextDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "BadArg" -> - Decode.succeed BadArg - - "BadDestruct" -> - Decode.succeed BadDestruct - - "BadCase" -> - Decode.succeed BadCase - - _ -> - Decode.fail ("Unknown Context: " ++ str) - ) - - -patternEncoder : Pattern -> Encode.Value -patternEncoder pattern = - case pattern of - Anything -> - Encode.object - [ ( "type", Encode.string "Anything" ) - ] - - Literal index -> - Encode.object - [ ( "type", Encode.string "Literal" ) - , ( "index", literalEncoder index ) - ] - - Ctor union name args -> - Encode.object - [ ( "type", Encode.string "Ctor" ) - , ( "union", Can.unionEncoder union ) - , ( "name", Encode.string name ) - , ( "args", Encode.list patternEncoder args ) - ] - - -patternDecoder : Decode.Decoder Pattern -patternDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Anything" -> - Decode.succeed Anything - - "Literal" -> - Decode.map Literal (Decode.field "index" literalDecoder) - - "Ctor" -> - Decode.map3 Ctor - (Decode.field "union" Can.unionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list patternDecoder)) - - _ -> - Decode.fail ("Unknown Pattern's type: " ++ type_) - ) - - -literalEncoder : Literal -> Encode.Value -literalEncoder literal = - case literal of - Chr value -> - Encode.object - [ ( "type", Encode.string "Chr" ) - , ( "value", Encode.string value ) - ] - - Str value -> - Encode.object - [ ( "type", Encode.string "Str" ) - , ( "value", Encode.string value ) - ] - - Int value -> - Encode.object - [ ( "type", Encode.string "Int" ) - , ( "value", Encode.int value ) - ] - - -literalDecoder : Decode.Decoder Literal -literalDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Chr" -> - Decode.map Chr (Decode.field "value" Decode.string) - - "Str" -> - Decode.map Str (Decode.field "value" Decode.string) - - "Int" -> - Decode.map Int (Decode.field "value" Decode.int) - - _ -> - Decode.fail ("Unknown Literal's type: " ++ type_) - ) + Serialize.customType + (\incompleteEncoder redundantEncoder value -> + case value of + Incomplete region context unhandled -> + incompleteEncoder region context unhandled + + Redundant caseRegion patternRegion index -> + redundantEncoder caseRegion patternRegion index + ) + |> Serialize.variant3 Incomplete A.regionCodec contextCodec (Serialize.list patternCodec) + |> Serialize.variant3 Redundant A.regionCodec A.regionCodec Serialize.int + |> Serialize.finishCustomType + + +contextCodec : Codec e Context +contextCodec = + Serialize.customType + (\badArgEncoder badDestructEncoder badCaseEncoder value -> + case value of + BadArg -> + badArgEncoder + + BadDestruct -> + badDestructEncoder + + BadCase -> + badCaseEncoder + ) + |> Serialize.variant0 BadArg + |> Serialize.variant0 BadDestruct + |> Serialize.variant0 BadCase + |> Serialize.finishCustomType + + +patternCodec : Codec e Pattern +patternCodec = + Serialize.customType + (\anythingEncoder literalCodecEncoder ctorEncoder value -> + case value of + Anything -> + anythingEncoder + + Literal index -> + literalCodecEncoder index + + Ctor union name args -> + ctorEncoder union name args + ) + |> Serialize.variant0 Anything + |> Serialize.variant1 Literal literalCodec + |> Serialize.variant3 + Ctor + Can.unionCodec + Serialize.string + (Serialize.list (Serialize.lazy (\() -> patternCodec))) + |> Serialize.finishCustomType + + +literalCodec : Codec e Literal +literalCodec = + Serialize.customType + (\chrEncoder strEncoder intEncoder literal -> + case literal of + Chr value -> + chrEncoder value + + Str value -> + strEncoder value + + Int value -> + intEncoder value + ) + |> Serialize.variant1 Chr Serialize.string + |> Serialize.variant1 Str Serialize.string + |> Serialize.variant1 Int Serialize.int + |> Serialize.finishCustomType diff --git a/src/Compiler/Optimize/DecisionTree.elm b/src/Compiler/Optimize/DecisionTree.elm index 88350bb4c..95226443e 100644 --- a/src/Compiler/Optimize/DecisionTree.elm +++ b/src/Compiler/Optimize/DecisionTree.elm @@ -4,11 +4,7 @@ module Compiler.Optimize.DecisionTree exposing , Test(..) , compile , pathCodec - , pathDecoder - , pathEncoder , testCodec - , testDecoder - , testEncoder ) {- To learn more about how this works, definitely read through: @@ -28,8 +24,6 @@ import Compiler.Data.Name as Name import Compiler.Elm.ModuleName as ModuleName import Compiler.Reporting.Annotation as A import Data.Set as EverySet -import Json.Decode as Decode -import Json.Encode as Encode import Prelude import Serialize exposing (Codec) import System.TypeCheck.IO as IO @@ -751,50 +745,6 @@ smallBranchingFactor branches path = -- ENCODERS and DECODERS -pathEncoder : Path -> Encode.Value -pathEncoder path_ = - case path_ of - Index index path -> - Encode.object - [ ( "type", Encode.string "Index" ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "path", pathEncoder path ) - ] - - Unbox path -> - Encode.object - [ ( "type", Encode.string "Unbox" ) - , ( "path", pathEncoder path ) - ] - - Empty -> - Encode.object - [ ( "type", Encode.string "Empty" ) - ] - - -pathDecoder : Decode.Decoder Path -pathDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Index" -> - Decode.map2 Index - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "path" pathDecoder) - - "Unbox" -> - Decode.map Unbox (Decode.field "path" pathDecoder) - - "Empty" -> - Decode.succeed Empty - - _ -> - Decode.fail ("Unknown Path's type: " ++ type_) - ) - - pathCodec : Codec e Path pathCodec = Serialize.customType @@ -815,99 +765,6 @@ pathCodec = |> Serialize.finishCustomType -testEncoder : Test -> Encode.Value -testEncoder test = - case test of - IsCtor home name index numAlts opts -> - Encode.object - [ ( "type", Encode.string "IsCtor" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "numAlts", Encode.int numAlts ) - , ( "opts", Can.ctorOptsEncoder opts ) - ] - - IsCons -> - Encode.object - [ ( "type", Encode.string "IsCons" ) - ] - - IsNil -> - Encode.object - [ ( "type", Encode.string "IsNil" ) - ] - - IsTuple -> - Encode.object - [ ( "type", Encode.string "IsTuple" ) - ] - - IsInt value -> - Encode.object - [ ( "type", Encode.string "IsInt" ) - , ( "value", Encode.int value ) - ] - - IsChr value -> - Encode.object - [ ( "type", Encode.string "IsChr" ) - , ( "value", Encode.string value ) - ] - - IsStr value -> - Encode.object - [ ( "type", Encode.string "IsStr" ) - , ( "value", Encode.string value ) - ] - - IsBool value -> - Encode.object - [ ( "type", Encode.string "IsBool" ) - , ( "value", Encode.bool value ) - ] - - -testDecoder : Decode.Decoder Test -testDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "IsCtor" -> - Decode.map5 IsCtor - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "numAlts" Decode.int) - (Decode.field "opts" Can.ctorOptsDecoder) - - "IsCons" -> - Decode.succeed IsCons - - "IsNil" -> - Decode.succeed IsNil - - "IsTuple" -> - Decode.succeed IsTuple - - "IsInt" -> - Decode.map IsInt (Decode.field "value" Decode.int) - - "IsChr" -> - Decode.map IsChr (Decode.field "value" Decode.string) - - "IsStr" -> - Decode.map IsStr (Decode.field "value" Decode.string) - - "IsBool" -> - Decode.map IsBool (Decode.field "value" Decode.bool) - - _ -> - Decode.fail ("Unknown Test's type: " ++ type_) - ) - - testCodec : Codec e Test testCodec = Serialize.customType @@ -937,14 +794,6 @@ testCodec = IsBool value -> isBoolEncoder value ) - -- Encode.object - -- [ ( "type", Encode.string "IsCtor" ) - -- , ( "home", ModuleName.canonicalEncoder home ) - -- , ( "name", Encode.string name ) - -- , ( "index", Index.zeroBasedEncoder index ) - -- , ( "numAlts", Encode.int numAlts ) - -- , ( "opts", Can.ctorOptsEncoder opts ) - -- ] |> Serialize.variant5 IsCtor ModuleName.canonicalCodec Serialize.string Index.zeroBasedCodec Serialize.int Can.ctorOptsCodec |> Serialize.variant0 IsCons |> Serialize.variant0 IsNil diff --git a/src/Compiler/Parse/Primitives.elm b/src/Compiler/Parse/Primitives.elm index eb679e8cf..ae674d535 100644 --- a/src/Compiler/Parse/Primitives.elm +++ b/src/Compiler/Parse/Primitives.elm @@ -22,8 +22,7 @@ module Compiler.Parse.Primitives exposing , oneOf , oneOfWithFallback , pure - , snippetDecoder - , snippetEncoder + , snippetCodec , specialize , unsafeIndex , withBacksetIndent @@ -33,8 +32,7 @@ module Compiler.Parse.Primitives exposing ) import Compiler.Reporting.Annotation as A -import Json.Decode as Decode -import Json.Encode as Encode +import Serialize exposing (Codec) import Utils.Crash exposing (crash) @@ -389,35 +387,26 @@ getCharWidth word = -- ENCODERS and DECODERS -snippetEncoder : Snippet -> Encode.Value -snippetEncoder (Snippet { fptr, offset, length, offRow, offCol }) = - Encode.object - [ ( "type", Encode.string "Snippet" ) - , ( "fptr", Encode.string fptr ) - , ( "offset", Encode.int offset ) - , ( "length", Encode.int length ) - , ( "offRow", Encode.int offRow ) - , ( "offCol", Encode.int offCol ) - ] - - -snippetDecoder : Decode.Decoder Snippet -snippetDecoder = - Decode.map5 - (\fptr offset length offRow offCol -> - Snippet - { fptr = fptr - , offset = offset - , length = length - , offRow = offRow - , offCol = offCol - } +snippetCodec : Codec e Snippet +snippetCodec = + Serialize.customType + (\snippetCodecEncoder (Snippet snippet) -> + snippetCodecEncoder snippet ) - (Decode.field "fptr" Decode.string) - (Decode.field "offset" Decode.int) - (Decode.field "length" Decode.int) - (Decode.field "offRow" Decode.int) - (Decode.field "offCol" Decode.int) + |> Serialize.variant1 + Snippet + (Serialize.record + (\fptr offset length offRow offCol -> + { fptr = fptr, offset = offset, length = length, offRow = offRow, offCol = offCol } + ) + |> Serialize.field .fptr Serialize.string + |> Serialize.field .offset Serialize.int + |> Serialize.field .length Serialize.int + |> Serialize.field .offRow Serialize.int + |> Serialize.field .offCol Serialize.int + |> Serialize.finishRecord + ) + |> Serialize.finishCustomType diff --git a/src/Compiler/Parse/Symbol.elm b/src/Compiler/Parse/Symbol.elm index 712c80331..87f32069c 100644 --- a/src/Compiler/Parse/Symbol.elm +++ b/src/Compiler/Parse/Symbol.elm @@ -1,8 +1,6 @@ module Compiler.Parse.Symbol exposing ( BadOperator(..) , badOperatorCodec - , badOperatorDecoder - , badOperatorEncoder , binopCharSet , operator ) @@ -10,8 +8,6 @@ module Compiler.Parse.Symbol exposing import Compiler.Data.Name exposing (Name) import Compiler.Parse.Primitives as P exposing (Col, Parser, Row) import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -107,51 +103,6 @@ binopCharSet = -- ENCODERS and DECODERS -badOperatorEncoder : BadOperator -> Encode.Value -badOperatorEncoder badOperator = - case badOperator of - BadDot -> - Encode.string "BadDot" - - BadPipe -> - Encode.string "BadPipe" - - BadArrow -> - Encode.string "BadArrow" - - BadEquals -> - Encode.string "BadEquals" - - BadHasType -> - Encode.string "BadHasType" - - -badOperatorDecoder : Decode.Decoder BadOperator -badOperatorDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "BadDot" -> - Decode.succeed BadDot - - "BadPipe" -> - Decode.succeed BadPipe - - "BadArrow" -> - Decode.succeed BadArrow - - "BadEquals" -> - Decode.succeed BadEquals - - "BadHasType" -> - Decode.succeed BadHasType - - _ -> - Decode.fail ("Unknown BadOperator: " ++ str) - ) - - badOperatorCodec : Codec e BadOperator badOperatorCodec = Serialize.customType diff --git a/src/Compiler/Reporting/Annotation.elm b/src/Compiler/Reporting/Annotation.elm index f5636fd98..43de36501 100644 --- a/src/Compiler/Reporting/Annotation.elm +++ b/src/Compiler/Reporting/Annotation.elm @@ -4,22 +4,16 @@ module Compiler.Reporting.Annotation exposing , Region(..) , at , locatedCodec - , locatedDecoder - , locatedEncoder , merge , mergeRegions , one , regionCodec - , regionDecoder - , regionEncoder , toRegion , toValue , traverse , zero ) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO as IO exposing (IO) @@ -92,22 +86,6 @@ one = -- ENCODERS and DECODERS -regionEncoder : Region -> Encode.Value -regionEncoder (Region start end) = - Encode.object - [ ( "type", Encode.string "Region" ) - , ( "start", positionEncoder start ) - , ( "end", positionEncoder end ) - ] - - -regionDecoder : Decode.Decoder Region -regionDecoder = - Decode.map2 Region - (Decode.field "start" positionDecoder) - (Decode.field "end" positionDecoder) - - regionCodec : Codec e Region regionCodec = Serialize.customType @@ -118,22 +96,6 @@ regionCodec = |> Serialize.finishCustomType -positionEncoder : Position -> Encode.Value -positionEncoder (Position start end) = - Encode.object - [ ( "type", Encode.string "Position" ) - , ( "start", Encode.int start ) - , ( "end", Encode.int end ) - ] - - -positionDecoder : Decode.Decoder Position -positionDecoder = - Decode.map2 Position - (Decode.field "start" Decode.int) - (Decode.field "end" Decode.int) - - positionCodec : Codec e Position positionCodec = Serialize.customType @@ -144,22 +106,11 @@ positionCodec = |> Serialize.finishCustomType -locatedEncoder : (a -> Encode.Value) -> Located a -> Encode.Value -locatedEncoder encoder (At region value) = - Encode.object - [ ( "type", Encode.string "Located" ) - , ( "region", regionEncoder region ) - , ( "value", encoder value ) - ] - - -locatedDecoder : Decode.Decoder a -> Decode.Decoder (Located a) -locatedDecoder decoder = - Decode.map2 At - (Decode.field "region" regionDecoder) - (Decode.field "value" (Decode.lazy (\_ -> decoder))) - - locatedCodec : Codec e a -> Codec e (Located a) -locatedCodec = - Debug.todo "locatedCodec" +locatedCodec a = + Serialize.customType + (\atEncoder (At region value) -> + atEncoder region value + ) + |> Serialize.variant2 At regionCodec a + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Error.elm b/src/Compiler/Reporting/Error.elm index e40b10f20..cf19d89b3 100644 --- a/src/Compiler/Reporting/Error.elm +++ b/src/Compiler/Reporting/Error.elm @@ -1,10 +1,7 @@ module Compiler.Reporting.Error exposing ( Error(..) , Module - , jsonToJson , moduleCodec - , moduleDecoder - , moduleEncoder , toDoc , toJson ) @@ -13,7 +10,6 @@ import Builder.File as File import Compiler.Data.NonEmptyList as NE import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) import Compiler.Elm.ModuleName as ModuleName -import Compiler.Json.Decode as DecodeX import Compiler.Json.Encode as E import Compiler.Nitpick.PatternMatches as P import Compiler.Reporting.Annotation as A @@ -29,8 +25,6 @@ import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Render.Type.Localizer as L import Compiler.Reporting.Report as Report import Compiler.Serialize as S -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import Time import Utils.Main as Utils @@ -242,32 +236,6 @@ encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) = -- ENCODERS and DECODERS -jsonToJson : Module -> Encode.Value -jsonToJson = - E.toJsonValue << toJson - - -moduleEncoder : Module -> Encode.Value -moduleEncoder modul = - Encode.object - [ ( "name", ModuleName.rawEncoder modul.name ) - , ( "absolutePath", Encode.string modul.absolutePath ) - , ( "modificationTime", File.timeEncoder modul.modificationTime ) - , ( "source", Encode.string modul.source ) - , ( "error", errorEncoder modul.error ) - ] - - -moduleDecoder : Decode.Decoder Module -moduleDecoder = - Decode.map5 Module - (Decode.field "name" ModuleName.rawDecoder) - (Decode.field "absolutePath" Decode.string) - (Decode.field "modificationTime" File.timeDecoder) - (Decode.field "source" Decode.string) - (Decode.field "error" errorDecoder) - - moduleCodec : Codec (Serialize.Error e) Module moduleCodec = Serialize.record Module @@ -279,90 +247,6 @@ moduleCodec = |> Serialize.finishRecord -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - BadSyntax syntaxError -> - Encode.object - [ ( "type", Encode.string "BadSyntax" ) - , ( "syntaxError", Syntax.errorEncoder syntaxError ) - ] - - BadImports errs -> - Encode.object - [ ( "type", Encode.string "BadImports" ) - , ( "errs", E.nonempty Import.errorEncoder errs ) - ] - - BadNames errs -> - Encode.object - [ ( "type", Encode.string "BadNames" ) - , ( "errs", E.oneOrMore Canonicalize.errorEncoder errs ) - ] - - BadTypes localizer errs -> - Encode.object - [ ( "type", Encode.string "BadTypes" ) - , ( "localizer", L.localizerEncoder localizer ) - , ( "errs", E.nonempty Type.errorEncoder errs ) - ] - - BadMains localizer errs -> - Encode.object - [ ( "type", Encode.string "BadMains" ) - , ( "localizer", L.localizerEncoder localizer ) - , ( "errs", E.oneOrMore Main.errorEncoder errs ) - ] - - BadPatterns errs -> - Encode.object - [ ( "type", Encode.string "BadPatterns" ) - , ( "errs", E.nonempty P.errorEncoder errs ) - ] - - BadDocs docsErr -> - Encode.object - [ ( "type", Encode.string "BadDocs" ) - , ( "docsErr", Docs.errorEncoder docsErr ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "BadSyntax" -> - Decode.map BadSyntax (Decode.field "syntaxError" Syntax.errorDecoder) - - "BadImports" -> - Decode.map BadImports (Decode.field "errs" (DecodeX.nonempty Import.errorDecoder)) - - "BadNames" -> - Decode.map BadNames (Decode.field "errs" (DecodeX.oneOrMore Canonicalize.errorDecoder)) - - "BadTypes" -> - Decode.map2 BadTypes - (Decode.field "localizer" L.localizerDecoder) - (Decode.field "errs" (DecodeX.nonempty Type.errorDecoder)) - - "BadMains" -> - Decode.map2 BadMains - (Decode.field "localizer" L.localizerDecoder) - (Decode.field "errs" (DecodeX.oneOrMore Main.errorDecoder)) - - "BadPatterns" -> - Decode.map BadPatterns (Decode.field "errs" (DecodeX.nonempty P.errorDecoder)) - - "BadDocs" -> - Decode.map BadDocs (Decode.field "docsErr" Docs.errorDecoder) - - _ -> - Decode.fail ("Unknown Path's type: " ++ type_) - ) - - errorCodec : Codec (Serialize.Error e) Error errorCodec = Serialize.customType diff --git a/src/Compiler/Reporting/Error/Canonicalize.elm b/src/Compiler/Reporting/Error/Canonicalize.elm index 91df8ceff..89e0287aa 100644 --- a/src/Compiler/Reporting/Error/Canonicalize.elm +++ b/src/Compiler/Reporting/Error/Canonicalize.elm @@ -7,10 +7,7 @@ module Compiler.Reporting.Error.Canonicalize exposing , PossibleNames , VarKind(..) , errorCodec - , errorDecoder - , errorEncoder - , invalidPayloadDecoder - , invalidPayloadEncoder + , invalidPayloadCodec , toReport ) @@ -20,18 +17,15 @@ import Compiler.Data.Index as Index import Compiler.Data.Name as Name exposing (Name) import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) import Compiler.Elm.ModuleName as ModuleName -import Compiler.Json.Decode as DecodeX -import Compiler.Json.Encode as EncodeX import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Render.Type as RT import Compiler.Reporting.Report as Report import Compiler.Reporting.Suggest as Suggest +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO as IO @@ -1300,829 +1294,355 @@ aliasToUnionDoc name args tipe = -- ENCODERS and DECODERS -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - AnnotationTooShort region name index leftovers -> - Encode.object - [ ( "type", Encode.string "AnnotationTooShort" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "index", Index.zeroBasedEncoder index ) - , ( "leftovers", Encode.int leftovers ) - ] - - AmbiguousVar region maybePrefix name h hs -> - Encode.object - [ ( "type", Encode.string "AmbiguousVar" ) - , ( "region", A.regionEncoder region ) - , ( "maybePrefix", EncodeX.maybe Encode.string maybePrefix ) - , ( "name", Encode.string name ) - , ( "h", ModuleName.canonicalEncoder h ) - , ( "hs", EncodeX.oneOrMore ModuleName.canonicalEncoder hs ) - ] - - AmbiguousType region maybePrefix name h hs -> - Encode.object - [ ( "type", Encode.string "AmbiguousType" ) - , ( "region", A.regionEncoder region ) - , ( "maybePrefix", EncodeX.maybe Encode.string maybePrefix ) - , ( "name", Encode.string name ) - , ( "h", ModuleName.canonicalEncoder h ) - , ( "hs", EncodeX.oneOrMore ModuleName.canonicalEncoder hs ) - ] - - AmbiguousVariant region maybePrefix name h hs -> - Encode.object - [ ( "type", Encode.string "AmbiguousVariant" ) - , ( "region", A.regionEncoder region ) - , ( "maybePrefix", EncodeX.maybe Encode.string maybePrefix ) - , ( "name", Encode.string name ) - , ( "h", ModuleName.canonicalEncoder h ) - , ( "hs", EncodeX.oneOrMore ModuleName.canonicalEncoder hs ) - ] - - AmbiguousBinop region name h hs -> - Encode.object - [ ( "type", Encode.string "AmbiguousBinop" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "h", ModuleName.canonicalEncoder h ) - , ( "hs", EncodeX.oneOrMore ModuleName.canonicalEncoder hs ) - ] - - BadArity region badArityContext name expected actual -> - Encode.object - [ ( "type", Encode.string "BadArity" ) - , ( "region", A.regionEncoder region ) - , ( "badArityContext", badArityContextEncoder badArityContext ) - , ( "name", Encode.string name ) - , ( "expected", Encode.int expected ) - , ( "actual", Encode.int actual ) - ] - - Binop region op1 op2 -> - Encode.object - [ ( "type", Encode.string "Binop" ) - , ( "region", A.regionEncoder region ) - , ( "op1", Encode.string op1 ) - , ( "op2", Encode.string op2 ) - ] - - DuplicateDecl name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicateDecl" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - DuplicateType name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicateType" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - DuplicateCtor name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicateCtor" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - DuplicateBinop name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicateBinop" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - DuplicateField name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicateField" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - DuplicateAliasArg typeName name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicateAliasArg" ) - , ( "typeName", Encode.string typeName ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - DuplicateUnionArg typeName name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicateUnionArg" ) - , ( "typeName", Encode.string typeName ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - DuplicatePattern context name r1 r2 -> - Encode.object - [ ( "type", Encode.string "DuplicatePattern" ) - , ( "context", duplicatePatternContextEncoder context ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - EffectNotFound region name -> - Encode.object - [ ( "type", Encode.string "EffectNotFound" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - ] - - EffectFunctionNotFound region name -> - Encode.object - [ ( "type", Encode.string "EffectFunctionNotFound" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - ] - - ExportDuplicate name r1 r2 -> - Encode.object - [ ( "type", Encode.string "ExportDuplicate" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - ExportNotFound region kind rawName possibleNames -> - Encode.object - [ ( "type", Encode.string "ExportNotFound" ) - , ( "region", A.regionEncoder region ) - , ( "kind", varKindEncoder kind ) - , ( "rawName", Encode.string rawName ) - , ( "possibleNames", Encode.list Encode.string possibleNames ) - ] - - ExportOpenAlias region name -> - Encode.object - [ ( "type", Encode.string "ExportOpenAlias" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - ] - - ImportCtorByName region ctor tipe -> - Encode.object - [ ( "type", Encode.string "ImportCtorByName" ) - , ( "region", A.regionEncoder region ) - , ( "ctor", Encode.string ctor ) - , ( "tipe", Encode.string tipe ) - ] - - ImportNotFound region name suggestions -> - Encode.object - [ ( "type", Encode.string "ImportNotFound" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "suggestions", Encode.list ModuleName.canonicalEncoder suggestions ) - ] - - ImportOpenAlias region name -> - Encode.object - [ ( "type", Encode.string "ImportOpenAlias" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - ] - - ImportExposingNotFound region home value possibleNames -> - Encode.object - [ ( "type", Encode.string "ImportExposingNotFound" ) - , ( "region", A.regionEncoder region ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "value", Encode.string value ) - , ( "possibleNames", Encode.list Encode.string possibleNames ) - ] - - NotFoundVar region prefix name possibleNames -> - Encode.object - [ ( "type", Encode.string "NotFoundVar" ) - , ( "region", A.regionEncoder region ) - , ( "prefix", EncodeX.maybe Encode.string prefix ) - , ( "name", Encode.string name ) - , ( "possibleNames", possibleNamesEncoder possibleNames ) - ] - - NotFoundType region prefix name possibleNames -> - Encode.object - [ ( "type", Encode.string "NotFoundType" ) - , ( "region", A.regionEncoder region ) - , ( "prefix", EncodeX.maybe Encode.string prefix ) - , ( "name", Encode.string name ) - , ( "possibleNames", possibleNamesEncoder possibleNames ) - ] - - NotFoundVariant region prefix name possibleNames -> - Encode.object - [ ( "type", Encode.string "NotFoundVariant" ) - , ( "region", A.regionEncoder region ) - , ( "prefix", EncodeX.maybe Encode.string prefix ) - , ( "name", Encode.string name ) - , ( "possibleNames", possibleNamesEncoder possibleNames ) - ] - - NotFoundBinop region op locals -> - Encode.object - [ ( "type", Encode.string "NotFoundBinop" ) - , ( "region", A.regionEncoder region ) - , ( "op", Encode.string op ) - , ( "locals", EncodeX.everySet Encode.string locals ) - ] - - PatternHasRecordCtor region name -> - Encode.object - [ ( "type", Encode.string "PatternHasRecordCtor" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - ] - - PortPayloadInvalid region portName badType invalidPayload -> - Encode.object - [ ( "type", Encode.string "PortPayloadInvalid" ) - , ( "region", A.regionEncoder region ) - , ( "portName", Encode.string portName ) - , ( "badType", Can.typeEncoder badType ) - , ( "invalidPayload", invalidPayloadEncoder invalidPayload ) - ] - - PortTypeInvalid region name portProblem -> - Encode.object - [ ( "type", Encode.string "PortTypeInvalid" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "portProblem", portProblemEncoder portProblem ) - ] - - RecursiveAlias region name args tipe others -> - Encode.object - [ ( "type", Encode.string "RecursiveAlias" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "args", Encode.list Encode.string args ) - , ( "tipe", Src.typeEncoder tipe ) - , ( "others", Encode.list Encode.string others ) - ] - - RecursiveDecl region name names -> - Encode.object - [ ( "type", Encode.string "RecursiveDecl" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "names", Encode.list Encode.string names ) - ] - - RecursiveLet name names -> - Encode.object - [ ( "type", Encode.string "RecursiveLet" ) - , ( "name", A.locatedEncoder Encode.string name ) - , ( "names", Encode.list Encode.string names ) - ] - - Shadowing name r1 r2 -> - Encode.object - [ ( "type", Encode.string "Shadowing" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - TupleLargerThanThree region -> - Encode.object - [ ( "type", Encode.string "TupleLargerThanThree" ) - , ( "region", A.regionEncoder region ) - ] - - TypeVarsUnboundInUnion unionRegion typeName allVars unbound unbounds -> - Encode.object - [ ( "type", Encode.string "TypeVarsUnboundInUnion" ) - , ( "unionRegion", A.regionEncoder unionRegion ) - , ( "typeName", Encode.string typeName ) - , ( "allVars", Encode.list Encode.string allVars ) - , ( "unbound", EncodeX.jsonPair Encode.string A.regionEncoder unbound ) - , ( "unbounds", Encode.list (EncodeX.jsonPair Encode.string A.regionEncoder) unbounds ) - ] - - TypeVarsMessedUpInAlias aliasRegion typeName allVars unusedVars unboundVars -> - Encode.object - [ ( "type", Encode.string "TypeVarsMessedUpInAlias" ) - , ( "aliasRegion", A.regionEncoder aliasRegion ) - , ( "typeName", Encode.string typeName ) - , ( "allVars", Encode.list Encode.string allVars ) - , ( "unusedVars", Encode.list (EncodeX.jsonPair Encode.string A.regionEncoder) unusedVars ) - , ( "unboundVars", Encode.list (EncodeX.jsonPair Encode.string A.regionEncoder) unboundVars ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "AnnotationTooShort" -> - Decode.map4 AnnotationTooShort - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "index" Index.zeroBasedDecoder) - (Decode.field "leftovers" Decode.int) - - "AmbiguousVar" -> - Decode.map5 AmbiguousVar - (Decode.field "region" A.regionDecoder) - (Decode.field "maybePrefix" (Decode.maybe Decode.string)) - (Decode.field "name" Decode.string) - (Decode.field "h" ModuleName.canonicalDecoder) - (Decode.field "hs" (DecodeX.oneOrMore ModuleName.canonicalDecoder)) - - "AmbiguousType" -> - Decode.map5 AmbiguousType - (Decode.field "region" A.regionDecoder) - (Decode.field "maybePrefix" (Decode.maybe Decode.string)) - (Decode.field "name" Decode.string) - (Decode.field "h" ModuleName.canonicalDecoder) - (Decode.field "hs" (DecodeX.oneOrMore ModuleName.canonicalDecoder)) - - "AmbiguousVariant" -> - Decode.map5 AmbiguousVariant - (Decode.field "region" A.regionDecoder) - (Decode.field "maybePrefix" (Decode.maybe Decode.string)) - (Decode.field "name" Decode.string) - (Decode.field "h" ModuleName.canonicalDecoder) - (Decode.field "hs" (DecodeX.oneOrMore ModuleName.canonicalDecoder)) - - "AmbiguousBinop" -> - Decode.map4 AmbiguousBinop - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "h" ModuleName.canonicalDecoder) - (Decode.field "hs" (DecodeX.oneOrMore ModuleName.canonicalDecoder)) - - "BadArity" -> - Decode.map5 BadArity - (Decode.field "region" A.regionDecoder) - (Decode.field "badArityContext" badArityContextDecoder) - (Decode.field "name" Decode.string) - (Decode.field "expected" Decode.int) - (Decode.field "actual" Decode.int) - - "Binop" -> - Decode.map3 Binop - (Decode.field "region" A.regionDecoder) - (Decode.field "op1" Decode.string) - (Decode.field "op2" Decode.string) - - "DuplicateDecl" -> - Decode.map3 DuplicateDecl - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "DuplicateType" -> - Decode.map3 DuplicateType - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "DuplicateCtor" -> - Decode.map3 DuplicateCtor - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "DuplicateBinop" -> - Decode.map3 DuplicateBinop - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "DuplicateField" -> - Decode.map3 DuplicateField - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "DuplicateAliasArg" -> - Decode.map4 DuplicateAliasArg - (Decode.field "typeName" Decode.string) - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "DuplicateUnionArg" -> - Decode.map4 DuplicateUnionArg - (Decode.field "typeName" Decode.string) - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "DuplicatePattern" -> - Decode.map4 DuplicatePattern - (Decode.field "context" duplicatePatternContextDecoder) - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "EffectNotFound" -> - Decode.map2 EffectNotFound - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - - "EffectFunctionNotFound" -> - Decode.map2 EffectFunctionNotFound - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - - "ExportDuplicate" -> - Decode.map3 ExportDuplicate - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "ExportNotFound" -> - Decode.map4 ExportNotFound - (Decode.field "region" A.regionDecoder) - (Decode.field "kind" varKindDecoder) - (Decode.field "rawName" Decode.string) - (Decode.field "possibleNames" (Decode.list Decode.string)) - - "ExportOpenAlias" -> - Decode.map2 ExportOpenAlias - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - - "ImportCtorByName" -> - Decode.map3 ImportCtorByName - (Decode.field "region" A.regionDecoder) - (Decode.field "ctor" Decode.string) - (Decode.field "tipe" Decode.string) - - "ImportNotFound" -> - Decode.map3 ImportNotFound - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "suggestions" (Decode.list ModuleName.canonicalDecoder)) - - "ImportOpenAlias" -> - Decode.map2 ImportOpenAlias - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - - "ImportExposingNotFound" -> - Decode.map4 ImportExposingNotFound - (Decode.field "region" A.regionDecoder) - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "value" Decode.string) - (Decode.field "possibleNames" (Decode.list Decode.string)) - - "NotFoundVar" -> - Decode.map4 NotFoundVar - (Decode.field "region" A.regionDecoder) - (Decode.field "prefix" (Decode.maybe Decode.string)) - (Decode.field "name" Decode.string) - (Decode.field "possibleNames" possibleNamesDecoder) - - "NotFoundType" -> - Decode.map4 NotFoundType - (Decode.field "region" A.regionDecoder) - (Decode.field "prefix" (Decode.maybe Decode.string)) - (Decode.field "name" Decode.string) - (Decode.field "possibleNames" possibleNamesDecoder) - - "NotFoundVariant" -> - Decode.map4 NotFoundVariant - (Decode.field "region" A.regionDecoder) - (Decode.field "prefix" (Decode.maybe Decode.string)) - (Decode.field "name" Decode.string) - (Decode.field "possibleNames" possibleNamesDecoder) - - "NotFoundBinop" -> - Decode.map3 NotFoundBinop - (Decode.field "region" A.regionDecoder) - (Decode.field "op" Decode.string) - (Decode.field "locals" (DecodeX.everySet compare Decode.string)) - - "PatternHasRecordCtor" -> - Decode.map2 PatternHasRecordCtor - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - - "PortPayloadInvalid" -> - Decode.map4 PortPayloadInvalid - (Decode.field "region" A.regionDecoder) - (Decode.field "portName" Decode.string) - (Decode.field "badType" Can.typeDecoder) - (Decode.field "invalidPayload" invalidPayloadDecoder) - - "PortTypeInvalid" -> - Decode.map3 PortTypeInvalid - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "portProblem" portProblemDecoder) - - "RecursiveAlias" -> - Decode.map5 RecursiveAlias - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list Decode.string)) - (Decode.field "tipe" Src.typeDecoder) - (Decode.field "others" (Decode.list Decode.string)) - - "RecursiveDecl" -> - Decode.map3 RecursiveDecl - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "names" (Decode.list Decode.string)) - - "RecursiveLet" -> - Decode.map2 RecursiveLet - (Decode.field "name" (A.locatedDecoder Decode.string)) - (Decode.field "names" (Decode.list Decode.string)) - - "Shadowing" -> - Decode.map3 Shadowing - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "TupleLargerThanThree" -> - Decode.map TupleLargerThanThree (Decode.field "region" A.regionDecoder) - - "TypeVarsUnboundInUnion" -> - Decode.map5 TypeVarsUnboundInUnion - (Decode.field "unionRegion" A.regionDecoder) - (Decode.field "typeName" Decode.string) - (Decode.field "allVars" (Decode.list Decode.string)) - (Decode.field "unbound" (DecodeX.jsonPair Decode.string A.regionDecoder)) - (Decode.field "unbounds" (Decode.list (DecodeX.jsonPair Decode.string A.regionDecoder))) - - "TypeVarsMessedUpInAlias" -> - Decode.map5 TypeVarsMessedUpInAlias - (Decode.field "aliasRegion" A.regionDecoder) - (Decode.field "typeName" Decode.string) - (Decode.field "allVars" (Decode.list Decode.string)) - (Decode.field "unusedVars" (Decode.list (DecodeX.jsonPair Decode.string A.regionDecoder))) - (Decode.field "unboundVars" (Decode.list (DecodeX.jsonPair Decode.string A.regionDecoder))) - - _ -> - Decode.fail ("Failed to decode Error's type: " ++ type_) - ) - - errorCodec : Codec e Error errorCodec = - Debug.todo "errorCodec" - - -badArityContextEncoder : BadArityContext -> Encode.Value -badArityContextEncoder badArityContext = - case badArityContext of - TypeArity -> - Encode.string "TypeArity" - - PatternArity -> - Encode.string "PatternArity" - - -badArityContextDecoder : Decode.Decoder BadArityContext -badArityContextDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "TypeArity" -> - Decode.succeed TypeArity - - "PatternArity" -> - Decode.succeed PatternArity - - _ -> - Decode.fail ("Unknown BadArityContext: " ++ str) - ) - - -duplicatePatternContextEncoder : DuplicatePatternContext -> Encode.Value -duplicatePatternContextEncoder duplicatePatternContext = - case duplicatePatternContext of - DPLambdaArgs -> - Encode.object - [ ( "type", Encode.string "DPLambdaArgs" ) - ] - - DPFuncArgs funcName -> - Encode.object - [ ( "type", Encode.string "DPFuncArgs" ) - , ( "funcName", Encode.string funcName ) - ] - - DPCaseBranch -> - Encode.object - [ ( "type", Encode.string "DPCaseBranch" ) - ] - - DPLetBinding -> - Encode.object - [ ( "type", Encode.string "DPLetBinding" ) - ] - - DPDestruct -> - Encode.object - [ ( "type", Encode.string "DPDestruct" ) - ] - - -duplicatePatternContextDecoder : Decode.Decoder DuplicatePatternContext -duplicatePatternContextDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "DPLambdaArgs" -> - Decode.succeed DPLambdaArgs - - "DPFuncArgs" -> - Decode.map DPFuncArgs (Decode.field "funcName" Decode.string) + Serialize.customType + (\annotationTooShortEncoder ambiguousVarEncoder ambiguousTypeEncoder ambiguousVariantEncoder ambiguousBinopEncoder badArityEncoder binopEncoder duplicateDeclEncoder duplicateTypeEncoder duplicateCtorEncoder duplicateBinopEncoder duplicateFieldEncoder duplicateAliasArgEncoder duplicateUnionArgEncoder duplicatePatternEncoder effectNotFoundEncoder effectFunctionNotFoundEncoder exportDuplicateEncoder exportNotFoundEncoder exportOpenAliasEncoder importCtorByNameEncoder importNotFoundEncoder importOpenAliasEncoder importExposingNotFoundEncoder notFoundVarEncoder notFoundTypeEncoder notFoundVariantEncoder notFoundBinopEncoder patternHasRecordCtorEncoder portPayloadInvalidEncoder portTypeInvalidEncoder recursiveAliasEncoder recursiveDeclEncoder recursiveLetEncoder shadowingEncoder tupleLargerThanThreeEncoder typeVarsUnboundInUnionEncoder typeVarsMessedUpInAliasEncoder error -> + case error of + AnnotationTooShort region name index leftovers -> + annotationTooShortEncoder region name index leftovers - "DPCaseBranch" -> - Decode.succeed DPCaseBranch + AmbiguousVar region maybePrefix name h hs -> + ambiguousVarEncoder region maybePrefix name h hs - "DPLetBinding" -> - Decode.succeed DPLetBinding + AmbiguousType region maybePrefix name h hs -> + ambiguousTypeEncoder region maybePrefix name h hs - "DPDestruct" -> - Decode.succeed DPDestruct + AmbiguousVariant region maybePrefix name h hs -> + ambiguousVariantEncoder region maybePrefix name h hs - _ -> - Decode.fail ("Failed to decode DuplicatePatternContext's type: " ++ type_) - ) - - -varKindEncoder : VarKind -> Encode.Value -varKindEncoder varKind = - case varKind of - BadOp -> - Encode.string "BadOp" - - BadVar -> - Encode.string "BadVar" + AmbiguousBinop region name h hs -> + ambiguousBinopEncoder region name h hs - BadPattern -> - Encode.string "BadPattern" - - BadType -> - Encode.string "BadType" + BadArity region badArityContext name expected actual -> + badArityEncoder region badArityContext name expected actual + Binop region op1 op2 -> + binopEncoder region op1 op2 -varKindDecoder : Decode.Decoder VarKind -varKindDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "BadOp" -> - Decode.succeed BadOp + DuplicateDecl name r1 r2 -> + duplicateDeclEncoder name r1 r2 - "BadVar" -> - Decode.succeed BadVar + DuplicateType name r1 r2 -> + duplicateTypeEncoder name r1 r2 - "BadPattern" -> - Decode.succeed BadPattern + DuplicateCtor name r1 r2 -> + duplicateCtorEncoder name r1 r2 - "BadType" -> - Decode.succeed BadType - - _ -> - Decode.fail ("Unknown VarKind: " ++ str) - ) + DuplicateBinop name r1 r2 -> + duplicateBinopEncoder name r1 r2 + DuplicateField name r1 r2 -> + duplicateFieldEncoder name r1 r2 -possibleNamesEncoder : PossibleNames -> Encode.Value -possibleNamesEncoder possibleNames = - Encode.object - [ ( "type", Encode.string "PossibleNames" ) - , ( "locals", EncodeX.everySet Encode.string possibleNames.locals ) - , ( "quals", EncodeX.assocListDict Encode.string (EncodeX.everySet Encode.string) possibleNames.quals ) - ] - - -possibleNamesDecoder : Decode.Decoder PossibleNames -possibleNamesDecoder = - Decode.map2 PossibleNames - (Decode.field "locals" (DecodeX.everySet compare Decode.string)) - (Decode.field "quals" (DecodeX.assocListDict compare Decode.string (DecodeX.everySet compare Decode.string))) - - -invalidPayloadEncoder : InvalidPayload -> Encode.Value -invalidPayloadEncoder invalidPayload = - case invalidPayload of - ExtendedRecord -> - Encode.object - [ ( "type", Encode.string "ExtendedRecord" ) - ] - - Function -> - Encode.object - [ ( "type", Encode.string "Function" ) - ] - - TypeVariable name -> - Encode.object - [ ( "type", Encode.string "TypeVariable" ) - , ( "name", Encode.string name ) - ] - - UnsupportedType name -> - Encode.object - [ ( "type", Encode.string "UnsupportedType" ) - , ( "name", Encode.string name ) - ] + DuplicateAliasArg typeName name r1 r2 -> + duplicateAliasArgEncoder typeName name r1 r2 + DuplicateUnionArg typeName name r1 r2 -> + duplicateUnionArgEncoder typeName name r1 r2 -invalidPayloadDecoder : Decode.Decoder InvalidPayload -invalidPayloadDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ExtendedRecord" -> - Decode.succeed ExtendedRecord + DuplicatePattern context name r1 r2 -> + duplicatePatternEncoder context name r1 r2 - "Function" -> - Decode.succeed Function + EffectNotFound region name -> + effectNotFoundEncoder region name - "TypeVariable" -> - Decode.map TypeVariable (Decode.field "name" Decode.string) - - "UnsupportedType" -> - Decode.map UnsupportedType (Decode.field "name" Decode.string) - - _ -> - Decode.fail ("Failed to decode InvalidPayload's type: " ++ type_) - ) - - -portProblemEncoder : PortProblem -> Encode.Value -portProblemEncoder portProblem = - case portProblem of - CmdNoArg -> - Encode.object - [ ( "type", Encode.string "CmdNoArg" ) - ] - - CmdExtraArgs n -> - Encode.object - [ ( "type", Encode.string "CmdExtraArgs" ) - , ( "n", Encode.int n ) - ] - - CmdBadMsg -> - Encode.object - [ ( "type", Encode.string "CmdBadMsg" ) - ] - - SubBad -> - Encode.object - [ ( "type", Encode.string "SubBad" ) - ] - - NotCmdOrSub -> - Encode.object - [ ( "type", Encode.string "NotCmdOrSub" ) - ] - - -portProblemDecoder : Decode.Decoder PortProblem -portProblemDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "CmdNoArg" -> - Decode.succeed CmdNoArg - - "CmdExtraArgs" -> - Decode.map CmdExtraArgs (Decode.field "n" Decode.int) - - "CmdBadMsg" -> - Decode.succeed CmdBadMsg - - "SubBad" -> - Decode.succeed SubBad - - "NotCmdOrSub" -> - Decode.succeed NotCmdOrSub - - _ -> - Decode.fail ("Failed to decode PortProblem's type: " ++ type_) - ) + EffectFunctionNotFound region name -> + effectFunctionNotFoundEncoder region name + + ExportDuplicate name r1 r2 -> + exportDuplicateEncoder name r1 r2 + + ExportNotFound region kind rawName possibleNames -> + exportNotFoundEncoder region kind rawName possibleNames + + ExportOpenAlias region name -> + exportOpenAliasEncoder region name + + ImportCtorByName region ctor tipe -> + importCtorByNameEncoder region ctor tipe + + ImportNotFound region name suggestions -> + importNotFoundEncoder region name suggestions + + ImportOpenAlias region name -> + importOpenAliasEncoder region name + + ImportExposingNotFound region home value possibleNames -> + importExposingNotFoundEncoder region home value possibleNames + + NotFoundVar region prefix name possibleNames -> + notFoundVarEncoder region prefix name possibleNames + + NotFoundType region prefix name possibleNames -> + notFoundTypeEncoder region prefix name possibleNames + + NotFoundVariant region prefix name possibleNames -> + notFoundVariantEncoder region prefix name possibleNames + + NotFoundBinop region op locals -> + notFoundBinopEncoder region op locals + + PatternHasRecordCtor region name -> + patternHasRecordCtorEncoder region name + + PortPayloadInvalid region portName badType invalidPayload -> + portPayloadInvalidEncoder region portName badType invalidPayload + + PortTypeInvalid region name portProblem -> + portTypeInvalidEncoder region name portProblem + + RecursiveAlias region name args tipe others -> + recursiveAliasEncoder region name args tipe others + + RecursiveDecl region name names -> + recursiveDeclEncoder region name names + + RecursiveLet name names -> + recursiveLetEncoder name names + + Shadowing name r1 r2 -> + shadowingEncoder name r1 r2 + + TupleLargerThanThree region -> + tupleLargerThanThreeEncoder region + + TypeVarsUnboundInUnion unionRegion typeName allVars unbound unbounds -> + typeVarsUnboundInUnionEncoder unionRegion typeName allVars unbound unbounds + + TypeVarsMessedUpInAlias aliasRegion typeName allVars unusedVars unboundVars -> + typeVarsMessedUpInAliasEncoder aliasRegion typeName allVars unusedVars unboundVars + ) + |> Serialize.variant4 AnnotationTooShort A.regionCodec Serialize.string Index.zeroBasedCodec Serialize.int + |> Serialize.variant5 + AmbiguousVar + A.regionCodec + (Serialize.maybe Serialize.string) + Serialize.string + ModuleName.canonicalCodec + (S.oneOrMore ModuleName.canonicalCodec) + |> Serialize.variant5 + AmbiguousType + A.regionCodec + (Serialize.maybe Serialize.string) + Serialize.string + ModuleName.canonicalCodec + (S.oneOrMore ModuleName.canonicalCodec) + |> Serialize.variant5 + AmbiguousVariant + A.regionCodec + (Serialize.maybe Serialize.string) + Serialize.string + ModuleName.canonicalCodec + (S.oneOrMore ModuleName.canonicalCodec) + |> Serialize.variant4 + AmbiguousBinop + A.regionCodec + Serialize.string + ModuleName.canonicalCodec + (S.oneOrMore ModuleName.canonicalCodec) + |> Serialize.variant5 BadArity A.regionCodec badArityContextCodec Serialize.string Serialize.int Serialize.int + |> Serialize.variant3 Binop A.regionCodec Serialize.string Serialize.string + |> Serialize.variant3 DuplicateDecl Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant3 DuplicateType Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant3 DuplicateCtor Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant3 DuplicateBinop Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant3 DuplicateField Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant4 DuplicateAliasArg Serialize.string Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant4 DuplicateUnionArg Serialize.string Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant4 DuplicatePattern duplicatePatternContextCodec Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant2 EffectNotFound A.regionCodec Serialize.string + |> Serialize.variant2 EffectFunctionNotFound A.regionCodec Serialize.string + |> Serialize.variant3 ExportDuplicate Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant4 + ExportNotFound + A.regionCodec + varKindCodec + Serialize.string + (Serialize.list Serialize.string) + |> Serialize.variant2 ExportOpenAlias A.regionCodec Serialize.string + |> Serialize.variant3 ImportCtorByName A.regionCodec Serialize.string Serialize.string + |> Serialize.variant3 ImportNotFound A.regionCodec Serialize.string (Serialize.list ModuleName.canonicalCodec) + |> Serialize.variant2 ImportOpenAlias A.regionCodec Serialize.string + |> Serialize.variant4 + ImportExposingNotFound + A.regionCodec + ModuleName.canonicalCodec + Serialize.string + (Serialize.list Serialize.string) + |> Serialize.variant4 + NotFoundVar + A.regionCodec + (Serialize.maybe Serialize.string) + Serialize.string + possibleNamesCodec + |> Serialize.variant4 + NotFoundType + A.regionCodec + (Serialize.maybe Serialize.string) + Serialize.string + possibleNamesCodec + |> Serialize.variant4 + NotFoundVariant + A.regionCodec + (Serialize.maybe Serialize.string) + Serialize.string + possibleNamesCodec + |> Serialize.variant3 NotFoundBinop A.regionCodec Serialize.string (S.everySet 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 + |> Serialize.variant5 + RecursiveAlias + A.regionCodec + Serialize.string + (Serialize.list Serialize.string) + Src.typeCodec + (Serialize.list Serialize.string) + |> Serialize.variant3 RecursiveDecl A.regionCodec Serialize.string (Serialize.list Serialize.string) + |> Serialize.variant2 RecursiveLet (A.locatedCodec Serialize.string) (Serialize.list Serialize.string) + |> Serialize.variant3 Shadowing Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant1 TupleLargerThanThree A.regionCodec + |> Serialize.variant5 + TypeVarsUnboundInUnion + A.regionCodec + Serialize.string + (Serialize.list Serialize.string) + (Serialize.tuple Serialize.string A.regionCodec) + (Serialize.list (Serialize.tuple Serialize.string A.regionCodec)) + |> Serialize.variant5 + TypeVarsMessedUpInAlias + A.regionCodec + Serialize.string + (Serialize.list Serialize.string) + (Serialize.list (Serialize.tuple Serialize.string A.regionCodec)) + (Serialize.list (Serialize.tuple Serialize.string A.regionCodec)) + |> Serialize.finishCustomType + + +badArityContextCodec : Codec e BadArityContext +badArityContextCodec = + Serialize.customType + (\typeArityEncoder patternArityEncoder value -> + case value of + TypeArity -> + typeArityEncoder + + PatternArity -> + patternArityEncoder + ) + |> Serialize.variant0 TypeArity + |> Serialize.variant0 PatternArity + |> Serialize.finishCustomType + + +duplicatePatternContextCodec : Codec e DuplicatePatternContext +duplicatePatternContextCodec = + Serialize.customType + (\dPLambdaArgsEncoder dPFuncArgsEncoder dPCaseBranchEncoder dPLetBindingEncoder dPDestructEncoder value -> + case value of + DPLambdaArgs -> + dPLambdaArgsEncoder + + DPFuncArgs funcName -> + dPFuncArgsEncoder funcName + + DPCaseBranch -> + dPCaseBranchEncoder + + DPLetBinding -> + dPLetBindingEncoder + + DPDestruct -> + dPDestructEncoder + ) + |> Serialize.variant0 DPLambdaArgs + |> Serialize.variant1 DPFuncArgs Serialize.string + |> Serialize.variant0 DPCaseBranch + |> Serialize.variant0 DPLetBinding + |> Serialize.variant0 DPDestruct + |> Serialize.finishCustomType + + +varKindCodec : Codec e VarKind +varKindCodec = + Serialize.customType + (\badOpEncoder badVarEncoder badPatternEncoder badTypeEncoder value -> + case value of + BadOp -> + badOpEncoder + + BadVar -> + badVarEncoder + + BadPattern -> + badPatternEncoder + + BadType -> + badTypeEncoder + ) + |> Serialize.variant0 BadOp + |> Serialize.variant0 BadVar + |> Serialize.variant0 BadPattern + |> Serialize.variant0 BadType + |> Serialize.finishCustomType + + +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.finishRecord + + +invalidPayloadCodec : Codec e InvalidPayload +invalidPayloadCodec = + Serialize.customType + (\extendedRecordEncoder functionEncoder typeVariableEncoder unsupportedTypeEncoder value -> + case value of + ExtendedRecord -> + extendedRecordEncoder + + Function -> + functionEncoder + + TypeVariable name -> + typeVariableEncoder name + + UnsupportedType name -> + unsupportedTypeEncoder name + ) + |> Serialize.variant0 ExtendedRecord + |> Serialize.variant0 Function + |> Serialize.variant1 TypeVariable Serialize.string + |> Serialize.variant1 UnsupportedType Serialize.string + |> Serialize.finishCustomType + + +portProblemCodec : Codec e PortProblem +portProblemCodec = + Serialize.customType + (\cmdNoArgEncoder cmdExtraArgsEncoder cmdBadMsgEncoder subBadEncoder notCmdOrSubEncoder value -> + case value of + CmdNoArg -> + cmdNoArgEncoder + + CmdExtraArgs n -> + cmdExtraArgsEncoder n + + CmdBadMsg -> + cmdBadMsgEncoder + + SubBad -> + subBadEncoder + + NotCmdOrSub -> + notCmdOrSubEncoder + ) + |> Serialize.variant0 CmdNoArg + |> Serialize.variant1 CmdExtraArgs Serialize.int + |> Serialize.variant0 CmdBadMsg + |> Serialize.variant0 SubBad + |> Serialize.variant0 NotCmdOrSub + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Error/Docs.elm b/src/Compiler/Reporting/Error/Docs.elm index 023e47b47..4edfc5fb3 100644 --- a/src/Compiler/Reporting/Error/Docs.elm +++ b/src/Compiler/Reporting/Error/Docs.elm @@ -4,15 +4,11 @@ module Compiler.Reporting.Error.Docs exposing , NameProblem(..) , SyntaxProblem(..) , errorCodec - , errorDecoder - , errorEncoder , toReports ) import Compiler.Data.Name as Name import Compiler.Data.NonEmptyList as NE -import Compiler.Json.Decode as DecodeX -import Compiler.Json.Encode as EncodeX import Compiler.Parse.Primitives exposing (Col, Row) import Compiler.Parse.Symbol exposing (BadOperator) import Compiler.Reporting.Annotation as A @@ -20,8 +16,7 @@ import Compiler.Reporting.Doc as D import Compiler.Reporting.Error.Syntax as E import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Report as Report -import Json.Decode as Decode -import Json.Encode as Encode +import Compiler.Serialize as S import Serialize exposing (Codec) @@ -208,249 +203,113 @@ toDefProblemReport source problem = -- ENCODERS and DECODERS -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - NoDocs region -> - Encode.object - [ ( "type", Encode.string "NoDocs" ) - , ( "region", A.regionEncoder region ) - ] - - ImplicitExposing region -> - Encode.object - [ ( "type", Encode.string "ImplicitExposing" ) - , ( "region", A.regionEncoder region ) - ] - - SyntaxProblem problem -> - Encode.object - [ ( "type", Encode.string "SyntaxProblem" ) - , ( "problem", syntaxProblemEncoder problem ) - ] - - NameProblems problems -> - Encode.object - [ ( "type", Encode.string "NameProblems" ) - , ( "problems", EncodeX.nonempty nameProblemEncoder problems ) - ] - - DefProblems problems -> - Encode.object - [ ( "type", Encode.string "DefProblems" ) - , ( "problems", EncodeX.nonempty defProblemEncoder problems ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NoDocs" -> - Decode.map NoDocs (Decode.field "region" A.regionDecoder) - - "ImplicitExposing" -> - Decode.map ImplicitExposing (Decode.field "region" A.regionDecoder) - - "SyntaxProblem" -> - Decode.map SyntaxProblem (Decode.field "problem" syntaxProblemDecoder) - - "NameProblems" -> - Decode.map NameProblems (Decode.field "problems" (DecodeX.nonempty nameProblemDecoder)) - - "DefProblems" -> - Decode.map DefProblems (Decode.field "problems" (DecodeX.nonempty defProblemDecoder)) - - _ -> - Decode.fail ("Failed to decode Error's type: " ++ type_) - ) - - -errorCodec : Codec e Error +errorCodec : Codec (Serialize.Error e) Error errorCodec = - Debug.todo "errorCodec" - - -syntaxProblemEncoder : SyntaxProblem -> Encode.Value -syntaxProblemEncoder syntaxProblem = - case syntaxProblem of - Op row col -> - Encode.object - [ ( "type", Encode.string "Op" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - OpBad badOperator row col -> - Encode.object - [ ( "type", Encode.string "OpBad" ) - , ( "badOperator", Compiler.Parse.Symbol.badOperatorEncoder badOperator ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Name row col -> - Encode.object - [ ( "type", Encode.string "Name" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Space name row col -> - Encode.object - [ ( "type", Encode.string "Space" ) - , ( "name", E.spaceEncoder name ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Comma row col -> - Encode.object - [ ( "type", Encode.string "Comma" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - BadEnd row col -> - Encode.object - [ ( "type", Encode.string "BadEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -syntaxProblemDecoder : Decode.Decoder SyntaxProblem -syntaxProblemDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Op" -> - Decode.map2 Op - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "OpBad" -> - Decode.map3 OpBad - (Decode.field "badOperator" Compiler.Parse.Symbol.badOperatorDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Name" -> - Decode.map2 Name - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Space" -> - Decode.map3 Space - (Decode.field "name" E.spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Comma" -> - Decode.map2 Comma - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "BadEnd" -> - Decode.map2 BadEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode SyntaxProblem's type: " ++ type_) - ) - - -nameProblemEncoder : NameProblem -> Encode.Value -nameProblemEncoder nameProblem = - case nameProblem of - NameDuplicate name r1 r2 -> - Encode.object - [ ( "type", Encode.string "NameDuplicate" ) - , ( "name", Encode.string name ) - , ( "r1", A.regionEncoder r1 ) - , ( "r2", A.regionEncoder r2 ) - ] - - NameOnlyInDocs name region -> - Encode.object - [ ( "type", Encode.string "NameOnlyInDocs" ) - , ( "name", Encode.string name ) - , ( "region", A.regionEncoder region ) - ] - - NameOnlyInExports name region -> - Encode.object - [ ( "type", Encode.string "NameOnlyInExports" ) - , ( "name", Encode.string name ) - , ( "region", A.regionEncoder region ) - ] - - -nameProblemDecoder : Decode.Decoder NameProblem -nameProblemDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NameDuplicate" -> - Decode.map3 NameDuplicate - (Decode.field "name" Decode.string) - (Decode.field "r1" A.regionDecoder) - (Decode.field "r2" A.regionDecoder) - - "NameOnlyInDocs" -> - Decode.map2 NameOnlyInDocs - (Decode.field "name" Decode.string) - (Decode.field "region" A.regionDecoder) - - "NameOnlyInExports" -> - Decode.map2 NameOnlyInExports - (Decode.field "name" Decode.string) - (Decode.field "region" A.regionDecoder) - - _ -> - Decode.fail ("Failed to decode NameProblem's type: " ++ type_) - ) - - -defProblemEncoder : DefProblem -> Encode.Value -defProblemEncoder defProblem = - case defProblem of - NoComment name region -> - Encode.object - [ ( "type", Encode.string "NoComment" ) - , ( "name", Encode.string name ) - , ( "region", A.regionEncoder region ) - ] - - NoAnnotation name region -> - Encode.object - [ ( "type", Encode.string "NoAnnotation" ) - , ( "name", Encode.string name ) - , ( "region", A.regionEncoder region ) - ] - - -defProblemDecoder : Decode.Decoder DefProblem -defProblemDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NoComment" -> - Decode.map2 NoComment - (Decode.field "name" Decode.string) - (Decode.field "region" A.regionDecoder) - - "NoAnnotation" -> - Decode.map2 NoAnnotation - (Decode.field "name" Decode.string) - (Decode.field "region" A.regionDecoder) - - _ -> - Decode.fail ("Failed to decode DefProblem's type: " ++ type_) - ) + Serialize.customType + (\noDocsEncoder implicitExposingEncoder syntaxProblemCodecEncoder nameProblemsEncoder defProblemsEncoder value -> + case value of + NoDocs region -> + noDocsEncoder region + + ImplicitExposing region -> + implicitExposingEncoder region + + SyntaxProblem problem -> + syntaxProblemCodecEncoder problem + + NameProblems problems -> + nameProblemsEncoder problems + + DefProblems problems -> + defProblemsEncoder problems + ) + |> Serialize.variant1 NoDocs A.regionCodec + |> Serialize.variant1 ImplicitExposing A.regionCodec + |> Serialize.variant1 SyntaxProblem syntaxProblemCodec + |> Serialize.variant1 NameProblems (S.nonempty nameProblemCodec) + |> Serialize.variant1 DefProblems (S.nonempty defProblemCodec) + |> Serialize.finishCustomType + + +spaceCodec : Codec e E.Space +spaceCodec = + Serialize.customType + (\hasTabEncoder endlessMultiCommentEncoder value -> + case value of + E.HasTab -> + hasTabEncoder + + E.EndlessMultiComment -> + endlessMultiCommentEncoder + ) + |> Serialize.variant0 E.HasTab + |> Serialize.variant0 E.EndlessMultiComment + |> Serialize.finishCustomType + + +syntaxProblemCodec : Codec e SyntaxProblem +syntaxProblemCodec = + Serialize.customType + (\opEncoder opBadEncoder nameEncoder spaceEncoder commaEncoder badEndEncoder value -> + case value of + Op row col -> + opEncoder row col + + OpBad badOperator row col -> + opBadEncoder badOperator row col + + Name row col -> + nameEncoder row col + + Space name row col -> + spaceEncoder name row col + + Comma row col -> + commaEncoder row col + + BadEnd row col -> + badEndEncoder row col + ) + |> Serialize.variant2 Op Serialize.int Serialize.int + |> Serialize.variant3 OpBad Compiler.Parse.Symbol.badOperatorCodec Serialize.int Serialize.int + |> Serialize.variant2 Name Serialize.int Serialize.int + |> Serialize.variant3 Space spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 Comma Serialize.int Serialize.int + |> Serialize.variant2 BadEnd Serialize.int Serialize.int + |> Serialize.finishCustomType + + +nameProblemCodec : Codec e NameProblem +nameProblemCodec = + Serialize.customType + (\nameDuplicateEncoder nameOnlyInDocsEncoder nameOnlyInExportsEncoder value -> + case value of + NameDuplicate name r1 r2 -> + nameDuplicateEncoder name r1 r2 + + NameOnlyInDocs name region -> + nameOnlyInDocsEncoder name region + + NameOnlyInExports name region -> + nameOnlyInExportsEncoder name region + ) + |> Serialize.variant3 NameDuplicate Serialize.string A.regionCodec A.regionCodec + |> Serialize.variant2 NameOnlyInDocs Serialize.string A.regionCodec + |> Serialize.variant2 NameOnlyInExports Serialize.string A.regionCodec + |> Serialize.finishCustomType + + +defProblemCodec : Codec e DefProblem +defProblemCodec = + Serialize.customType + (\noCommentEncoder noAnnotationEncoder value -> + case value of + NoComment name region -> + noCommentEncoder name region + + NoAnnotation name region -> + noAnnotationEncoder name region + ) + |> Serialize.variant2 NoComment Serialize.string A.regionCodec + |> Serialize.variant2 NoAnnotation Serialize.string A.regionCodec + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Error/Import.elm b/src/Compiler/Reporting/Error/Import.elm index f038b2dd0..337dd2960 100644 --- a/src/Compiler/Reporting/Error/Import.elm +++ b/src/Compiler/Reporting/Error/Import.elm @@ -2,27 +2,20 @@ module Compiler.Reporting.Error.Import exposing ( Error(..) , Problem(..) , errorCodec - , errorDecoder - , errorEncoder , problemCodec - , problemDecoder - , problemEncoder , toReport ) import Compiler.Elm.ModuleName as ModuleName import Compiler.Elm.Package as Pkg -import Compiler.Json.Decode as DecodeX -import Compiler.Json.Encode as EncodeX import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Report as Report import Compiler.Reporting.Suggest as Suggest +import Compiler.Serialize as S import Data.Map as Dict import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -189,73 +182,6 @@ toSuggestions name unimportedModules = -- ENCODERS and DECODERS -problemEncoder : Problem -> Encode.Value -problemEncoder problem = - case problem of - NotFound -> - Encode.object - [ ( "type", Encode.string "NotFound" ) - ] - - Ambiguous path paths pkg pkgs -> - Encode.object - [ ( "type", Encode.string "Ambiguous" ) - , ( "path", Encode.string path ) - , ( "paths", Encode.list Encode.string paths ) - , ( "pkg", Pkg.nameEncoder pkg ) - , ( "pkgs", Encode.list Pkg.nameEncoder pkgs ) - ] - - AmbiguousLocal path1 path2 paths -> - Encode.object - [ ( "type", Encode.string "AmbiguousLocal" ) - , ( "path1", Encode.string path1 ) - , ( "path2", Encode.string path2 ) - , ( "paths", Encode.list Encode.string paths ) - ] - - AmbiguousForeign pkg1 pkg2 pkgs -> - Encode.object - [ ( "type", Encode.string "AmbiguousForeign" ) - , ( "pkg1", Pkg.nameEncoder pkg1 ) - , ( "pkg2", Pkg.nameEncoder pkg2 ) - , ( "pkgs", Encode.list Pkg.nameEncoder pkgs ) - ] - - -problemDecoder : Decode.Decoder Problem -problemDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NotFound" -> - Decode.succeed NotFound - - "Ambiguous" -> - Decode.map4 Ambiguous - (Decode.field "path" Decode.string) - (Decode.field "paths" (Decode.list Decode.string)) - (Decode.field "pkg" Pkg.nameDecoder) - (Decode.field "pkgs" (Decode.list Pkg.nameDecoder)) - - "AmbiguousLocal" -> - Decode.map3 AmbiguousLocal - (Decode.field "path1" Decode.string) - (Decode.field "path2" Decode.string) - (Decode.field "paths" (Decode.list Decode.string)) - - "AmbiguousForeign" -> - Decode.map3 AmbiguousForeign - (Decode.field "pkg1" Pkg.nameDecoder) - (Decode.field "pkg2" Pkg.nameDecoder) - (Decode.field "pkgs" (Decode.list Pkg.nameDecoder)) - - _ -> - Decode.fail ("Failed to decode Problem's type: " ++ type_) - ) - - problemCodec : Codec e Problem problemCodec = Serialize.customType @@ -280,26 +206,11 @@ problemCodec = |> Serialize.finishCustomType -errorEncoder : Error -> Encode.Value -errorEncoder (Error region name unimportedModules problem) = - Encode.object - [ ( "type", Encode.string "Error" ) - , ( "region", A.regionEncoder region ) - , ( "name", ModuleName.rawEncoder name ) - , ( "unimportedModules", EncodeX.everySet ModuleName.rawEncoder unimportedModules ) - , ( "problem", problemEncoder problem ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.map4 Error - (Decode.field "region" A.regionDecoder) - (Decode.field "name" ModuleName.rawDecoder) - (Decode.field "unimportedModules" (DecodeX.everySet compare ModuleName.rawDecoder)) - (Decode.field "problem" problemDecoder) - - errorCodec : Codec e Error errorCodec = - Debug.todo "errorCodec" + Serialize.customType + (\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.finishCustomType diff --git a/src/Compiler/Reporting/Error/Main.elm b/src/Compiler/Reporting/Error/Main.elm index 10bfb64ec..88a810c32 100644 --- a/src/Compiler/Reporting/Error/Main.elm +++ b/src/Compiler/Reporting/Error/Main.elm @@ -1,8 +1,6 @@ module Compiler.Reporting.Error.Main exposing ( Error(..) , errorCodec - , errorDecoder - , errorEncoder , toReport ) @@ -15,8 +13,6 @@ import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Render.Type as RT import Compiler.Reporting.Render.Type.Localizer as L import Compiler.Reporting.Report as Report -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -100,61 +96,21 @@ toReport localizer source err = -- ENCODERS and DECODERS -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - BadType region tipe -> - Encode.object - [ ( "type", Encode.string "BadType" ) - , ( "region", A.regionEncoder region ) - , ( "tipe", Can.typeEncoder tipe ) - ] - - BadCycle region name names -> - Encode.object - [ ( "type", Encode.string "BadCycle" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "names", Encode.list Encode.string names ) - ] - - BadFlags region subType invalidPayload -> - Encode.object - [ ( "type", Encode.string "BadFlags" ) - , ( "region", A.regionEncoder region ) - , ( "subType", Can.typeEncoder subType ) - , ( "invalidPayload", E.invalidPayloadEncoder invalidPayload ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "BadType" -> - Decode.map2 BadType - (Decode.field "region" A.regionDecoder) - (Decode.field "tipe" Can.typeDecoder) - - "BadCycle" -> - Decode.map3 BadCycle - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "names" (Decode.list Decode.string)) - - "BadFlags" -> - Decode.map3 BadFlags - (Decode.field "region" A.regionDecoder) - (Decode.field "subType" Can.typeDecoder) - (Decode.field "invalidPayload" E.invalidPayloadDecoder) - - _ -> - Decode.fail ("Failed to decode Error's type: " ++ type_) - ) - - errorCodec : Codec e Error errorCodec = - Debug.todo "errorCodec" + Serialize.customType + (\badTypeEncoder badCycleEncoder badFlagsEncoder error -> + case error of + BadType region tipe -> + badTypeEncoder region tipe + + BadCycle region name names -> + badCycleEncoder region name names + + BadFlags region subType invalidPayload -> + badFlagsEncoder region subType invalidPayload + ) + |> Serialize.variant2 BadType A.regionCodec Can.typeCodec + |> Serialize.variant3 BadCycle A.regionCodec Serialize.string (Serialize.list Serialize.string) + |> Serialize.variant3 BadFlags A.regionCodec Can.typeCodec E.invalidPayloadCodec + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Error/Syntax.elm b/src/Compiler/Reporting/Error/Syntax.elm index 551e2a893..4f2a96d4b 100644 --- a/src/Compiler/Reporting/Error/Syntax.elm +++ b/src/Compiler/Reporting/Error/Syntax.elm @@ -31,10 +31,6 @@ module Compiler.Reporting.Error.Syntax exposing , Type(..) , TypeAlias(..) , errorCodec - , errorDecoder - , errorEncoder - , spaceDecoder - , spaceEncoder , toReport , toSpaceReport ) @@ -48,9 +44,6 @@ import Compiler.Reporting.Doc as D import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Report as Report import Hex -import Json.Decode as Decode -import Json.Encode as Encode -import Pretty exposing (space) import Serialize exposing (Codec) @@ -7865,96 +7858,6 @@ toTTupleReport source context tuple startRow startCol = -- ENCODERS and DECODERS -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - ModuleNameUnspecified name -> - Encode.object - [ ( "type", Encode.string "ModuleNameUnspecified" ) - , ( "name", ModuleName.rawEncoder name ) - ] - - ModuleNameMismatch expectedName actualName -> - Encode.object - [ ( "type", Encode.string "ModuleNameMismatch" ) - , ( "expectedName", ModuleName.rawEncoder expectedName ) - , ( "actualName", A.locatedEncoder ModuleName.rawEncoder actualName ) - ] - - UnexpectedPort region -> - Encode.object - [ ( "type", Encode.string "UnexpectedPort" ) - , ( "region", A.regionEncoder region ) - ] - - NoPorts region -> - Encode.object - [ ( "type", Encode.string "NoPorts" ) - , ( "region", A.regionEncoder region ) - ] - - NoPortsInPackage name -> - Encode.object - [ ( "type", Encode.string "NoPortsInPackage" ) - , ( "name", A.locatedEncoder Encode.string name ) - ] - - NoPortModulesInPackage region -> - Encode.object - [ ( "type", Encode.string "NoPortModulesInPackage" ) - , ( "region", A.regionEncoder region ) - ] - - NoEffectsOutsideKernel region -> - Encode.object - [ ( "type", Encode.string "NoEffectsOutsideKernel" ) - , ( "region", A.regionEncoder region ) - ] - - ParseError modul -> - Encode.object - [ ( "type", Encode.string "ParseError" ) - , ( "modul", moduleEncoder modul ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ModuleNameUnspecified" -> - Decode.map ModuleNameUnspecified (Decode.field "name" ModuleName.rawDecoder) - - "ModuleNameMismatch" -> - Decode.map2 ModuleNameMismatch - (Decode.field "expectedName" ModuleName.rawDecoder) - (Decode.field "actualName" (A.locatedDecoder ModuleName.rawDecoder)) - - "UnexpectedPort" -> - Decode.map UnexpectedPort (Decode.field "region" A.regionDecoder) - - "NoPorts" -> - Decode.map NoPorts (Decode.field "region" A.regionDecoder) - - "NoPortsInPackage" -> - Decode.map NoPortsInPackage (Decode.field "name" (A.locatedDecoder Decode.string)) - - "NoPortModulesInPackage" -> - Decode.map NoPortModulesInPackage (Decode.field "region" A.regionDecoder) - - "NoEffectsOutsideKernel" -> - Decode.map NoEffectsOutsideKernel (Decode.field "region" A.regionDecoder) - - "ParseError" -> - Decode.map ParseError (Decode.field "modul" moduleDecoder) - - _ -> - Decode.fail ("Failed to decode Error's type: " ++ type_) - ) - - errorCodec : Codec e Error errorCodec = Serialize.customType @@ -7995,33 +7898,6 @@ errorCodec = |> Serialize.finishCustomType -spaceEncoder : Space -> Encode.Value -spaceEncoder space = - case space of - HasTab -> - Encode.string "HasTab" - - EndlessMultiComment -> - Encode.string "EndlessMultiComment" - - -spaceDecoder : Decode.Decoder Space -spaceDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "HasTab" -> - Decode.succeed HasTab - - "EndlessMultiComment" -> - Decode.succeed EndlessMultiComment - - _ -> - Decode.fail ("Unknown Space: " ++ str) - ) - - spaceCodec : Codec e Space spaceCodec = Serialize.customType @@ -8038,295 +7914,6 @@ spaceCodec = |> Serialize.finishCustomType -moduleEncoder : Module -> Encode.Value -moduleEncoder modul = - case modul of - ModuleSpace space row col -> - Encode.object - [ ( "type", Encode.string "ModuleSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ModuleBadEnd row col -> - Encode.object - [ ( "type", Encode.string "ModuleBadEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ModuleProblem row col -> - Encode.object - [ ( "type", Encode.string "ModuleProblem" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ModuleName row col -> - Encode.object - [ ( "type", Encode.string "ModuleName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ModuleExposing exposing_ row col -> - Encode.object - [ ( "type", Encode.string "ModuleExposing" ) - , ( "exposing", exposingEncoder exposing_ ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortModuleProblem row col -> - Encode.object - [ ( "type", Encode.string "PortModuleProblem" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortModuleName row col -> - Encode.object - [ ( "type", Encode.string "PortModuleName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortModuleExposing exposing_ row col -> - Encode.object - [ ( "type", Encode.string "PortModuleExposing" ) - , ( "exposing", exposingEncoder exposing_ ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Effect row col -> - Encode.object - [ ( "type", Encode.string "Effect" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - FreshLine row col -> - Encode.object - [ ( "type", Encode.string "FreshLine" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportStart row col -> - Encode.object - [ ( "type", Encode.string "ImportStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportName row col -> - Encode.object - [ ( "type", Encode.string "ImportName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportAs row col -> - Encode.object - [ ( "type", Encode.string "ImportAs" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportAlias row col -> - Encode.object - [ ( "type", Encode.string "ImportAlias" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportExposing row col -> - Encode.object - [ ( "type", Encode.string "ImportExposing" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportExposingList exposing_ row col -> - Encode.object - [ ( "type", Encode.string "ImportExposingList" ) - , ( "exposing", exposingEncoder exposing_ ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportEnd row col -> - Encode.object - [ ( "type", Encode.string "ImportEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportIndentName row col -> - Encode.object - [ ( "type", Encode.string "ImportIndentName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportIndentAlias row col -> - Encode.object - [ ( "type", Encode.string "ImportIndentAlias" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ImportIndentExposingList row col -> - Encode.object - [ ( "type", Encode.string "ImportIndentExposingList" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Infix row col -> - Encode.object - [ ( "type", Encode.string "Infix" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Declarations decl row col -> - Encode.object - [ ( "type", Encode.string "Declarations" ) - , ( "decl", declEncoder decl ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -moduleDecoder : Decode.Decoder Module -moduleDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ModuleSpace" -> - Decode.map3 ModuleSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ModuleBadEnd" -> - Decode.map2 ModuleBadEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ModuleProblem" -> - Decode.map2 ModuleProblem - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ModuleName" -> - Decode.map2 ModuleName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ModuleExposing" -> - Decode.map3 ModuleExposing - (Decode.field "exposing" exposingDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortModuleProblem" -> - Decode.map2 PortModuleProblem - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortModuleName" -> - Decode.map2 PortModuleName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortModuleExposing" -> - Decode.map3 PortModuleExposing - (Decode.field "exposing" exposingDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Effect" -> - Decode.map2 Effect - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "FreshLine" -> - Decode.map2 FreshLine - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportStart" -> - Decode.map2 ImportStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportName" -> - Decode.map2 ImportName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportAs" -> - Decode.map2 ImportAs - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportAlias" -> - Decode.map2 ImportAlias - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportExposing" -> - Decode.map2 ImportExposing - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportExposingList" -> - Decode.map3 ImportExposingList - (Decode.field "exposing" exposingDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportEnd" -> - Decode.map2 ImportEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportIndentName" -> - Decode.map2 ImportIndentName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportIndentAlias" -> - Decode.map2 ImportIndentAlias - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ImportIndentExposingList" -> - Decode.map2 ImportIndentExposingList - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Infix" -> - Decode.map2 Infix - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Declarations" -> - Decode.map3 Declarations - (Decode.field "decl" declDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Module's type: " ++ type_) - ) - - moduleCodec : Codec e Module moduleCodec = Serialize.customType @@ -8423,145 +8010,6 @@ moduleCodec = |> Serialize.finishCustomType -exposingEncoder : Exposing -> Encode.Value -exposingEncoder exposing_ = - case exposing_ of - ExposingSpace space row col -> - Encode.object - [ ( "type", Encode.string "ExposingSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingStart row col -> - Encode.object - [ ( "type", Encode.string "ExposingStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingValue row col -> - Encode.object - [ ( "type", Encode.string "ExposingValue" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingOperator row col -> - Encode.object - [ ( "type", Encode.string "ExposingOperator" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingOperatorReserved op row col -> - Encode.object - [ ( "type", Encode.string "ExposingOperatorReserved" ) - , ( "op", Compiler.Parse.Symbol.badOperatorEncoder op ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingOperatorRightParen row col -> - Encode.object - [ ( "type", Encode.string "ExposingOperatorRightParen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingTypePrivacy row col -> - Encode.object - [ ( "type", Encode.string "ExposingTypePrivacy" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingEnd row col -> - Encode.object - [ ( "type", Encode.string "ExposingEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "ExposingIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - ExposingIndentValue row col -> - Encode.object - [ ( "type", Encode.string "ExposingIndentValue" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -exposingDecoder : Decode.Decoder Exposing -exposingDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ExposingSpace" -> - Decode.map3 ExposingSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingStart" -> - Decode.map2 ExposingStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingValue" -> - Decode.map2 ExposingValue - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingOperator" -> - Decode.map2 ExposingOperator - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingOperatorReserved" -> - Decode.map3 ExposingOperatorReserved - (Decode.field "op" Compiler.Parse.Symbol.badOperatorDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingOperatorRightParen" -> - Decode.map2 ExposingOperatorRightParen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingTypePrivacy" -> - Decode.map2 ExposingTypePrivacy - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingEnd" -> - Decode.map2 ExposingEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingIndentEnd" -> - Decode.map2 ExposingIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ExposingIndentValue" -> - Decode.map2 ExposingIndentValue - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Exposing's type: " ++ type_) - ) - - exposingCodec : Codec e Exposing exposingCodec = Serialize.customType @@ -8610,103 +8058,6 @@ exposingCodec = |> Serialize.finishCustomType -declEncoder : Decl -> Encode.Value -declEncoder decl = - case decl of - DeclStart row col -> - Encode.object - [ ( "type", Encode.string "DeclStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclSpace space row col -> - Encode.object - [ ( "type", Encode.string "DeclSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Port port_ row col -> - Encode.object - [ ( "type", Encode.string "Port" ) - , ( "port", portEncoder port_ ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclType declType row col -> - Encode.object - [ ( "type", Encode.string "DeclType" ) - , ( "declType", declTypeEncoder declType ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDef name declDef row col -> - Encode.object - [ ( "type", Encode.string "DeclDef" ) - , ( "name", Encode.string name ) - , ( "declDef", declDefEncoder declDef ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclFreshLineAfterDocComment row col -> - Encode.object - [ ( "type", Encode.string "DeclFreshLineAfterDocComment" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -declDecoder : Decode.Decoder Decl -declDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "DeclStart" -> - Decode.map2 DeclStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclSpace" -> - Decode.map3 DeclSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Port" -> - Decode.map3 Port - (Decode.field "port" portDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclType" -> - Decode.map3 DeclType - (Decode.field "declType" declTypeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDef" -> - Decode.map4 DeclDef - (Decode.field "name" Decode.string) - (Decode.field "declDef" declDefDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclFreshLineAfterDocComment" -> - Decode.map2 DeclFreshLineAfterDocComment - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Decl's type: " ++ type_) - ) - - declCodec : Codec e Decl declCodec = Serialize.customType @@ -8739,343 +8090,68 @@ declCodec = |> Serialize.finishCustomType -portEncoder : Port -> Encode.Value -portEncoder port_ = - case port_ of - PortSpace space row col -> - Encode.object - [ ( "type", Encode.string "PortSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortName row col -> - Encode.object - [ ( "type", Encode.string "PortName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortColon row col -> - Encode.object - [ ( "type", Encode.string "PortColon" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortType tipe row col -> - Encode.object - [ ( "type", Encode.string "PortType" ) - , ( "tipe", typeEncoder tipe ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortIndentName row col -> - Encode.object - [ ( "type", Encode.string "PortIndentName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortIndentColon row col -> - Encode.object - [ ( "type", Encode.string "PortIndentColon" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PortIndentType row col -> - Encode.object - [ ( "type", Encode.string "PortIndentType" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -portDecoder : Decode.Decoder Port -portDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PortSpace" -> - Decode.map3 PortSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortName" -> - Decode.map2 PortName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortColon" -> - Decode.map2 PortColon - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortType" -> - Decode.map3 PortType - (Decode.field "tipe" typeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortIndentName" -> - Decode.map2 PortIndentName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortIndentColon" -> - Decode.map2 PortIndentColon - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PortIndentType" -> - Decode.map2 PortIndentType - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Port's type: " ++ type_) - ) - - portCodec : Codec e Port portCodec = - Debug.todo "portCodec" - - -declTypeEncoder : DeclType -> Encode.Value -declTypeEncoder declType = - case declType of - DT_Space space row col -> - Encode.object - [ ( "type", Encode.string "DT_Space" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + Serialize.customType + (\portSpaceEncoder portNameEncoder portColonEncoder portTypeEncoder portIndentNameEncoder portIndentColonEncoder portIndentTypeEncoder value -> + case value of + PortSpace space row col -> + portSpaceEncoder space row col - DT_Name row col -> - Encode.object - [ ( "type", Encode.string "DT_Name" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PortName row col -> + portNameEncoder row col - DT_Alias typeAlias row col -> - Encode.object - [ ( "type", Encode.string "DT_Alias" ) - , ( "typeAlias", typeAliasEncoder typeAlias ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PortColon row col -> + portColonEncoder row col - DT_Union customType row col -> - Encode.object - [ ( "type", Encode.string "DT_Union" ) - , ( "customType", customTypeEncoder customType ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PortType tipe row col -> + portTypeEncoder tipe row col - DT_IndentName row col -> - Encode.object - [ ( "type", Encode.string "DT_IndentName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PortIndentName row col -> + portIndentNameEncoder row col + PortIndentColon row col -> + portIndentColonEncoder row col -declTypeDecoder : Decode.Decoder DeclType -declTypeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "DT_Space" -> - Decode.map3 DT_Space - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DT_Name" -> - Decode.map2 DT_Name - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DT_Alias" -> - Decode.map3 DT_Alias - (Decode.field "typeAlias" typeAliasDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DT_Union" -> - Decode.map3 DT_Union - (Decode.field "customType" customTypeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DT_IndentName" -> - Decode.map2 DT_IndentName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode DeclType's type: " ++ type_) - ) + PortIndentType row col -> + portIndentTypeEncoder row col + ) + |> Serialize.variant3 PortSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 PortName Serialize.int Serialize.int + |> Serialize.variant2 PortColon Serialize.int Serialize.int + |> Serialize.variant3 PortType typeCodec Serialize.int Serialize.int + |> Serialize.variant2 PortIndentName Serialize.int Serialize.int + |> Serialize.variant2 PortIndentColon Serialize.int Serialize.int + |> Serialize.variant2 PortIndentType Serialize.int Serialize.int + |> Serialize.finishCustomType declTypeCodec : Codec e DeclType declTypeCodec = - Debug.todo "declTypeCodec" - - -declDefEncoder : DeclDef -> Encode.Value -declDefEncoder declDef = - case declDef of - DeclDefSpace space row col -> - Encode.object - [ ( "type", Encode.string "DeclDefSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDefEquals row col -> - Encode.object - [ ( "type", Encode.string "DeclDefEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDefType tipe row col -> - Encode.object - [ ( "type", Encode.string "DeclDefType" ) - , ( "tipe", typeEncoder tipe ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDefArg pattern row col -> - Encode.object - [ ( "type", Encode.string "DeclDefArg" ) - , ( "pattern", patternEncoder pattern ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDefBody expr row col -> - Encode.object - [ ( "type", Encode.string "DeclDefBody" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDefNameRepeat row col -> - Encode.object - [ ( "type", Encode.string "DeclDefNameRepeat" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDefNameMatch name row col -> - Encode.object - [ ( "type", Encode.string "DeclDefNameMatch" ) - , ( "name", Encode.string name ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DeclDefIndentType row col -> - Encode.object - [ ( "type", Encode.string "DeclDefIndentType" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + Serialize.customType + (\dT_SpaceEncoder dT_NameEncoder dT_AliasEncoder dT_UnionEncoder dT_IndentNameEncoder value -> + case value of + DT_Space space row col -> + dT_SpaceEncoder space row col - DeclDefIndentEquals row col -> - Encode.object - [ ( "type", Encode.string "DeclDefIndentEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DT_Name row col -> + dT_NameEncoder row col - DeclDefIndentBody row col -> - Encode.object - [ ( "type", Encode.string "DeclDefIndentBody" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DT_Alias typeAlias row col -> + dT_AliasEncoder typeAlias row col + DT_Union customType row col -> + dT_UnionEncoder customType row col -declDefDecoder : Decode.Decoder DeclDef -declDefDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "DeclDefSpace" -> - Decode.map3 DeclDefSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefEquals" -> - Decode.map2 DeclDefEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefType" -> - Decode.map3 DeclDefType - (Decode.field "tipe" typeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefArg" -> - Decode.map3 DeclDefArg - (Decode.field "pattern" patternDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefBody" -> - Decode.map3 DeclDefBody - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefNameRepeat" -> - Decode.map2 DeclDefNameRepeat - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefNameMatch" -> - Decode.map3 DeclDefNameMatch - (Decode.field "name" Decode.string) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefIndentType" -> - Decode.map2 DeclDefIndentType - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefIndentEquals" -> - Decode.map2 DeclDefIndentEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DeclDefIndentBody" -> - Decode.map2 DeclDefIndentBody - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode DeclDef's type: " ++ type_) - ) + DT_IndentName row col -> + dT_IndentNameEncoder row col + ) + |> Serialize.variant3 DT_Space spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 DT_Name Serialize.int Serialize.int + |> Serialize.variant3 DT_Alias typeAliasCodec Serialize.int Serialize.int + |> Serialize.variant3 DT_Union customTypeCodec Serialize.int Serialize.int + |> Serialize.variant2 DT_IndentName Serialize.int Serialize.int + |> Serialize.finishCustomType declDefCodec : Codec e DeclDef @@ -9126,559 +8202,92 @@ declDefCodec = |> Serialize.finishCustomType -typeEncoder : Type -> Encode.Value -typeEncoder type_ = - case type_ of - TRecord record row col -> - Encode.object - [ ( "type", Encode.string "TRecord" ) - , ( "record", tRecordEncoder record ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TTuple tuple row col -> - Encode.object - [ ( "type", Encode.string "TTuple" ) - , ( "tuple", tTupleEncoder tuple ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TStart row col -> - Encode.object - [ ( "type", Encode.string "TStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TSpace space row col -> - Encode.object - [ ( "type", Encode.string "TSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TIndentStart row col -> - Encode.object - [ ( "type", Encode.string "TIndentStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -typeDecoder : Decode.Decoder Type -typeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "TRecord" -> - Decode.map3 TRecord - (Decode.field "record" tRecordDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TTuple" -> - Decode.map3 TTuple - (Decode.field "tuple" tTupleDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TStart" -> - Decode.map2 TStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TSpace" -> - Decode.map3 TSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TIndentStart" -> - Decode.map2 TIndentStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Type's type: " ++ type_) - ) - - typeCodec : Codec e Type typeCodec = - Debug.todo "typeCodec" - - -patternEncoder : Pattern -> Encode.Value -patternEncoder pattern = - case pattern of - PRecord record row col -> - Encode.object - [ ( "type", Encode.string "PRecord" ) - , ( "record", pRecordEncoder record ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PTuple tuple row col -> - Encode.object - [ ( "type", Encode.string "PTuple" ) - , ( "tuple", pTupleEncoder tuple ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PList list row col -> - Encode.object - [ ( "type", Encode.string "PList" ) - , ( "list", pListEncoder list ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PStart row col -> - Encode.object - [ ( "type", Encode.string "PStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PChar char row col -> - Encode.object - [ ( "type", Encode.string "PChar" ) - , ( "char", charEncoder char ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PString string row col -> - Encode.object - [ ( "type", Encode.string "PString" ) - , ( "string", stringEncoder string ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PNumber number row col -> - Encode.object - [ ( "type", Encode.string "PNumber" ) - , ( "number", numberEncoder number ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PFloat width row col -> - Encode.object - [ ( "type", Encode.string "PFloat" ) - , ( "width", Encode.int width ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PAlias row col -> - Encode.object - [ ( "type", Encode.string "PAlias" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PWildcardNotVar name width row col -> - Encode.object - [ ( "type", Encode.string "PWildcardNotVar" ) - , ( "name", Encode.string name ) - , ( "width", Encode.int width ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - PSpace space row col -> - Encode.object - [ ( "type", Encode.string "PSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + Serialize.customType + (\tRecordCodecEncoder tTupleCodecEncoder tStartEncoder tSpaceEncoder tIndentStartEncoder value -> + case value of + TRecord record row col -> + tRecordCodecEncoder record row col - PIndentStart row col -> - Encode.object - [ ( "type", Encode.string "PIndentStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TTuple tuple row col -> + tTupleCodecEncoder tuple row col - PIndentAlias row col -> - Encode.object - [ ( "type", Encode.string "PIndentAlias" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TStart row col -> + tStartEncoder row col + TSpace space row col -> + tSpaceEncoder space row col -patternDecoder : Decode.Decoder Pattern -patternDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PRecord" -> - Decode.map3 PRecord - (Decode.field "record" pRecordDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PTuple" -> - Decode.map3 PTuple - (Decode.field "tuple" pTupleDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PList" -> - Decode.map3 PList - (Decode.field "list" pListDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PStart" -> - Decode.map2 PStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PChar" -> - Decode.map3 PChar - (Decode.field "char" charDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PString" -> - Decode.map3 PString - (Decode.field "string" stringDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PNumber" -> - Decode.map3 PNumber - (Decode.field "number" numberDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PFloat" -> - Decode.map3 PFloat - (Decode.field "width" Decode.int) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PAlias" -> - Decode.map2 PAlias - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PWildcardNotVar" -> - Decode.map4 PWildcardNotVar - (Decode.field "name" Decode.string) - (Decode.field "width" Decode.int) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PSpace" -> - Decode.map3 PSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PIndentStart" -> - Decode.map2 PIndentStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PIndentAlias" -> - Decode.map2 PIndentAlias - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Pattern's type: " ++ type_) - ) + TIndentStart row col -> + tIndentStartEncoder row col + ) + |> Serialize.variant3 TRecord tRecordCodec Serialize.int Serialize.int + |> Serialize.variant3 TTuple (Serialize.lazy (\() -> tTupleCodec)) Serialize.int Serialize.int + |> Serialize.variant2 TStart Serialize.int Serialize.int + |> Serialize.variant3 TSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 TIndentStart Serialize.int Serialize.int + |> Serialize.finishCustomType patternCodec : Codec e Pattern patternCodec = - Debug.todo "patternCodec" - - -exprEncoder : Expr -> Encode.Value -exprEncoder expr = - case expr of - Let let_ row col -> - Encode.object - [ ( "type", Encode.string "Let" ) - , ( "let", letEncoder let_ ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Case case_ row col -> - Encode.object - [ ( "type", Encode.string "Case" ) - , ( "case", caseEncoder case_ ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - If if_ row col -> - Encode.object - [ ( "type", Encode.string "If" ) - , ( "if", ifEncoder if_ ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - List list row col -> - Encode.object - [ ( "type", Encode.string "List" ) - , ( "list", listEncoder list ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Record record row col -> - Encode.object - [ ( "type", Encode.string "Record" ) - , ( "record", recordEncoder record ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Tuple tuple row col -> - Encode.object - [ ( "type", Encode.string "Tuple" ) - , ( "tuple", tupleEncoder tuple ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Func func row col -> - Encode.object - [ ( "type", Encode.string "Func" ) - , ( "func", funcEncoder func ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Dot row col -> - Encode.object - [ ( "type", Encode.string "Dot" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - Access row col -> - Encode.object - [ ( "type", Encode.string "Access" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + Serialize.customType + (\pRecordCodecEncoder pTupleCodecEncoder pListCodecEncoder pStartEncoder pCharEncoder pStringEncoder pNumberEncoder pFloatEncoder pAliasEncoder pWildcardNotVarEncoder pSpaceEncoder pIndentStartEncoder pIndentAliasEncoder value -> + case value of + PRecord record row col -> + pRecordCodecEncoder record row col - OperatorRight op row col -> - Encode.object - [ ( "type", Encode.string "OperatorRight" ) - , ( "op", Encode.string op ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PTuple tuple row col -> + pTupleCodecEncoder tuple row col - OperatorReserved operator row col -> - Encode.object - [ ( "type", Encode.string "OperatorReserved" ) - , ( "operator", Compiler.Parse.Symbol.badOperatorEncoder operator ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PList list row col -> + pListCodecEncoder list row col - Start row col -> - Encode.object - [ ( "type", Encode.string "Start" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PStart row col -> + pStartEncoder row col - Char char row col -> - Encode.object - [ ( "type", Encode.string "Char" ) - , ( "char", charEncoder char ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PChar char row col -> + pCharEncoder char row col - String_ string row col -> - Encode.object - [ ( "type", Encode.string "String" ) - , ( "string", stringEncoder string ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PString string row col -> + pStringEncoder string row col - Number number row col -> - Encode.object - [ ( "type", Encode.string "Number" ) - , ( "number", numberEncoder number ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PNumber number row col -> + pNumberEncoder number row col - Space space row col -> - Encode.object - [ ( "type", Encode.string "Space" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PFloat width row col -> + pFloatEncoder width row col - EndlessShader row col -> - Encode.object - [ ( "type", Encode.string "EndlessShader" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PAlias row col -> + pAliasEncoder row col - ShaderProblem problem row col -> - Encode.object - [ ( "type", Encode.string "ShaderProblem" ) - , ( "problem", Encode.string problem ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PWildcardNotVar name width row col -> + pWildcardNotVarEncoder name width row col - IndentOperatorRight op row col -> - Encode.object - [ ( "type", Encode.string "IndentOperatorRight" ) - , ( "op", Encode.string op ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PSpace space row col -> + pSpaceEncoder space row col + PIndentStart row col -> + pIndentStartEncoder row col -exprDecoder : Decode.Decoder Expr -exprDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Let" -> - Decode.map3 Let - (Decode.field "let" letDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Case" -> - Decode.map3 Case - (Decode.field "case" caseDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "If" -> - Decode.map3 If - (Decode.field "if" ifDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "List" -> - Decode.map3 List - (Decode.field "list" listDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Record" -> - Decode.map3 Record - (Decode.field "record" recordDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Tuple" -> - Decode.map3 Tuple - (Decode.field "tuple" tupleDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Func" -> - Decode.map3 Func - (Decode.field "func" funcDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Dot" -> - Decode.map2 Dot - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Access" -> - Decode.map2 Access - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "OperatorRight" -> - Decode.map3 OperatorRight - (Decode.field "op" Decode.string) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "OperatorReserved" -> - Decode.map3 OperatorReserved - (Decode.field "operator" Compiler.Parse.Symbol.badOperatorDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Start" -> - Decode.map2 Start - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Char" -> - Decode.map3 Char - (Decode.field "char" charDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "String" -> - Decode.map3 String_ - (Decode.field "string" stringDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Number" -> - Decode.map3 Number - (Decode.field "number" numberDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "Space" -> - Decode.map3 Space - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "EndlessShader" -> - Decode.map2 EndlessShader - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ShaderProblem" -> - Decode.map3 ShaderProblem - (Decode.field "problem" Decode.string) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IndentOperatorRight" -> - Decode.map3 IndentOperatorRight - (Decode.field "op" Decode.string) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Expr's type: " ++ type_) - ) + PIndentAlias row col -> + pIndentAliasEncoder row col + ) + |> Serialize.variant3 PRecord pRecordCodec Serialize.int Serialize.int + |> Serialize.variant3 PTuple (Serialize.lazy (\() -> pTupleCodec)) Serialize.int Serialize.int + |> Serialize.variant3 PList pListCodec Serialize.int Serialize.int + |> Serialize.variant2 PStart Serialize.int Serialize.int + |> Serialize.variant3 PChar charCodec Serialize.int Serialize.int + |> Serialize.variant3 PString string_Codec Serialize.int Serialize.int + |> Serialize.variant3 PNumber numberCodec Serialize.int Serialize.int + |> Serialize.variant3 PFloat Serialize.int Serialize.int Serialize.int + |> Serialize.variant2 PAlias Serialize.int Serialize.int + |> Serialize.variant4 PWildcardNotVar Serialize.string Serialize.int Serialize.int Serialize.int + |> Serialize.variant3 PSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 PIndentStart Serialize.int Serialize.int + |> Serialize.variant2 PIndentAlias Serialize.int Serialize.int + |> Serialize.finishCustomType exprCodec : Codec e Expr @@ -9743,20 +8352,20 @@ exprCodec = IndentOperatorRight op row col -> indentOperatorRightEncoder op row col ) - |> Serialize.variant3 Let letCodec Serialize.int Serialize.int + |> Serialize.variant3 Let (Serialize.lazy (\() -> letCodec)) Serialize.int Serialize.int |> Serialize.variant3 Case caseCodec Serialize.int Serialize.int - |> Serialize.variant3 If ifCodec Serialize.int Serialize.int - |> Serialize.variant3 List listCodec Serialize.int Serialize.int - |> Serialize.variant3 Record recordCodec Serialize.int Serialize.int - |> Serialize.variant3 Tuple tupleCodec Serialize.int Serialize.int - |> Serialize.variant3 Func funcCodec Serialize.int Serialize.int + |> Serialize.variant3 If (Serialize.lazy (\() -> ifCodec)) Serialize.int Serialize.int + |> Serialize.variant3 List (Serialize.lazy (\() -> listCodec)) Serialize.int Serialize.int + |> Serialize.variant3 Record (Serialize.lazy (\() -> recordCodec)) Serialize.int Serialize.int + |> Serialize.variant3 Tuple (Serialize.lazy (\() -> tupleCodec)) Serialize.int Serialize.int + |> Serialize.variant3 Func (Serialize.lazy (\() -> funcCodec)) Serialize.int Serialize.int |> Serialize.variant2 Dot Serialize.int Serialize.int |> Serialize.variant2 Access Serialize.int Serialize.int |> Serialize.variant3 OperatorRight Serialize.string Serialize.int Serialize.int |> Serialize.variant3 OperatorReserved Compiler.Parse.Symbol.badOperatorCodec Serialize.int Serialize.int |> Serialize.variant2 Start Serialize.int Serialize.int |> Serialize.variant3 Char charCodec Serialize.int Serialize.int - |> Serialize.variant3 String_ stringCodec Serialize.int Serialize.int + |> Serialize.variant3 String_ string_Codec Serialize.int Serialize.int |> Serialize.variant3 Number numberCodec Serialize.int Serialize.int |> Serialize.variant3 Space spaceCodec Serialize.int Serialize.int |> Serialize.variant2 EndlessShader Serialize.int Serialize.int @@ -9765,2235 +8374,773 @@ exprCodec = |> Serialize.finishCustomType -letEncoder : Let -> Encode.Value -letEncoder let_ = - case let_ of - LetSpace space row col -> - Encode.object - [ ( "type", Encode.string "LetSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +letCodec : Codec e Let +letCodec = + Serialize.customType + (\letSpaceEncoder letInEncoder letDefAlignmentEncoder letDefNameEncoder letDefEncoder letDestructEncoder letBodyEncoder letIndentDefEncoder letIndentInEncoder letIndentBodyEncoder value -> + case value of + LetSpace space row col -> + letSpaceEncoder space row col - LetIn row col -> - Encode.object - [ ( "type", Encode.string "LetIn" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetIn row col -> + letInEncoder row col - LetDefAlignment int row col -> - Encode.object - [ ( "type", Encode.string "LetDefAlignment" ) - , ( "int", Encode.int int ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetDefAlignment int row col -> + letDefAlignmentEncoder int row col - LetDefName row col -> - Encode.object - [ ( "type", Encode.string "LetDefName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetDefName row col -> + letDefNameEncoder row col - LetDef name def row col -> - Encode.object - [ ( "type", Encode.string "LetDef" ) - , ( "name", Encode.string name ) - , ( "def", defEncoder def ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetDef name def row col -> + letDefEncoder name def row col - LetDestruct destruct row col -> - Encode.object - [ ( "type", Encode.string "LetDestruct" ) - , ( "destruct", destructEncoder destruct ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetDestruct destruct row col -> + letDestructEncoder destruct row col - LetBody expr row col -> - Encode.object - [ ( "type", Encode.string "LetBody" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetBody expr row col -> + letBodyEncoder expr row col - LetIndentDef row col -> - Encode.object - [ ( "type", Encode.string "LetIndentDef" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetIndentDef row col -> + letIndentDefEncoder row col - LetIndentIn row col -> - Encode.object - [ ( "type", Encode.string "LetIndentIn" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetIndentIn row col -> + letIndentInEncoder row col - LetIndentBody row col -> - Encode.object - [ ( "type", Encode.string "LetIndentBody" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + LetIndentBody row col -> + letIndentBodyEncoder row col + ) + |> Serialize.variant3 LetSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 LetIn Serialize.int Serialize.int + |> Serialize.variant3 LetDefAlignment Serialize.int Serialize.int Serialize.int + |> Serialize.variant2 LetDefName Serialize.int Serialize.int + |> Serialize.variant4 LetDef Serialize.string defCodec Serialize.int Serialize.int + |> Serialize.variant3 LetDestruct destructCodec Serialize.int Serialize.int + |> Serialize.variant3 LetBody exprCodec Serialize.int Serialize.int + |> Serialize.variant2 LetIndentDef Serialize.int Serialize.int + |> Serialize.variant2 LetIndentIn Serialize.int Serialize.int + |> Serialize.variant2 LetIndentBody Serialize.int Serialize.int + |> Serialize.finishCustomType -letDecoder : Decode.Decoder Let -letDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "LetSpace" -> - Decode.map3 LetSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetIn" -> - Decode.map2 LetIn - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetDefAlignment" -> - Decode.map3 LetDefAlignment - (Decode.field "int" Decode.int) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetDefName" -> - Decode.map2 LetDefName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetDef" -> - Decode.map4 LetDef - (Decode.field "name" Decode.string) - (Decode.field "def" defDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetDestruct" -> - Decode.map3 LetDestruct - (Decode.field "destruct" destructDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetBody" -> - Decode.map3 LetBody - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetIndentDef" -> - Decode.map2 LetIndentDef - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetIndentIn" -> - Decode.map2 LetIndentIn - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "LetIndentBody" -> - Decode.map2 LetIndentBody - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Let's type: " ++ type_) - ) +caseCodec : Codec e Case +caseCodec = + Serialize.customType + (\caseSpaceEncoder caseOfEncoder casePatternEncoder caseArrowEncoder caseExprEncoder caseBranchEncoder caseIndentOfEncoder caseIndentExprEncoder caseIndentPatternEncoder caseIndentArrowEncoder caseIndentBranchEncoder casePatternAlignmentEncoder value -> + case value of + CaseSpace space row col -> + caseSpaceEncoder space row col + CaseOf row col -> + caseOfEncoder row col -letCodec : Codec e Let -letCodec = - Debug.todo "letCodec" + CasePattern pattern row col -> + casePatternEncoder pattern row col + CaseArrow row col -> + caseArrowEncoder row col -caseEncoder : Case -> Encode.Value -caseEncoder case_ = - case case_ of - CaseSpace space row col -> - Encode.object - [ ( "type", Encode.string "CaseSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CaseExpr expr row col -> + caseExprEncoder expr row col - CaseOf row col -> - Encode.object - [ ( "type", Encode.string "CaseOf" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CaseBranch expr row col -> + caseBranchEncoder expr row col - CasePattern pattern row col -> - Encode.object - [ ( "type", Encode.string "CasePattern" ) - , ( "pattern", patternEncoder pattern ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CaseIndentOf row col -> + caseIndentOfEncoder row col - CaseArrow row col -> - Encode.object - [ ( "type", Encode.string "CaseArrow" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CaseIndentExpr row col -> + caseIndentExprEncoder row col - CaseExpr expr row col -> - Encode.object - [ ( "type", Encode.string "CaseExpr" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CaseIndentPattern row col -> + caseIndentPatternEncoder row col - CaseBranch expr row col -> - Encode.object - [ ( "type", Encode.string "CaseBranch" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CaseIndentArrow row col -> + caseIndentArrowEncoder row col - CaseIndentOf row col -> - Encode.object - [ ( "type", Encode.string "CaseIndentOf" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CaseIndentBranch row col -> + caseIndentBranchEncoder row col - CaseIndentExpr row col -> - Encode.object - [ ( "type", Encode.string "CaseIndentExpr" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CasePatternAlignment indent row col -> + casePatternAlignmentEncoder indent row col + ) + |> Serialize.variant3 CaseSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 CaseOf Serialize.int Serialize.int + |> Serialize.variant3 CasePattern patternCodec Serialize.int Serialize.int + |> Serialize.variant2 CaseArrow Serialize.int Serialize.int + |> Serialize.variant3 CaseExpr (Serialize.lazy (\() -> exprCodec)) Serialize.int Serialize.int + |> Serialize.variant3 CaseBranch (Serialize.lazy (\() -> exprCodec)) Serialize.int Serialize.int + |> Serialize.variant2 CaseIndentOf Serialize.int Serialize.int + |> Serialize.variant2 CaseIndentExpr Serialize.int Serialize.int + |> Serialize.variant2 CaseIndentPattern Serialize.int Serialize.int + |> Serialize.variant2 CaseIndentArrow Serialize.int Serialize.int + |> Serialize.variant2 CaseIndentBranch Serialize.int Serialize.int + |> Serialize.variant3 CasePatternAlignment Serialize.int Serialize.int Serialize.int + |> Serialize.finishCustomType - CaseIndentPattern row col -> - Encode.object - [ ( "type", Encode.string "CaseIndentPattern" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - CaseIndentArrow row col -> - Encode.object - [ ( "type", Encode.string "CaseIndentArrow" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +ifCodec : Codec e If +ifCodec = + Serialize.customType + (\ifSpaceEncoder ifThenEncoder ifElseEncoder ifElseBranchStartEncoder ifConditionEncoder ifThenBranchEncoder ifElseBranchEncoder ifIndentConditionEncoder ifIndentThenEncoder ifIndentThenBranchEncoder ifIndentElseBranchEncoder ifIndentElseEncoder value -> + case value of + IfSpace space row col -> + ifSpaceEncoder space row col - CaseIndentBranch row col -> - Encode.object - [ ( "type", Encode.string "CaseIndentBranch" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + IfThen row col -> + ifThenEncoder row col - CasePatternAlignment indent row col -> - Encode.object - [ ( "type", Encode.string "CasePatternAlignment" ) - , ( "indent", Encode.int indent ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + IfElse row col -> + ifElseEncoder row col + IfElseBranchStart row col -> + ifElseBranchStartEncoder row col -caseDecoder : Decode.Decoder Case -caseDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "CaseSpace" -> - Decode.map3 CaseSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseOf" -> - Decode.map2 CaseOf - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CasePattern" -> - Decode.map3 CasePattern - (Decode.field "pattern" patternDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseArrow" -> - Decode.map2 CaseArrow - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseExpr" -> - Decode.map3 CaseExpr - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseBranch" -> - Decode.map3 CaseBranch - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseIndentOf" -> - Decode.map2 CaseIndentOf - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseIndentExpr" -> - Decode.map2 CaseIndentExpr - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseIndentPattern" -> - Decode.map2 CaseIndentPattern - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseIndentArrow" -> - Decode.map2 CaseIndentArrow - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CaseIndentBranch" -> - Decode.map2 CaseIndentBranch - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CasePatternAlignment" -> - Decode.map3 CasePatternAlignment - (Decode.field "indent" Decode.int) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Case's type: " ++ type_) - ) + IfCondition expr row col -> + ifConditionEncoder expr row col + IfThenBranch expr row col -> + ifThenBranchEncoder expr row col -caseCodec : Codec e Case -caseCodec = - Debug.todo "caseCodec" + IfElseBranch expr row col -> + ifElseBranchEncoder expr row col + IfIndentCondition row col -> + ifIndentConditionEncoder row col -ifEncoder : If -> Encode.Value -ifEncoder if_ = - case if_ of - IfSpace space row col -> - Encode.object - [ ( "type", Encode.string "IfSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + IfIndentThen row col -> + ifIndentThenEncoder row col - IfThen row col -> - Encode.object - [ ( "type", Encode.string "IfThen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + IfIndentThenBranch row col -> + ifIndentThenBranchEncoder row col - IfElse row col -> - Encode.object - [ ( "type", Encode.string "IfElse" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + IfIndentElseBranch row col -> + ifIndentElseBranchEncoder row col - IfElseBranchStart row col -> - Encode.object - [ ( "type", Encode.string "IfElseBranchStart" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + IfIndentElse row col -> + ifIndentElseEncoder row col + ) + |> Serialize.variant3 IfSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 IfThen Serialize.int Serialize.int + |> Serialize.variant2 IfElse Serialize.int Serialize.int + |> Serialize.variant2 IfElseBranchStart Serialize.int Serialize.int + |> Serialize.variant3 IfCondition exprCodec Serialize.int Serialize.int + |> Serialize.variant3 IfThenBranch exprCodec Serialize.int Serialize.int + |> Serialize.variant3 IfElseBranch exprCodec Serialize.int Serialize.int + |> Serialize.variant2 IfIndentCondition Serialize.int Serialize.int + |> Serialize.variant2 IfIndentThen Serialize.int Serialize.int + |> Serialize.variant2 IfIndentThenBranch Serialize.int Serialize.int + |> Serialize.variant2 IfIndentElseBranch Serialize.int Serialize.int + |> Serialize.variant2 IfIndentElse Serialize.int Serialize.int + |> Serialize.finishCustomType - IfCondition expr row col -> - Encode.object - [ ( "type", Encode.string "IfCondition" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - IfThenBranch expr row col -> - Encode.object - [ ( "type", Encode.string "IfThenBranch" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +listCodec : Codec e List_ +listCodec = + Serialize.customType + (\listSpaceEncoder listOpenEncoder listExprEncoder listEndEncoder listIndentOpenEncoder listIndentEndEncoder listIndentExprEncoder value -> + case value of + ListSpace space row col -> + listSpaceEncoder space row col - IfElseBranch expr row col -> - Encode.object - [ ( "type", Encode.string "IfElseBranch" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + ListOpen row col -> + listOpenEncoder row col - IfIndentCondition row col -> - Encode.object - [ ( "type", Encode.string "IfIndentCondition" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + ListExpr expr row col -> + listExprEncoder expr row col - IfIndentThen row col -> - Encode.object - [ ( "type", Encode.string "IfIndentThen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + ListEnd row col -> + listEndEncoder row col - IfIndentThenBranch row col -> - Encode.object - [ ( "type", Encode.string "IfIndentThenBranch" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + ListIndentOpen row col -> + listIndentOpenEncoder row col - IfIndentElseBranch row col -> - Encode.object - [ ( "type", Encode.string "IfIndentElseBranch" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + ListIndentEnd row col -> + listIndentEndEncoder row col - IfIndentElse row col -> - Encode.object - [ ( "type", Encode.string "IfIndentElse" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + ListIndentExpr row col -> + listIndentExprEncoder row col + ) + |> Serialize.variant3 ListSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 ListOpen Serialize.int Serialize.int + |> Serialize.variant3 ListExpr exprCodec Serialize.int Serialize.int + |> Serialize.variant2 ListEnd Serialize.int Serialize.int + |> Serialize.variant2 ListIndentOpen Serialize.int Serialize.int + |> Serialize.variant2 ListIndentEnd Serialize.int Serialize.int + |> Serialize.variant2 ListIndentExpr Serialize.int Serialize.int + |> Serialize.finishCustomType -ifDecoder : Decode.Decoder If -ifDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "IfSpace" -> - Decode.map3 IfSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfThen" -> - Decode.map2 IfThen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfElse" -> - Decode.map2 IfElse - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfElseBranchStart" -> - Decode.map2 IfElseBranchStart - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfCondition" -> - Decode.map3 IfCondition - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfThenBranch" -> - Decode.map3 IfThenBranch - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfElseBranch" -> - Decode.map3 IfElseBranch - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfIndentCondition" -> - Decode.map2 IfIndentCondition - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfIndentThen" -> - Decode.map2 IfIndentThen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfIndentThenBranch" -> - Decode.map2 IfIndentThenBranch - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfIndentElseBranch" -> - Decode.map2 IfIndentElseBranch - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "IfIndentElse" -> - Decode.map2 IfIndentElse - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode If's type: " ++ type_) - ) +recordCodec : Codec e Record +recordCodec = + Serialize.customType + (\recordOpenEncoder recordEndEncoder recordFieldEncoder recordEqualsEncoder recordExprEncoder recordSpaceEncoder recordIndentOpenEncoder recordIndentEndEncoder recordIndentFieldEncoder recordIndentEqualsEncoder recordIndentExprEncoder value -> + case value of + RecordOpen row col -> + recordOpenEncoder row col + RecordEnd row col -> + recordEndEncoder row col -ifCodec : Codec e If -ifCodec = - Debug.todo "ifCodec" + RecordField row col -> + recordFieldEncoder row col + RecordEquals row col -> + recordEqualsEncoder row col -listEncoder : List_ -> Encode.Value -listEncoder list_ = - case list_ of - ListSpace space row col -> - Encode.object - [ ( "type", Encode.string "ListSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + RecordExpr expr row col -> + recordExprEncoder expr row col - ListOpen row col -> - Encode.object - [ ( "type", Encode.string "ListOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + RecordSpace space row col -> + recordSpaceEncoder space row col - ListExpr expr row col -> - Encode.object - [ ( "type", Encode.string "ListExpr" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + RecordIndentOpen row col -> + recordIndentOpenEncoder row col - ListEnd row col -> - Encode.object - [ ( "type", Encode.string "ListEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + RecordIndentEnd row col -> + recordIndentEndEncoder row col - ListIndentOpen row col -> - Encode.object - [ ( "type", Encode.string "ListIndentOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + RecordIndentField row col -> + recordIndentFieldEncoder row col - ListIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "ListIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + RecordIndentEquals row col -> + recordIndentEqualsEncoder row col - ListIndentExpr row col -> - Encode.object - [ ( "type", Encode.string "ListIndentExpr" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + RecordIndentExpr row col -> + recordIndentExprEncoder row col + ) + |> Serialize.variant2 RecordOpen Serialize.int Serialize.int + |> Serialize.variant2 RecordEnd Serialize.int Serialize.int + |> Serialize.variant2 RecordField Serialize.int Serialize.int + |> Serialize.variant2 RecordEquals Serialize.int Serialize.int + |> Serialize.variant3 RecordExpr exprCodec Serialize.int Serialize.int + |> Serialize.variant3 RecordSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 RecordIndentOpen Serialize.int Serialize.int + |> Serialize.variant2 RecordIndentEnd Serialize.int Serialize.int + |> Serialize.variant2 RecordIndentField Serialize.int Serialize.int + |> Serialize.variant2 RecordIndentEquals Serialize.int Serialize.int + |> Serialize.variant2 RecordIndentExpr Serialize.int Serialize.int + |> Serialize.finishCustomType -listDecoder : Decode.Decoder List_ -listDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ListSpace" -> - Decode.map3 ListSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ListOpen" -> - Decode.map2 ListOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ListExpr" -> - Decode.map3 ListExpr - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ListEnd" -> - Decode.map2 ListEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ListIndentOpen" -> - Decode.map2 ListIndentOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ListIndentEnd" -> - Decode.map2 ListIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "ListIndentExpr" -> - Decode.map2 ListIndentExpr - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode List's type: " ++ type_) - ) +tupleCodec : Codec e Tuple +tupleCodec = + Serialize.customType + (\tupleExprEncoder tupleSpaceEncoder tupleEndEncoder tupleOperatorCloseEncoder tupleOperatorReservedEncoder tupleIndentExpr1Encoder tupleIndentExprNEncoder tupleIndentEndEncoder value -> + case value of + TupleExpr expr row col -> + tupleExprEncoder expr row col + TupleSpace space row col -> + tupleSpaceEncoder space row col -listCodec : Codec e List_ -listCodec = - Debug.todo "listCodec" + TupleEnd row col -> + tupleEndEncoder row col + TupleOperatorClose row col -> + tupleOperatorCloseEncoder row col -recordEncoder : Record -> Encode.Value -recordEncoder record = - case record of - RecordOpen row col -> - Encode.object - [ ( "type", Encode.string "RecordOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TupleOperatorReserved operator row col -> + tupleOperatorReservedEncoder operator row col - RecordEnd row col -> - Encode.object - [ ( "type", Encode.string "RecordEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TupleIndentExpr1 row col -> + tupleIndentExpr1Encoder row col - RecordField row col -> - Encode.object - [ ( "type", Encode.string "RecordField" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TupleIndentExprN row col -> + tupleIndentExprNEncoder row col - RecordEquals row col -> - Encode.object - [ ( "type", Encode.string "RecordEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - RecordExpr expr row col -> - Encode.object - [ ( "type", Encode.string "RecordExpr" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - RecordSpace space row col -> - Encode.object - [ ( "type", Encode.string "RecordSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - RecordIndentOpen row col -> - Encode.object - [ ( "type", Encode.string "RecordIndentOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - RecordIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "RecordIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - RecordIndentField row col -> - Encode.object - [ ( "type", Encode.string "RecordIndentField" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - RecordIndentEquals row col -> - Encode.object - [ ( "type", Encode.string "RecordIndentEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - RecordIndentExpr row col -> - Encode.object - [ ( "type", Encode.string "RecordIndentExpr" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -recordDecoder : Decode.Decoder Record -recordDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "RecordOpen" -> - Decode.map2 RecordOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordEnd" -> - Decode.map2 RecordEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordField" -> - Decode.map2 RecordField - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordEquals" -> - Decode.map2 RecordEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordExpr" -> - Decode.map3 RecordExpr - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordSpace" -> - Decode.map3 RecordSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordIndentOpen" -> - Decode.map2 RecordIndentOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordIndentEnd" -> - Decode.map2 RecordIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordIndentField" -> - Decode.map2 RecordIndentField - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordIndentEquals" -> - Decode.map2 RecordIndentEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "RecordIndentExpr" -> - Decode.map2 RecordIndentExpr - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Record's type: " ++ type_) - ) - - -recordCodec : Codec e Record -recordCodec = - Debug.todo "recordCodec" - - -tupleEncoder : Tuple -> Encode.Value -tupleEncoder tuple = - case tuple of - TupleExpr expr row col -> - Encode.object - [ ( "type", Encode.string "TupleExpr" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TupleSpace space row col -> - Encode.object - [ ( "type", Encode.string "TupleSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TupleEnd row col -> - Encode.object - [ ( "type", Encode.string "TupleEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TupleOperatorClose row col -> - Encode.object - [ ( "type", Encode.string "TupleOperatorClose" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TupleOperatorReserved operator row col -> - Encode.object - [ ( "type", Encode.string "TupleOperatorReserved" ) - , ( "operator", Compiler.Parse.Symbol.badOperatorEncoder operator ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TupleIndentExpr1 row col -> - Encode.object - [ ( "type", Encode.string "TupleIndentExpr1" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TupleIndentExprN row col -> - Encode.object - [ ( "type", Encode.string "TupleIndentExprN" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - TupleIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "TupleIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -tupleDecoder : Decode.Decoder Tuple -tupleDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "TupleExpr" -> - Decode.map3 TupleExpr - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TupleSpace" -> - Decode.map3 TupleSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TupleEnd" -> - Decode.map2 TupleEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TupleOperatorClose" -> - Decode.map2 TupleOperatorClose - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TupleOperatorReserved" -> - Decode.map3 TupleOperatorReserved - (Decode.field "operator" Compiler.Parse.Symbol.badOperatorDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TupleIndentExpr1" -> - Decode.map2 TupleIndentExpr1 - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TupleIndentExprN" -> - Decode.map2 TupleIndentExprN - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TupleIndentEnd" -> - Decode.map2 TupleIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Tuple's type: " ++ type_) - ) - - -tupleCodec : Codec e Tuple -tupleCodec = - Debug.todo "tupleCodec" - - -funcEncoder : Func -> Encode.Value -funcEncoder func = - case func of - FuncSpace space row col -> - Encode.object - [ ( "type", Encode.string "FuncSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - FuncArg pattern row col -> - Encode.object - [ ( "type", Encode.string "FuncArg" ) - , ( "pattern", patternEncoder pattern ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - FuncBody expr row col -> - Encode.object - [ ( "type", Encode.string "FuncBody" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - FuncArrow row col -> - Encode.object - [ ( "type", Encode.string "FuncArrow" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - FuncIndentArg row col -> - Encode.object - [ ( "type", Encode.string "FuncIndentArg" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - FuncIndentArrow row col -> - Encode.object - [ ( "type", Encode.string "FuncIndentArrow" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - FuncIndentBody row col -> - Encode.object - [ ( "type", Encode.string "FuncIndentBody" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - -funcDecoder : Decode.Decoder Func -funcDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "FuncSpace" -> - Decode.map3 FuncSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "FuncArg" -> - Decode.map3 FuncArg - (Decode.field "pattern" patternDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "FuncBody" -> - Decode.map3 FuncBody - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "FuncArrow" -> - Decode.map2 FuncArrow - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "FuncIndentArg" -> - Decode.map2 FuncIndentArg - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "FuncIndentArrow" -> - Decode.map2 FuncIndentArrow - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "FuncIndentBody" -> - Decode.map2 FuncIndentBody - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Func's type: " ++ type_) - ) + TupleIndentEnd row col -> + tupleIndentEndEncoder row col + ) + |> Serialize.variant3 TupleExpr exprCodec Serialize.int Serialize.int + |> Serialize.variant3 TupleSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 TupleEnd Serialize.int Serialize.int + |> Serialize.variant2 TupleOperatorClose Serialize.int Serialize.int + |> Serialize.variant3 TupleOperatorReserved Compiler.Parse.Symbol.badOperatorCodec Serialize.int Serialize.int + |> Serialize.variant2 TupleIndentExpr1 Serialize.int Serialize.int + |> Serialize.variant2 TupleIndentExprN Serialize.int Serialize.int + |> Serialize.variant2 TupleIndentEnd Serialize.int Serialize.int + |> Serialize.finishCustomType funcCodec : Codec e Func funcCodec = - Debug.todo "funcCodec" - - -charEncoder : Char -> Encode.Value -charEncoder char = - case char of - CharEndless -> - Encode.object - [ ( "type", Encode.string "CharEndless" ) - ] - - CharEscape escape -> - Encode.object - [ ( "type", Encode.string "CharEscape" ) - , ( "escape", escapeEncoder escape ) - ] + Serialize.customType + (\funcSpaceEncoder funcArgEncoder funcBodyEncoder funcArrowEncoder funcIndentArgEncoder funcIndentArrowEncoder funcIndentBodyEncoder value -> + case value of + FuncSpace space row col -> + funcSpaceEncoder space row col - CharNotString width -> - Encode.object - [ ( "type", Encode.string "CharNotString" ) - , ( "width", Encode.int width ) - ] + FuncArg pattern row col -> + funcArgEncoder pattern row col + FuncBody expr row col -> + funcBodyEncoder expr row col -charDecoder : Decode.Decoder Char -charDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "CharEndless" -> - Decode.succeed CharEndless + FuncArrow row col -> + funcArrowEncoder row col - "CharEscape" -> - Decode.map CharEscape (Decode.field "escape" escapeDecoder) + FuncIndentArg row col -> + funcIndentArgEncoder row col - "CharNotString" -> - Decode.map CharNotString (Decode.field "width" Decode.int) + FuncIndentArrow row col -> + funcIndentArrowEncoder row col - _ -> - Decode.fail ("Failed to decode Char's type: " ++ type_) - ) + FuncIndentBody row col -> + funcIndentBodyEncoder row col + ) + |> Serialize.variant3 FuncSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant3 FuncArg patternCodec Serialize.int Serialize.int + |> Serialize.variant3 FuncBody exprCodec Serialize.int Serialize.int + |> Serialize.variant2 FuncArrow Serialize.int Serialize.int + |> Serialize.variant2 FuncIndentArg Serialize.int Serialize.int + |> Serialize.variant2 FuncIndentArrow Serialize.int Serialize.int + |> Serialize.variant2 FuncIndentBody Serialize.int Serialize.int + |> Serialize.finishCustomType charCodec : Codec e Char charCodec = - Debug.todo "charCodec" - - -stringEncoder : String_ -> Encode.Value -stringEncoder string_ = - case string_ of - StringEndless_Single -> - Encode.object - [ ( "type", Encode.string "StringEndless_Single" ) ] - - StringEndless_Multi -> - Encode.object - [ ( "type", Encode.string "StringEndless_Multi" ) ] - - StringEscape escape -> - Encode.object - [ ( "type", Encode.string "StringEscape" ) - , ( "escape", escapeEncoder escape ) - ] - - -stringDecoder : Decode.Decoder String_ -stringDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "StringEndless_Single" -> - Decode.succeed StringEndless_Single - - "StringEndless_Multi" -> - Decode.succeed StringEndless_Multi - - "StringEscape" -> - Decode.map StringEscape (Decode.field "escape" escapeDecoder) - - _ -> - Decode.fail ("Failed to decode String's type: " ++ type_) - ) - - -stringCodec : Codec e String_ -stringCodec = - Debug.todo "stringCodec" - - -numberEncoder : Number -> Encode.Value -numberEncoder number = - case number of - NumberEnd -> - Encode.object - [ ( "type", Encode.string "NumberEnd" ) - ] - - NumberDot n -> - Encode.object - [ ( "type", Encode.string "NumberDot" ) - , ( "n", Encode.int n ) - ] - - NumberHexDigit -> - Encode.object - [ ( "type", Encode.string "NumberHexDigit" ) - ] - - NumberNoLeadingZero -> - Encode.object - [ ( "type", Encode.string "NumberNoLeadingZero" ) - ] + Serialize.customType + (\charEndlessEncoder charEscapeEncoder charNotStringEncoder value -> + case value of + CharEndless -> + charEndlessEncoder + CharEscape escape -> + charEscapeEncoder escape -numberDecoder : Decode.Decoder Number -numberDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NumberEnd" -> - Decode.succeed NumberEnd + CharNotString width -> + charNotStringEncoder width + ) + |> Serialize.variant0 CharEndless + |> Serialize.variant1 CharEscape escapeCodec + |> Serialize.variant1 CharNotString Serialize.int + |> Serialize.finishCustomType - "NumberDot" -> - Decode.map NumberDot (Decode.field "n" Decode.int) - "NumberHexDigit" -> - Decode.succeed NumberHexDigit +string_Codec : Codec e String_ +string_Codec = + Serialize.customType + (\stringEndless_SingleEncoder stringEndless_MultiEncoder stringEscapeEncoder value -> + case value of + StringEndless_Single -> + stringEndless_SingleEncoder - "NumberNoLeadingZero" -> - Decode.succeed NumberNoLeadingZero + StringEndless_Multi -> + stringEndless_MultiEncoder - _ -> - Decode.fail ("Failed to decode Number's type: " ++ type_) - ) + StringEscape escape -> + stringEscapeEncoder escape + ) + |> Serialize.variant0 StringEndless_Single + |> Serialize.variant0 StringEndless_Multi + |> Serialize.variant1 StringEscape escapeCodec + |> Serialize.finishCustomType numberCodec : Codec e Number numberCodec = - Debug.todo "numberCodec" - - -escapeEncoder : Escape -> Encode.Value -escapeEncoder escape = - case escape of - EscapeUnknown -> - Encode.object - [ ( "type", Encode.string "EscapeUnknown" ) - ] - - BadUnicodeFormat width -> - Encode.object - [ ( "type", Encode.string "BadUnicodeFormat" ) - , ( "width", Encode.int width ) - ] - - BadUnicodeCode width -> - Encode.object - [ ( "type", Encode.string "BadUnicodeCode" ) - , ( "width", Encode.int width ) - ] - - BadUnicodeLength width numDigits badCode -> - Encode.object - [ ( "type", Encode.string "BadUnicodeLength" ) - , ( "width", Encode.int width ) - , ( "numDigits", Encode.int numDigits ) - , ( "badCode", Encode.int badCode ) - ] - - -escapeDecoder : Decode.Decoder Escape -escapeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "EscapeUnknown" -> - Decode.succeed EscapeUnknown - - "BadUnicodeFormat" -> - Decode.map BadUnicodeFormat (Decode.field "width" Decode.int) - - "BadUnicodeCode" -> - Decode.map BadUnicodeCode (Decode.field "width" Decode.int) - - "BadUnicodeLength" -> - Decode.map3 BadUnicodeLength - (Decode.field "width" Decode.int) - (Decode.field "numDigits" Decode.int) - (Decode.field "badCode" Decode.int) - - _ -> - Decode.fail ("Failed to decode Escape's type: " ++ type_) - ) - - -defEncoder : Def -> Encode.Value -defEncoder def = - case def of - DefSpace space row col -> - Encode.object - [ ( "type", Encode.string "DefSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefType tipe row col -> - Encode.object - [ ( "type", Encode.string "DefType" ) - , ( "tipe", typeEncoder tipe ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefNameRepeat row col -> - Encode.object - [ ( "type", Encode.string "DefNameRepeat" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefNameMatch name row col -> - Encode.object - [ ( "type", Encode.string "DefNameMatch" ) - , ( "name", Encode.string name ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefArg pattern row col -> - Encode.object - [ ( "type", Encode.string "DefArg" ) - , ( "pattern", patternEncoder pattern ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefEquals row col -> - Encode.object - [ ( "type", Encode.string "DefEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefBody expr row col -> - Encode.object - [ ( "type", Encode.string "DefBody" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefIndentEquals row col -> - Encode.object - [ ( "type", Encode.string "DefIndentEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - - DefIndentType row col -> - Encode.object - [ ( "type", Encode.string "DefIndentType" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + Serialize.customType + (\numberEndEncoder numberDotEncoder numberHexDigitEncoder numberNoLeadingZeroEncoder value -> + case value of + NumberEnd -> + numberEndEncoder - DefIndentBody row col -> - Encode.object - [ ( "type", Encode.string "DefIndentBody" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + NumberDot n -> + numberDotEncoder n - DefAlignment indent row col -> - Encode.object - [ ( "type", Encode.string "DefAlignment" ) - , ( "indent", Encode.int indent ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + NumberHexDigit -> + numberHexDigitEncoder + NumberNoLeadingZero -> + numberNoLeadingZeroEncoder + ) + |> Serialize.variant0 NumberEnd + |> Serialize.variant1 NumberDot Serialize.int + |> Serialize.variant0 NumberHexDigit + |> Serialize.variant0 NumberNoLeadingZero + |> Serialize.finishCustomType -defDecoder : Decode.Decoder Def -defDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "DefSpace" -> - Decode.map3 DefSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefType" -> - Decode.map3 DefType - (Decode.field "tipe" typeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefNameRepeat" -> - Decode.map2 DefNameRepeat - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefNameMatch" -> - Decode.map3 DefNameMatch - (Decode.field "name" Decode.string) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefArg" -> - Decode.map3 DefArg - (Decode.field "pattern" patternDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefEquals" -> - Decode.map2 DefEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefBody" -> - Decode.map3 DefBody - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefIndentEquals" -> - Decode.map2 DefIndentEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefIndentType" -> - Decode.map2 DefIndentType - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefIndentBody" -> - Decode.map2 DefIndentBody - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DefAlignment" -> - Decode.map3 DefAlignment - (Decode.field "indent" Decode.int) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Def's type: " ++ type_) - ) +escapeCodec : Codec e Escape +escapeCodec = + Serialize.customType + (\escapeUnknownEncoder badUnicodeFormatEncoder badUnicodeCodeEncoder badUnicodeLengthEncoder value -> + case value of + EscapeUnknown -> + escapeUnknownEncoder -destructEncoder : Destruct -> Encode.Value -destructEncoder destruct = - case destruct of - DestructSpace space row col -> - Encode.object - [ ( "type", Encode.string "DestructSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + BadUnicodeFormat width -> + badUnicodeFormatEncoder width - DestructPattern pattern row col -> - Encode.object - [ ( "type", Encode.string "DestructPattern" ) - , ( "pattern", patternEncoder pattern ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + BadUnicodeCode width -> + badUnicodeCodeEncoder width - DestructEquals row col -> - Encode.object - [ ( "type", Encode.string "DestructEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + BadUnicodeLength width numDigits badCode -> + badUnicodeLengthEncoder width numDigits badCode + ) + |> Serialize.variant0 EscapeUnknown + |> Serialize.variant1 BadUnicodeFormat Serialize.int + |> Serialize.variant1 BadUnicodeCode Serialize.int + |> Serialize.variant3 BadUnicodeLength Serialize.int Serialize.int Serialize.int + |> Serialize.finishCustomType - DestructBody expr row col -> - Encode.object - [ ( "type", Encode.string "DestructBody" ) - , ( "expr", exprEncoder expr ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - DestructIndentEquals row col -> - Encode.object - [ ( "type", Encode.string "DestructIndentEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +defCodec : Codec e Def +defCodec = + Serialize.customType + (\defSpaceEncoder defTypeEncoder defNameRepeatEncoder defNameMatchEncoder defArgEncoder defEqualsEncoder defBodyEncoder defIndentEqualsEncoder defIndentTypeEncoder defIndentBodyEncoder defAlignmentEncoder value -> + case value of + DefSpace space row col -> + defSpaceEncoder space row col - DestructIndentBody row col -> - Encode.object - [ ( "type", Encode.string "DestructIndentBody" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DefType tipe row col -> + defTypeEncoder tipe row col + DefNameRepeat row col -> + defNameRepeatEncoder row col -destructDecoder : Decode.Decoder Destruct -destructDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "DestructSpace" -> - Decode.map3 DestructSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DestructPattern" -> - Decode.map3 DestructPattern - (Decode.field "pattern" patternDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DestructEquals" -> - Decode.map2 DestructEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DestructBody" -> - Decode.map3 DestructBody - (Decode.field "expr" exprDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DestructIndentEquals" -> - Decode.map2 DestructIndentEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "DestructIndentBody" -> - Decode.map2 DestructIndentBody - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode Destruct's type: " ++ type_) - ) + DefNameMatch name row col -> + defNameMatchEncoder name row col + DefArg pattern row col -> + defArgEncoder pattern row col -pRecordEncoder : PRecord -> Encode.Value -pRecordEncoder pRecord = - case pRecord of - PRecordOpen row col -> - Encode.object - [ ( "type", Encode.string "PRecordOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DefEquals row col -> + defEqualsEncoder row col - PRecordEnd row col -> - Encode.object - [ ( "type", Encode.string "PRecordEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DefBody expr row col -> + defBodyEncoder expr row col - PRecordField row col -> - Encode.object - [ ( "type", Encode.string "PRecordField" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DefIndentEquals row col -> + defIndentEqualsEncoder row col - PRecordSpace space row col -> - Encode.object - [ ( "type", Encode.string "PRecordSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DefIndentType row col -> + defIndentTypeEncoder row col - PRecordIndentOpen row col -> - Encode.object - [ ( "type", Encode.string "PRecordIndentOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DefIndentBody row col -> + defIndentBodyEncoder row col - PRecordIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "PRecordIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DefAlignment indent row col -> + defAlignmentEncoder indent row col + ) + |> Serialize.variant3 DefSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant3 DefType typeCodec Serialize.int Serialize.int + |> Serialize.variant2 DefNameRepeat Serialize.int Serialize.int + |> Serialize.variant3 DefNameMatch Serialize.string Serialize.int Serialize.int + |> Serialize.variant3 DefArg patternCodec Serialize.int Serialize.int + |> Serialize.variant2 DefEquals Serialize.int Serialize.int + |> Serialize.variant3 DefBody exprCodec Serialize.int Serialize.int + |> Serialize.variant2 DefIndentEquals Serialize.int Serialize.int + |> Serialize.variant2 DefIndentType Serialize.int Serialize.int + |> Serialize.variant2 DefIndentBody Serialize.int Serialize.int + |> Serialize.variant3 DefAlignment Serialize.int Serialize.int Serialize.int + |> Serialize.finishCustomType - PRecordIndentField row col -> - Encode.object - [ ( "type", Encode.string "PRecordIndentField" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +destructCodec : Codec e Destruct +destructCodec = + Serialize.customType + (\destructSpaceEncoder destructPatternEncoder destructEqualsEncoder destructBodyEncoder destructIndentEqualsEncoder destructIndentBodyEncoder value -> + case value of + DestructSpace space row col -> + destructSpaceEncoder space row col -pRecordDecoder : Decode.Decoder PRecord -pRecordDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PRecordOpen" -> - Decode.map2 PRecordOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PRecordEnd" -> - Decode.map2 PRecordEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PRecordField" -> - Decode.map2 PRecordField - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PRecordSpace" -> - Decode.map3 PRecordSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PRecordIndentOpen" -> - Decode.map2 PRecordIndentOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PRecordIndentEnd" -> - Decode.map2 PRecordIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PRecordIndentField" -> - Decode.map2 PRecordIndentField - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode PRecord's type: " ++ type_) - ) + DestructPattern pattern row col -> + destructPatternEncoder pattern row col + DestructEquals row col -> + destructEqualsEncoder row col -pTupleEncoder : PTuple -> Encode.Value -pTupleEncoder pTuple = - case pTuple of - PTupleOpen row col -> - Encode.object - [ ( "type", Encode.string "PTupleOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DestructBody expr row col -> + destructBodyEncoder expr row col - PTupleEnd row col -> - Encode.object - [ ( "type", Encode.string "PTupleEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DestructIndentEquals row col -> + destructIndentEqualsEncoder row col - PTupleExpr pattern row col -> - Encode.object - [ ( "type", Encode.string "PTupleExpr" ) - , ( "pattern", patternEncoder pattern ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + DestructIndentBody row col -> + destructIndentBodyEncoder row col + ) + |> Serialize.variant3 DestructSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant3 DestructPattern patternCodec Serialize.int Serialize.int + |> Serialize.variant2 DestructEquals Serialize.int Serialize.int + |> Serialize.variant3 DestructBody exprCodec Serialize.int Serialize.int + |> Serialize.variant2 DestructIndentEquals Serialize.int Serialize.int + |> Serialize.variant2 DestructIndentBody Serialize.int Serialize.int + |> Serialize.finishCustomType - PTupleSpace space row col -> - Encode.object - [ ( "type", Encode.string "PTupleSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - PTupleIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "PTupleIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +pRecordCodec : Codec e PRecord +pRecordCodec = + Serialize.customType + (\pRecordOpenEncoder pRecordEndEncoder pRecordFieldEncoder pRecordSpaceEncoder pRecordIndentOpenEncoder pRecordIndentEndEncoder pRecordIndentFieldEncoder value -> + case value of + PRecordOpen row col -> + pRecordOpenEncoder row col - PTupleIndentExpr1 row col -> - Encode.object - [ ( "type", Encode.string "PTupleIndentExpr1" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PRecordEnd row col -> + pRecordEndEncoder row col - PTupleIndentExprN row col -> - Encode.object - [ ( "type", Encode.string "PTupleIndentExprN" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PRecordField row col -> + pRecordFieldEncoder row col + PRecordSpace space row col -> + pRecordSpaceEncoder space row col -pTupleDecoder : Decode.Decoder PTuple -pTupleDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PTupleOpen" -> - Decode.map2 PTupleOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PTupleEnd" -> - Decode.map2 PTupleEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PTupleExpr" -> - Decode.map3 PTupleExpr - (Decode.field "pattern" patternDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PTupleSpace" -> - Decode.map3 PTupleSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PTupleIndentEnd" -> - Decode.map2 PTupleIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PTupleIndentExpr1" -> - Decode.map2 PTupleIndentExpr1 - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PTupleIndentExprN" -> - Decode.map2 PTupleIndentExprN - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode PTuple's type: " ++ type_) - ) + PRecordIndentOpen row col -> + pRecordIndentOpenEncoder row col + PRecordIndentEnd row col -> + pRecordIndentEndEncoder row col -pListEncoder : PList -> Encode.Value -pListEncoder pList = - case pList of - PListOpen row col -> - Encode.object - [ ( "type", Encode.string "PListOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PRecordIndentField row col -> + pRecordIndentFieldEncoder row col + ) + |> Serialize.variant2 PRecordOpen Serialize.int Serialize.int + |> Serialize.variant2 PRecordEnd Serialize.int Serialize.int + |> Serialize.variant2 PRecordField Serialize.int Serialize.int + |> Serialize.variant3 PRecordSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 PRecordIndentOpen Serialize.int Serialize.int + |> Serialize.variant2 PRecordIndentEnd Serialize.int Serialize.int + |> Serialize.variant2 PRecordIndentField Serialize.int Serialize.int + |> Serialize.finishCustomType - PListEnd row col -> - Encode.object - [ ( "type", Encode.string "PListEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - PListExpr pattern row col -> - Encode.object - [ ( "type", Encode.string "PListExpr" ) - , ( "pattern", patternEncoder pattern ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +pTupleCodec : Codec e PTuple +pTupleCodec = + Serialize.customType + (\pTupleOpenEncoder pTupleEndEncoder pTupleExprEncoder pTupleSpaceEncoder pTupleIndentEndEncoder pTupleIndentExpr1Encoder pTupleIndentExprNEncoder value -> + case value of + PTupleOpen row col -> + pTupleOpenEncoder row col - PListSpace space row col -> - Encode.object - [ ( "type", Encode.string "PListSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PTupleEnd row col -> + pTupleEndEncoder row col - PListIndentOpen row col -> - Encode.object - [ ( "type", Encode.string "PListIndentOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PTupleExpr pattern row col -> + pTupleExprEncoder pattern row col - PListIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "PListIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PTupleSpace space row col -> + pTupleSpaceEncoder space row col - PListIndentExpr row col -> - Encode.object - [ ( "type", Encode.string "PListIndentExpr" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PTupleIndentEnd row col -> + pTupleIndentEndEncoder row col + PTupleIndentExpr1 row col -> + pTupleIndentExpr1Encoder row col -pListDecoder : Decode.Decoder PList -pListDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PListOpen" -> - Decode.map2 PListOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PListEnd" -> - Decode.map2 PListEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PListExpr" -> - Decode.map3 PListExpr - (Decode.field "pattern" patternDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PListSpace" -> - Decode.map3 PListSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PListIndentOpen" -> - Decode.map2 PListIndentOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PListIndentEnd" -> - Decode.map2 PListIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "PListIndentExpr" -> - Decode.map2 PListIndentExpr - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode PList's type: " ++ type_) - ) + PTupleIndentExprN row col -> + pTupleIndentExprNEncoder row col + ) + |> Serialize.variant2 PTupleOpen Serialize.int Serialize.int + |> Serialize.variant2 PTupleEnd Serialize.int Serialize.int + |> Serialize.variant3 PTupleExpr patternCodec Serialize.int Serialize.int + |> Serialize.variant3 PTupleSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 PTupleIndentEnd Serialize.int Serialize.int + |> Serialize.variant2 PTupleIndentExpr1 Serialize.int Serialize.int + |> Serialize.variant2 PTupleIndentExprN Serialize.int Serialize.int + |> Serialize.finishCustomType -tRecordEncoder : TRecord -> Encode.Value -tRecordEncoder tRecord = - case tRecord of - TRecordOpen row col -> - Encode.object - [ ( "type", Encode.string "TRecordOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +pListCodec : Codec e PList +pListCodec = + Serialize.customType + (\pListOpenEncoder pListEndEncoder pListExprEncoder pListSpaceEncoder pListIndentOpenEncoder pListIndentEndEncoder pListIndentExprEncoder value -> + case value of + PListOpen row col -> + pListOpenEncoder row col - TRecordEnd row col -> - Encode.object - [ ( "type", Encode.string "TRecordEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PListEnd row col -> + pListEndEncoder row col - TRecordField row col -> - Encode.object - [ ( "type", Encode.string "TRecordField" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PListExpr pattern row col -> + pListExprEncoder pattern row col - TRecordColon row col -> - Encode.object - [ ( "type", Encode.string "TRecordColon" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PListSpace space row col -> + pListSpaceEncoder space row col - TRecordType tipe row col -> - Encode.object - [ ( "type", Encode.string "TRecordType" ) - , ( "tipe", typeEncoder tipe ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PListIndentOpen row col -> + pListIndentOpenEncoder row col - TRecordSpace space row col -> - Encode.object - [ ( "type", Encode.string "TRecordSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PListIndentEnd row col -> + pListIndentEndEncoder row col - TRecordIndentOpen row col -> - Encode.object - [ ( "type", Encode.string "TRecordIndentOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + PListIndentExpr row col -> + pListIndentExprEncoder row col + ) + |> Serialize.variant2 PListOpen Serialize.int Serialize.int + |> Serialize.variant2 PListEnd Serialize.int Serialize.int + |> Serialize.variant3 PListExpr (Serialize.lazy (\() -> patternCodec)) Serialize.int Serialize.int + |> Serialize.variant3 PListSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 PListIndentOpen Serialize.int Serialize.int + |> Serialize.variant2 PListIndentEnd Serialize.int Serialize.int + |> Serialize.variant2 PListIndentExpr Serialize.int Serialize.int + |> Serialize.finishCustomType - TRecordIndentField row col -> - Encode.object - [ ( "type", Encode.string "TRecordIndentField" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - TRecordIndentColon row col -> - Encode.object - [ ( "type", Encode.string "TRecordIndentColon" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +tRecordCodec : Codec e TRecord +tRecordCodec = + Serialize.customType + (\tRecordOpenEncoder tRecordEndEncoder tRecordFieldEncoder tRecordColonEncoder tRecordTypeEncoder tRecordSpaceEncoder tRecordIndentOpenEncoder tRecordIndentFieldEncoder tRecordIndentColonEncoder tRecordIndentTypeEncoder tRecordIndentEndEncoder value -> + case value of + TRecordOpen row col -> + tRecordOpenEncoder row col - TRecordIndentType row col -> - Encode.object - [ ( "type", Encode.string "TRecordIndentType" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TRecordEnd row col -> + tRecordEndEncoder row col - TRecordIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "TRecordIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TRecordField row col -> + tRecordFieldEncoder row col + TRecordColon row col -> + tRecordColonEncoder row col -tRecordDecoder : Decode.Decoder TRecord -tRecordDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "TRecordOpen" -> - Decode.map2 TRecordOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordEnd" -> - Decode.map2 TRecordEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordField" -> - Decode.map2 TRecordField - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordColon" -> - Decode.map2 TRecordColon - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordType" -> - Decode.map3 TRecordType - (Decode.field "tipe" typeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordSpace" -> - Decode.map3 TRecordSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordIndentOpen" -> - Decode.map2 TRecordIndentOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordIndentField" -> - Decode.map2 TRecordIndentField - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordIndentColon" -> - Decode.map2 TRecordIndentColon - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordIndentType" -> - Decode.map2 TRecordIndentType - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TRecordIndentEnd" -> - Decode.map2 TRecordIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode TRecord's type: " ++ type_) - ) + TRecordType tipe row col -> + tRecordTypeEncoder tipe row col + TRecordSpace space row col -> + tRecordSpaceEncoder space row col -tTupleEncoder : TTuple -> Encode.Value -tTupleEncoder tTuple = - case tTuple of - TTupleOpen row col -> - Encode.object - [ ( "type", Encode.string "TTupleOpen" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TRecordIndentOpen row col -> + tRecordIndentOpenEncoder row col - TTupleEnd row col -> - Encode.object - [ ( "type", Encode.string "TTupleEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TRecordIndentField row col -> + tRecordIndentFieldEncoder row col - TTupleType tipe row col -> - Encode.object - [ ( "type", Encode.string "TTupleType" ) - , ( "tipe", typeEncoder tipe ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TRecordIndentColon row col -> + tRecordIndentColonEncoder row col - TTupleSpace space row col -> - Encode.object - [ ( "type", Encode.string "TTupleSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TRecordIndentType row col -> + tRecordIndentTypeEncoder row col - TTupleIndentType1 row col -> - Encode.object - [ ( "type", Encode.string "TTupleIndentType1" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TRecordIndentEnd row col -> + tRecordIndentEndEncoder row col + ) + |> Serialize.variant2 TRecordOpen Serialize.int Serialize.int + |> Serialize.variant2 TRecordEnd Serialize.int Serialize.int + |> Serialize.variant2 TRecordField Serialize.int Serialize.int + |> Serialize.variant2 TRecordColon Serialize.int Serialize.int + |> Serialize.variant3 TRecordType (Serialize.lazy (\() -> typeCodec)) Serialize.int Serialize.int + |> Serialize.variant3 TRecordSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 TRecordIndentOpen Serialize.int Serialize.int + |> Serialize.variant2 TRecordIndentField Serialize.int Serialize.int + |> Serialize.variant2 TRecordIndentColon Serialize.int Serialize.int + |> Serialize.variant2 TRecordIndentType Serialize.int Serialize.int + |> Serialize.variant2 TRecordIndentEnd Serialize.int Serialize.int + |> Serialize.finishCustomType - TTupleIndentTypeN row col -> - Encode.object - [ ( "type", Encode.string "TTupleIndentTypeN" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - TTupleIndentEnd row col -> - Encode.object - [ ( "type", Encode.string "TTupleIndentEnd" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +tTupleCodec : Codec e TTuple +tTupleCodec = + Serialize.customType + (\tTupleOpenEncoder tTupleEndEncoder tTupleTypeEncoder tTupleSpaceEncoder tTupleIndentType1Encoder tTupleIndentTypeNEncoder tTupleIndentEndEncoder value -> + case value of + TTupleOpen row col -> + tTupleOpenEncoder row col + TTupleEnd row col -> + tTupleEndEncoder row col -tTupleDecoder : Decode.Decoder TTuple -tTupleDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "TTupleOpen" -> - Decode.map2 TTupleOpen - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TTupleEnd" -> - Decode.map2 TTupleEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TTupleType" -> - Decode.map3 TTupleType - (Decode.field "tipe" typeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TTupleSpace" -> - Decode.map3 TTupleSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TTupleIndentType1" -> - Decode.map2 TTupleIndentType1 - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TTupleIndentTypeN" -> - Decode.map2 TTupleIndentTypeN - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "TTupleIndentEnd" -> - Decode.map2 TTupleIndentEnd - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode TTuple's type: " ++ type_) - ) + TTupleType tipe row col -> + tTupleTypeEncoder tipe row col + TTupleSpace space row col -> + tTupleSpaceEncoder space row col -customTypeEncoder : CustomType -> Encode.Value -customTypeEncoder customType = - case customType of - CT_Space space row col -> - Encode.object - [ ( "type", Encode.string "CT_Space" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TTupleIndentType1 row col -> + tTupleIndentType1Encoder row col - CT_Name row col -> - Encode.object - [ ( "type", Encode.string "CT_Name" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TTupleIndentTypeN row col -> + tTupleIndentTypeNEncoder row col - CT_Equals row col -> - Encode.object - [ ( "type", Encode.string "CT_Equals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + TTupleIndentEnd row col -> + tTupleIndentEndEncoder row col + ) + |> Serialize.variant2 TTupleOpen Serialize.int Serialize.int + |> Serialize.variant2 TTupleEnd Serialize.int Serialize.int + |> Serialize.variant3 TTupleType typeCodec Serialize.int Serialize.int + |> Serialize.variant3 TTupleSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 TTupleIndentType1 Serialize.int Serialize.int + |> Serialize.variant2 TTupleIndentTypeN Serialize.int Serialize.int + |> Serialize.variant2 TTupleIndentEnd Serialize.int Serialize.int + |> Serialize.finishCustomType - CT_Bar row col -> - Encode.object - [ ( "type", Encode.string "CT_Bar" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - CT_Variant row col -> - Encode.object - [ ( "type", Encode.string "CT_Variant" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +customTypeCodec : Codec e CustomType +customTypeCodec = + Serialize.customType + (\cT_SpaceEncoder cT_NameEncoder cT_EqualsEncoder cT_BarEncoder cT_VariantEncoder cT_VariantArgEncoder cT_IndentEqualsEncoder cT_IndentBarEncoder cT_IndentAfterBarEncoder cT_IndentAfterEqualsEncoder value -> + case value of + CT_Space space row col -> + cT_SpaceEncoder space row col - CT_VariantArg tipe row col -> - Encode.object - [ ( "type", Encode.string "CT_VariantArg" ) - , ( "tipe", typeEncoder tipe ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CT_Name row col -> + cT_NameEncoder row col - CT_IndentEquals row col -> - Encode.object - [ ( "type", Encode.string "CT_IndentEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CT_Equals row col -> + cT_EqualsEncoder row col - CT_IndentBar row col -> - Encode.object - [ ( "type", Encode.string "CT_IndentBar" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CT_Bar row col -> + cT_BarEncoder row col - CT_IndentAfterBar row col -> - Encode.object - [ ( "type", Encode.string "CT_IndentAfterBar" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CT_Variant row col -> + cT_VariantEncoder row col - CT_IndentAfterEquals row col -> - Encode.object - [ ( "type", Encode.string "CT_IndentAfterEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CT_VariantArg tipe row col -> + cT_VariantArgEncoder tipe row col + CT_IndentEquals row col -> + cT_IndentEqualsEncoder row col -customTypeDecoder : Decode.Decoder CustomType -customTypeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "CT_Space" -> - Decode.map3 CT_Space - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_Name" -> - Decode.map2 CT_Name - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_Equals" -> - Decode.map2 CT_Equals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_Bar" -> - Decode.map2 CT_Bar - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_Variant" -> - Decode.map2 CT_Variant - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_VariantArg" -> - Decode.map3 CT_VariantArg - (Decode.field "tipe" typeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_IndentEquals" -> - Decode.map2 CT_IndentEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_IndentBar" -> - Decode.map2 CT_IndentBar - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_IndentAfterBar" -> - Decode.map2 CT_IndentAfterBar - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "CT_IndentAfterEquals" -> - Decode.map2 CT_IndentAfterEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode CustomType's type: " ++ type_) - ) + CT_IndentBar row col -> + cT_IndentBarEncoder row col + CT_IndentAfterBar row col -> + cT_IndentAfterBarEncoder row col -typeAliasEncoder : TypeAlias -> Encode.Value -typeAliasEncoder typeAlias = - case typeAlias of - AliasSpace space row col -> - Encode.object - [ ( "type", Encode.string "AliasSpace" ) - , ( "space", spaceEncoder space ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + CT_IndentAfterEquals row col -> + cT_IndentAfterEqualsEncoder row col + ) + |> Serialize.variant3 CT_Space spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 CT_Name Serialize.int Serialize.int + |> Serialize.variant2 CT_Equals Serialize.int Serialize.int + |> Serialize.variant2 CT_Bar Serialize.int Serialize.int + |> Serialize.variant2 CT_Variant Serialize.int Serialize.int + |> Serialize.variant3 CT_VariantArg typeCodec Serialize.int Serialize.int + |> Serialize.variant2 CT_IndentEquals Serialize.int Serialize.int + |> Serialize.variant2 CT_IndentBar Serialize.int Serialize.int + |> Serialize.variant2 CT_IndentAfterBar Serialize.int Serialize.int + |> Serialize.variant2 CT_IndentAfterEquals Serialize.int Serialize.int + |> Serialize.finishCustomType - AliasName row col -> - Encode.object - [ ( "type", Encode.string "AliasName" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] - AliasEquals row col -> - Encode.object - [ ( "type", Encode.string "AliasEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] +typeAliasCodec : Codec e TypeAlias +typeAliasCodec = + Serialize.customType + (\aliasSpaceEncoder aliasNameEncoder aliasEqualsEncoder aliasBodyEncoder aliasIndentEqualsEncoder aliasIndentBodyEncoder value -> + case value of + AliasSpace space row col -> + aliasSpaceEncoder space row col - AliasBody tipe row col -> - Encode.object - [ ( "type", Encode.string "AliasBody" ) - , ( "tipe", typeEncoder tipe ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + AliasName row col -> + aliasNameEncoder row col - AliasIndentEquals row col -> - Encode.object - [ ( "type", Encode.string "AliasIndentEquals" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + AliasEquals row col -> + aliasEqualsEncoder row col - AliasIndentBody row col -> - Encode.object - [ ( "type", Encode.string "AliasIndentBody" ) - , ( "row", Encode.int row ) - , ( "col", Encode.int col ) - ] + AliasBody tipe row col -> + aliasBodyEncoder tipe row col + AliasIndentEquals row col -> + aliasIndentEqualsEncoder row col -typeAliasDecoder : Decode.Decoder TypeAlias -typeAliasDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "AliasSpace" -> - Decode.map3 AliasSpace - (Decode.field "space" spaceDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "AliasName" -> - Decode.map2 AliasName - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "AliasEquals" -> - Decode.map2 AliasEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "AliasBody" -> - Decode.map3 AliasBody - (Decode.field "tipe" typeDecoder) - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "AliasIndentEquals" -> - Decode.map2 AliasIndentEquals - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - "AliasIndentBody" -> - Decode.map2 AliasIndentBody - (Decode.field "row" Decode.int) - (Decode.field "col" Decode.int) - - _ -> - Decode.fail ("Failed to decode TypeAlias's type: " ++ type_) - ) + AliasIndentBody row col -> + aliasIndentBodyEncoder row col + ) + |> Serialize.variant3 AliasSpace spaceCodec Serialize.int Serialize.int + |> Serialize.variant2 AliasName Serialize.int Serialize.int + |> Serialize.variant2 AliasEquals Serialize.int Serialize.int + |> Serialize.variant3 AliasBody typeCodec Serialize.int Serialize.int + |> Serialize.variant2 AliasIndentEquals Serialize.int Serialize.int + |> Serialize.variant2 AliasIndentBody Serialize.int Serialize.int + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Error/Type.elm b/src/Compiler/Reporting/Error/Type.elm index 232fd820b..4dc166290 100644 --- a/src/Compiler/Reporting/Error/Type.elm +++ b/src/Compiler/Reporting/Error/Type.elm @@ -9,8 +9,6 @@ module Compiler.Reporting.Error.Type exposing , PExpected(..) , SubContext(..) , errorCodec - , errorDecoder - , errorEncoder , ptypeReplace , toReport , typeReplace @@ -19,8 +17,6 @@ module Compiler.Reporting.Error.Type exposing import Compiler.AST.Canonical as Can import Compiler.Data.Index as Index import Compiler.Data.Name exposing (Name) -import Compiler.Json.Decode as DecodeX -import Compiler.Json.Encode as EncodeX import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D import Compiler.Reporting.Render.Code as Code @@ -28,10 +24,9 @@ import Compiler.Reporting.Render.Type as RT import Compiler.Reporting.Render.Type.Localizer as L import Compiler.Reporting.Report as Report import Compiler.Reporting.Suggest as Suggest +import Compiler.Serialize as S import Compiler.Type.Error as T import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -2526,716 +2521,318 @@ toInfiniteReport source localizer region name overallType = -- ENCODERS and DECODERS -errorEncoder : Error -> Encode.Value -errorEncoder error = - case error of - BadExpr region category actualType expected -> - Encode.object - [ ( "type", Encode.string "BadExpr" ) - , ( "region", A.regionEncoder region ) - , ( "category", categoryEncoder category ) - , ( "actualType", T.typeEncoder actualType ) - , ( "expected", expectedEncoder T.typeEncoder expected ) - ] - - BadPattern region category tipe expected -> - Encode.object - [ ( "type", Encode.string "BadPattern" ) - , ( "region", A.regionEncoder region ) - , ( "category", pCategoryEncoder category ) - , ( "tipe", T.typeEncoder tipe ) - , ( "expected", pExpectedEncoder T.typeEncoder expected ) - ] - - InfiniteType region name overallType -> - Encode.object - [ ( "type", Encode.string "InfiniteType" ) - , ( "region", A.regionEncoder region ) - , ( "name", Encode.string name ) - , ( "overallType", T.typeEncoder overallType ) - ] - - -errorDecoder : Decode.Decoder Error -errorDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "BadExpr" -> - Decode.map4 BadExpr - (Decode.field "region" A.regionDecoder) - (Decode.field "category" categoryDecoder) - (Decode.field "actualType" T.typeDecoder) - (Decode.field "expected" (expectedDecoder T.typeDecoder)) - - "BadPattern" -> - Decode.map4 BadPattern - (Decode.field "region" A.regionDecoder) - (Decode.field "category" pCategoryDecoder) - (Decode.field "tipe" T.typeDecoder) - (Decode.field "expected" (pExpectedDecoder T.typeDecoder)) - - "InfiniteType" -> - Decode.map3 InfiniteType - (Decode.field "region" A.regionDecoder) - (Decode.field "name" Decode.string) - (Decode.field "overallType" T.typeDecoder) - - _ -> - Decode.fail ("Failed to decode Error's type: " ++ type_) - ) - - errorCodec : Codec e Error errorCodec = - Debug.todo "errorCodec" - - -categoryEncoder : Category -> Encode.Value -categoryEncoder category = - case category of - List -> - Encode.object - [ ( "type", Encode.string "List" ) - ] - - Number -> - Encode.object - [ ( "type", Encode.string "Number" ) - ] - - Float -> - Encode.object - [ ( "type", Encode.string "Float" ) - ] - - String -> - Encode.object - [ ( "type", Encode.string "String" ) - ] - - Char -> - Encode.object - [ ( "type", Encode.string "Char" ) - ] - - If -> - Encode.object - [ ( "type", Encode.string "If" ) - ] - - Case -> - Encode.object - [ ( "type", Encode.string "Case" ) - ] - - CallResult maybeName -> - Encode.object - [ ( "type", Encode.string "CallResult" ) - , ( "maybeName", maybeNameEncoder maybeName ) - ] - - Lambda -> - Encode.object - [ ( "type", Encode.string "Lambda" ) - ] - - Accessor field -> - Encode.object - [ ( "type", Encode.string "Accessor" ) - , ( "field", Encode.string field ) - ] - - Access field -> - Encode.object - [ ( "type", Encode.string "Access" ) - , ( "field", Encode.string field ) - ] - - Record -> - Encode.object - [ ( "type", Encode.string "Record" ) - ] - - Tuple -> - Encode.object - [ ( "type", Encode.string "Tuple" ) - ] - - Unit -> - Encode.object - [ ( "type", Encode.string "Unit" ) - ] - - Shader -> - Encode.object - [ ( "type", Encode.string "Shader" ) - ] - - Effects -> - Encode.object - [ ( "type", Encode.string "Effects" ) - ] - - Local name -> - Encode.object - [ ( "type", Encode.string "Local" ) - , ( "name", Encode.string name ) - ] - - Foreign name -> - Encode.object - [ ( "type", Encode.string "Foreign" ) - , ( "name", Encode.string name ) - ] - - -categoryDecoder : Decode.Decoder Category -categoryDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "List" -> - Decode.succeed List - - "Number" -> - Decode.succeed Number - - "Float" -> - Decode.succeed Float - - "String" -> - Decode.succeed String - - "Char" -> - Decode.succeed Char - - "If" -> - Decode.succeed If - - "Case" -> - Decode.succeed Case - - "CallResult" -> - Decode.map CallResult (Decode.field "maybeName" maybeNameDecoder) - - "Lambda" -> - Decode.succeed Lambda - - "Accessor" -> - Decode.map Accessor (Decode.field "field" Decode.string) - - "Access" -> - Decode.map Access (Decode.field "field" Decode.string) - - "Record" -> - Decode.succeed Record - - "Tuple" -> - Decode.succeed Tuple - - "Unit" -> - Decode.succeed Unit - - "Shader" -> - Decode.succeed Shader - - "Effects" -> - Decode.succeed Effects - - "Local" -> - Decode.map Local (Decode.field "name" Decode.string) - - "Foreign" -> - Decode.map Foreign (Decode.field "name" Decode.string) - - _ -> - Decode.fail ("Failed to decode Category's type: " ++ type_) - ) - - -expectedEncoder : (a -> Encode.Value) -> Expected a -> Encode.Value -expectedEncoder encoder expected = - case expected of - NoExpectation expectedType -> - Encode.object - [ ( "type", Encode.string "NoExpectation" ) - , ( "expectedType", encoder expectedType ) - ] - - FromContext region context expectedType -> - Encode.object - [ ( "type", Encode.string "FromContext" ) - , ( "region", A.regionEncoder region ) - , ( "context", contextEncoder context ) - , ( "expectedType", encoder expectedType ) - ] - - FromAnnotation name arity subContext expectedType -> - Encode.object - [ ( "type", Encode.string "FromAnnotation" ) - , ( "name", Encode.string name ) - , ( "arity", Encode.int arity ) - , ( "subContext", subContextEncoder subContext ) - , ( "expectedType", encoder expectedType ) - ] - - -expectedDecoder : Decode.Decoder a -> Decode.Decoder (Expected a) -expectedDecoder decoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "NoExpectation" -> - Decode.map NoExpectation - (Decode.field "expectedType" decoder) - - "FromContext" -> - Decode.map3 FromContext - (Decode.field "region" A.regionDecoder) - (Decode.field "context" contextDecoder) - (Decode.field "expectedType" decoder) - - "FromAnnotation" -> - Decode.map4 FromAnnotation - (Decode.field "name" Decode.string) - (Decode.field "arity" Decode.int) - (Decode.field "subContext" subContextDecoder) - (Decode.field "expectedType" decoder) - - _ -> - Decode.fail ("Unknown Expected's type: " ++ type_) - ) - - -contextDecoder : Decode.Decoder Context -contextDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "ListEntry" -> - Decode.map ListEntry (Decode.field "index" Index.zeroBasedDecoder) - - "Negate" -> - Decode.succeed Negate - - "OpLeft" -> - Decode.map OpLeft (Decode.field "op" Decode.string) + Serialize.customType + (\badExprEncoder badPatternEncoder infiniteTypeEncoder value -> + case value of + BadExpr region category actualType expected -> + badExprEncoder region category actualType expected - "OpRight" -> - Decode.map OpRight (Decode.field "op" Decode.string) + BadPattern region category tipe expected -> + badPatternEncoder region category tipe expected - "IfCondition" -> - Decode.succeed IfCondition - - "IfBranch" -> - Decode.map IfBranch (Decode.field "index" Index.zeroBasedDecoder) - - "CaseBranch" -> - Decode.map CaseBranch (Decode.field "index" Index.zeroBasedDecoder) - - "CallArity" -> - Decode.map2 CallArity - (Decode.field "maybeFuncName" maybeNameDecoder) - (Decode.field "numGivenArgs" Decode.int) - - "CallArg" -> - Decode.map2 CallArg - (Decode.field "maybeFuncName" maybeNameDecoder) - (Decode.field "index" Index.zeroBasedDecoder) - - "RecordAccess" -> - Decode.map4 RecordAccess - (Decode.field "recordRegion" A.regionDecoder) - (Decode.field "maybeName" (Decode.nullable Decode.string)) - (Decode.field "fieldRegion" A.regionDecoder) - (Decode.field "field" Decode.string) - - "RecordUpdateKeys" -> - Decode.map2 RecordUpdateKeys - (Decode.field "record" Decode.string) - (Decode.field "expectedFields" (DecodeX.assocListDict compare Decode.string Can.fieldUpdateDecoder)) - - "RecordUpdateValue" -> - Decode.map RecordUpdateValue (Decode.field "field" Decode.string) - - "Destructure" -> - Decode.succeed Destructure - - _ -> - Decode.fail ("Unknown Context's type: " ++ type_) - ) - - -contextEncoder : Context -> Encode.Value -contextEncoder context = - case context of - ListEntry index -> - Encode.object - [ ( "type", Encode.string "ListEntry" ) - , ( "index", Index.zeroBasedEncoder index ) - ] - - Negate -> - Encode.object - [ ( "type", Encode.string "Negate" ) - ] - - OpLeft op -> - Encode.object - [ ( "type", Encode.string "OpLeft" ) - , ( "op", Encode.string op ) - ] - - OpRight op -> - Encode.object - [ ( "type", Encode.string "OpRight" ) - , ( "op", Encode.string op ) - ] - - IfCondition -> - Encode.object - [ ( "type", Encode.string "IfCondition" ) - ] - - IfBranch index -> - Encode.object - [ ( "type", Encode.string "IfBranch" ) - , ( "index", Index.zeroBasedEncoder index ) - ] - - CaseBranch index -> - Encode.object - [ ( "type", Encode.string "CaseBranch" ) - , ( "index", Index.zeroBasedEncoder index ) - ] - - CallArity maybeFuncName numGivenArgs -> - Encode.object - [ ( "type", Encode.string "CallArity" ) - , ( "maybeFuncName", maybeNameEncoder maybeFuncName ) - , ( "numGivenArgs", Encode.int numGivenArgs ) - ] - - CallArg maybeFuncName index -> - Encode.object - [ ( "type", Encode.string "CallArg" ) - , ( "maybeFuncName", maybeNameEncoder maybeFuncName ) - , ( "index", Index.zeroBasedEncoder index ) - ] - - RecordAccess recordRegion maybeName fieldRegion field -> - Encode.object - [ ( "type", Encode.string "RecordAccess" ) - , ( "recordRegion", A.regionEncoder recordRegion ) - , ( "maybeName", EncodeX.maybe Encode.string maybeName ) - , ( "fieldRegion", A.regionEncoder fieldRegion ) - , ( "field", Encode.string field ) - ] - - RecordUpdateKeys record expectedFields -> - Encode.object - [ ( "type", Encode.string "RecordUpdateKeys" ) - , ( "record", Encode.string record ) - , ( "expectedFields", EncodeX.assocListDict Encode.string Can.fieldUpdateEncoder expectedFields ) - ] - - RecordUpdateValue field -> - Encode.object - [ ( "type", Encode.string "RecordUpdateValue" ) - , ( "field", Encode.string field ) - ] - - Destructure -> - Encode.object - [ ( "type", Encode.string "Destructure" ) - ] - - -subContextDecoder : Decode.Decoder SubContext -subContextDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "TypedIfBranch" -> - Decode.map TypedIfBranch - (Decode.field "index" Index.zeroBasedDecoder) - - "TypedCaseBranch" -> - Decode.map TypedCaseBranch - (Decode.field "index" Index.zeroBasedDecoder) - - "TypedBody" -> - Decode.succeed TypedBody - - _ -> - Decode.fail ("Unknown SubContext's type: " ++ type_) - ) - - -subContextEncoder : SubContext -> Encode.Value -subContextEncoder subContext = - case subContext of - TypedIfBranch index -> - Encode.object - [ ( "type", Encode.string "TypedIfBranch" ) - , ( "index", Index.zeroBasedEncoder index ) - ] + InfiniteType region name overallType -> + infiniteTypeEncoder region name overallType + ) + |> Serialize.variant4 BadExpr A.regionCodec categoryCodec T.typeCodec (expectedCodec T.typeCodec) + |> Serialize.variant4 BadPattern A.regionCodec pCategoryCodec T.typeCodec (pExpectedCodec T.typeCodec) + |> Serialize.variant3 InfiniteType A.regionCodec Serialize.string T.typeCodec + |> Serialize.finishCustomType - TypedCaseBranch index -> - Encode.object - [ ( "type", Encode.string "TypedCaseBranch" ) - , ( "index", Index.zeroBasedEncoder index ) - ] - TypedBody -> - Encode.object - [ ( "type", Encode.string "TypedBody" ) - ] +categoryCodec : Codec e Category +categoryCodec = + Serialize.customType + (\listEncoder numberEncoder floatEncoder stringEncoder charEncoder ifEncoder caseEncoder callResultEncoder lambdaEncoder accessorEncoder accessEncoder recordEncoder tupleEncoder unitEncoder shaderEncoder effectsEncoder localEncoder foreignEncoder value -> + case value of + List -> + listEncoder + Number -> + numberEncoder -pCategoryEncoder : PCategory -> Encode.Value -pCategoryEncoder pCategory = - case pCategory of - PRecord -> - Encode.object - [ ( "type", Encode.string "PRecord" ) - ] + Float -> + floatEncoder - PUnit -> - Encode.object - [ ( "type", Encode.string "PUnit" ) - ] + String -> + stringEncoder - PTuple -> - Encode.object - [ ( "type", Encode.string "PTuple" ) - ] + Char -> + charEncoder - PList -> - Encode.object - [ ( "type", Encode.string "PList" ) - ] + If -> + ifEncoder - PCtor name -> - Encode.object - [ ( "type", Encode.string "PCtor" ) - , ( "name", Encode.string name ) - ] + Case -> + caseEncoder - PInt -> - Encode.object - [ ( "type", Encode.string "PInt" ) - ] + CallResult maybeName -> + callResultEncoder maybeName - PStr -> - Encode.object - [ ( "type", Encode.string "PStr" ) - ] + Lambda -> + lambdaEncoder - PChr -> - Encode.object - [ ( "type", Encode.string "PChr" ) - ] + Accessor field -> + accessorEncoder field - PBool -> - Encode.object - [ ( "type", Encode.string "PBool" ) - ] + Access field -> + accessEncoder field + Record -> + recordEncoder -pCategoryDecoder : Decode.Decoder PCategory -pCategoryDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PRecord" -> - Decode.succeed PRecord + Tuple -> + tupleEncoder - "PUnit" -> - Decode.succeed PUnit + Unit -> + unitEncoder - "PTuple" -> - Decode.succeed PTuple + Shader -> + shaderEncoder - "PList" -> - Decode.succeed PList + Effects -> + effectsEncoder - "PCtor" -> - Decode.map PCtor (Decode.field "name" Decode.string) + Local name -> + localEncoder name - "PInt" -> - Decode.succeed PInt + Foreign name -> + foreignEncoder name + ) + |> Serialize.variant0 List + |> Serialize.variant0 Number + |> Serialize.variant0 Float + |> Serialize.variant0 String + |> Serialize.variant0 Char + |> Serialize.variant0 If + |> Serialize.variant0 Case + |> Serialize.variant1 CallResult maybeNameCodec + |> Serialize.variant0 Lambda + |> Serialize.variant1 Accessor Serialize.string + |> Serialize.variant1 Access Serialize.string + |> Serialize.variant0 Record + |> Serialize.variant0 Tuple + |> Serialize.variant0 Unit + |> Serialize.variant0 Shader + |> Serialize.variant0 Effects + |> Serialize.variant1 Local Serialize.string + |> Serialize.variant1 Foreign Serialize.string + |> Serialize.finishCustomType + + +expectedCodec : Codec e tipe -> Codec e (Expected tipe) +expectedCodec tipe = + Serialize.customType + (\noExpectationEncoder fromContextEncoder fromAnnotationEncoder value -> + case value of + NoExpectation expectedType -> + noExpectationEncoder expectedType + + FromContext region context expectedType -> + fromContextEncoder region context expectedType + + FromAnnotation name arity subContext expectedType -> + fromAnnotationEncoder name arity subContext expectedType + ) + |> Serialize.variant1 NoExpectation tipe + |> Serialize.variant3 FromContext A.regionCodec contextCodec tipe + |> Serialize.variant4 FromAnnotation Serialize.string Serialize.int subContextCodec tipe + |> Serialize.finishCustomType - "PStr" -> - Decode.succeed PStr - "PChr" -> - Decode.succeed PChr +contextCodec : Codec e Context +contextCodec = + Serialize.customType + (\listEntryEncoder negateEncoder opLeftEncoder opRightEncoder ifConditionEncoder ifBranchEncoder caseBranchEncoder callArityEncoder callArgEncoder recordAccessEncoder recordUpdateKeysEncoder recordUpdateValueEncoder destructureEncoder value -> + case value of + ListEntry index -> + listEntryEncoder index - "PBool" -> - Decode.succeed PBool + Negate -> + negateEncoder - _ -> - Decode.fail ("Unknown PCategory's type: " ++ type_) - ) + OpLeft op -> + opLeftEncoder op + OpRight op -> + opRightEncoder op -pExpectedEncoder : (a -> Encode.Value) -> PExpected a -> Encode.Value -pExpectedEncoder encoder pExpected = - case pExpected of - PNoExpectation expectedType -> - Encode.object - [ ( "type", Encode.string "PNoExpectation" ) - , ( "expectedType", encoder expectedType ) - ] + IfCondition -> + ifConditionEncoder - PFromContext region context expectedType -> - Encode.object - [ ( "type", Encode.string "PFromContext" ) - , ( "region", A.regionEncoder region ) - , ( "context", pContextEncoder context ) - , ( "expectedType", encoder expectedType ) - ] + IfBranch index -> + ifBranchEncoder index + CaseBranch index -> + caseBranchEncoder index -pExpectedDecoder : Decode.Decoder a -> Decode.Decoder (PExpected a) -pExpectedDecoder decoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PNoExpectation" -> - Decode.map PNoExpectation (Decode.field "expectedType" decoder) + CallArity maybeFuncName numGivenArgs -> + callArityEncoder maybeFuncName numGivenArgs - -- | PFromContext A.Region PContext tipe - "PFromContext" -> - Decode.map3 PFromContext - (Decode.field "region" A.regionDecoder) - (Decode.field "context" pContextDecoder) - (Decode.field "expectedType" decoder) + CallArg maybeFuncName index -> + callArgEncoder maybeFuncName index - _ -> - Decode.fail ("Failed to decode PExpected's type: " ++ type_) - ) + RecordAccess recordRegion maybeName fieldRegion field -> + recordAccessEncoder recordRegion maybeName fieldRegion field + RecordUpdateKeys record expectedFields -> + recordUpdateKeysEncoder record expectedFields -maybeNameEncoder : MaybeName -> Encode.Value -maybeNameEncoder maybeName = - case maybeName of - FuncName name -> - Encode.object - [ ( "type", Encode.string "FuncName" ) - , ( "name", Encode.string name ) - ] + RecordUpdateValue field -> + recordUpdateValueEncoder field - CtorName name -> - Encode.object - [ ( "type", Encode.string "CtorName" ) - , ( "name", Encode.string name ) - ] + Destructure -> + destructureEncoder + ) + |> Serialize.variant1 ListEntry Index.zeroBasedCodec + |> Serialize.variant0 Negate + |> Serialize.variant1 OpLeft Serialize.string + |> Serialize.variant1 OpRight Serialize.string + |> Serialize.variant0 IfCondition + |> Serialize.variant1 IfBranch Index.zeroBasedCodec + |> Serialize.variant1 CaseBranch Index.zeroBasedCodec + |> Serialize.variant2 CallArity maybeNameCodec Serialize.int + |> Serialize.variant2 CallArg maybeNameCodec Index.zeroBasedCodec + |> Serialize.variant4 + RecordAccess + A.regionCodec + (Serialize.maybe Serialize.string) + A.regionCodec + Serialize.string + |> Serialize.variant2 RecordUpdateKeys Serialize.string (S.assocListDict compare Serialize.string Can.fieldUpdateCodec) + |> Serialize.variant1 RecordUpdateValue Serialize.string + |> Serialize.variant0 Destructure + |> Serialize.finishCustomType + + +subContextCodec : Codec e SubContext +subContextCodec = + Serialize.customType + (\typedIfBranchEncoder typedCaseBranchEncoder typedBodyEncoder value -> + case value of + TypedIfBranch index -> + typedIfBranchEncoder index + + TypedCaseBranch index -> + typedCaseBranchEncoder index + + TypedBody -> + typedBodyEncoder + ) + |> Serialize.variant1 TypedIfBranch Index.zeroBasedCodec + |> Serialize.variant1 TypedCaseBranch Index.zeroBasedCodec + |> Serialize.variant0 TypedBody + |> Serialize.finishCustomType - OpName op -> - Encode.object - [ ( "type", Encode.string "OpName" ) - , ( "op", Encode.string op ) - ] - NoName -> - Encode.object - [ ( "type", Encode.string "NoName" ) - ] +pCategoryCodec : Codec e PCategory +pCategoryCodec = + Serialize.customType + (\pRecordEncoder pUnitEncoder pTupleEncoder pListEncoder pCtorEncoder pIntEncoder pStrEncoder pChrEncoder pBoolEncoder value -> + case value of + PRecord -> + pRecordEncoder + PUnit -> + pUnitEncoder -maybeNameDecoder : Decode.Decoder MaybeName -maybeNameDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "FuncName" -> - Decode.map FuncName (Decode.field "name" Decode.string) + PTuple -> + pTupleEncoder - "CtorName" -> - Decode.map CtorName (Decode.field "name" Decode.string) + PList -> + pListEncoder - "OpName" -> - Decode.map OpName (Decode.field "op" Decode.string) + PCtor name -> + pCtorEncoder name - "NoName" -> - Decode.succeed NoName + PInt -> + pIntEncoder - _ -> - Decode.fail ("Failed to decode MaybeName's type: " ++ type_) - ) + PStr -> + pStrEncoder + PChr -> + pChrEncoder -pContextEncoder : PContext -> Encode.Value -pContextEncoder pContext = - case pContext of - PTypedArg name index -> - Encode.object - [ ( "type", Encode.string "PTypedArg" ) - , ( "name", Encode.string name ) - , ( "index", Index.zeroBasedEncoder index ) - ] + PBool -> + pBoolEncoder + ) + |> Serialize.variant0 PRecord + |> Serialize.variant0 PUnit + |> Serialize.variant0 PTuple + |> Serialize.variant0 PList + |> Serialize.variant1 PCtor Serialize.string + |> Serialize.variant0 PInt + |> Serialize.variant0 PStr + |> Serialize.variant0 PChr + |> Serialize.variant0 PBool + |> Serialize.finishCustomType + + +pExpectedCodec : Codec e tipe -> Codec e (PExpected tipe) +pExpectedCodec tipe = + Serialize.customType + (\pNoExpectationEncoder pFromContextEncoder value -> + case value of + PNoExpectation expectedType -> + pNoExpectationEncoder expectedType + + PFromContext region context expectedType -> + pFromContextEncoder region context expectedType + ) + |> Serialize.variant1 PNoExpectation tipe + |> Serialize.variant3 PFromContext A.regionCodec pContextCodec tipe + |> Serialize.finishCustomType - PCaseMatch index -> - Encode.object - [ ( "type", Encode.string "PCaseMatch" ) - , ( "index", Index.zeroBasedEncoder index ) - ] - PCtorArg name index -> - Encode.object - [ ( "type", Encode.string "PCtorArg" ) - , ( "name", Encode.string name ) - , ( "index", Index.zeroBasedEncoder index ) - ] +maybeNameCodec : Codec e MaybeName +maybeNameCodec = + Serialize.customType + (\funcNameEncoder ctorNameEncoder opNameEncoder noNameEncoder value -> + case value of + FuncName name -> + funcNameEncoder name - PListEntry index -> - Encode.object - [ ( "type", Encode.string "PListEntry" ) - , ( "index", Index.zeroBasedEncoder index ) - ] + CtorName name -> + ctorNameEncoder name - PTail -> - Encode.object - [ ( "type", Encode.string "PTail" ) - ] + OpName op -> + opNameEncoder op + NoName -> + noNameEncoder + ) + |> Serialize.variant1 FuncName Serialize.string + |> Serialize.variant1 CtorName Serialize.string + |> Serialize.variant1 OpName Serialize.string + |> Serialize.variant0 NoName + |> Serialize.finishCustomType -pContextDecoder : Decode.Decoder PContext -pContextDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "PTypedArg" -> - Decode.map2 PTypedArg - (Decode.field "name" Decode.string) - (Decode.field "index" Index.zeroBasedDecoder) - "PCaseMatch" -> - Decode.map PCaseMatch (Decode.field "index" Index.zeroBasedDecoder) +pContextCodec : Codec e PContext +pContextCodec = + Serialize.customType + (\pTypedArgEncoder pCaseMatchEncoder pCtorArgEncoder pListEntryEncoder pTailEncoder value -> + case value of + PTypedArg name index -> + pTypedArgEncoder name index - "PCtorArg" -> - Decode.map2 PCtorArg - (Decode.field "name" Decode.string) - (Decode.field "index" Index.zeroBasedDecoder) + PCaseMatch index -> + pCaseMatchEncoder index - "PListEntry" -> - Decode.map PListEntry (Decode.field "index" Index.zeroBasedDecoder) + PCtorArg name index -> + pCtorArgEncoder name index - "PTail" -> - Decode.succeed PTail + PListEntry index -> + pListEntryEncoder index - _ -> - Decode.fail ("Failed to decode PContext's type: " ++ type_) - ) + PTail -> + pTailEncoder + ) + |> Serialize.variant2 PTypedArg Serialize.string Index.zeroBasedCodec + |> Serialize.variant1 PCaseMatch Index.zeroBasedCodec + |> Serialize.variant2 PCtorArg Serialize.string Index.zeroBasedCodec + |> Serialize.variant1 PListEntry Index.zeroBasedCodec + |> Serialize.variant0 PTail + |> Serialize.finishCustomType diff --git a/src/Compiler/Reporting/Render/Type/Localizer.elm b/src/Compiler/Reporting/Render/Type/Localizer.elm index e66f991cf..2604a03d7 100644 --- a/src/Compiler/Reporting/Render/Type/Localizer.elm +++ b/src/Compiler/Reporting/Render/Type/Localizer.elm @@ -4,8 +4,6 @@ module Compiler.Reporting.Render.Type.Localizer exposing , fromModule , fromNames , localizerCodec - , localizerDecoder - , localizerEncoder , toChars , toDoc ) @@ -13,14 +11,11 @@ module Compiler.Reporting.Render.Type.Localizer exposing import Compiler.AST.Source as Src import Compiler.Data.Name as Name exposing (Name) import Compiler.Elm.ModuleName as ModuleName -import Compiler.Json.Decode as DecodeX -import Compiler.Json.Encode as EncodeX import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.TypeCheck.IO as IO @@ -134,64 +129,35 @@ addType exposed types = -- ENCODERS and DECODERS -localizerEncoder : Localizer -> Encode.Value -localizerEncoder (Localizer localizer) = - EncodeX.assocListDict Encode.string importEncoder localizer - - -localizerDecoder : Decode.Decoder Localizer -localizerDecoder = - Decode.map Localizer (DecodeX.assocListDict compare Decode.string importDecoder) - - localizerCodec : Codec e Localizer localizerCodec = - Debug.todo "localizerCodec" - - -importEncoder : Import -> Encode.Value -importEncoder import_ = - Encode.object - [ ( "type", Encode.string "Import" ) - , ( "alias", EncodeX.maybe Encode.string import_.alias ) - , ( "exposing", exposingEncoder import_.exposing_ ) - ] - - -importDecoder : Decode.Decoder Import -importDecoder = - Decode.map2 Import - (Decode.field "alias" (Decode.maybe Decode.string)) - (Decode.field "exposing" exposingDecoder) - + Serialize.customType + (\localizerCodecEncoder (Localizer localizer) -> + localizerCodecEncoder localizer + ) + |> Serialize.variant1 Localizer (S.assocListDict compare Serialize.string importCodec) + |> Serialize.finishCustomType + + +importCodec : Codec e Import +importCodec = + Serialize.record Import + |> Serialize.field .alias (Serialize.maybe Serialize.string) + |> Serialize.field .exposing_ exposingCodec + |> Serialize.finishRecord + + +exposingCodec : Codec e Exposing +exposingCodec = + Serialize.customType + (\allEncoder onlyEncoder value -> + case value of + All -> + allEncoder -exposingEncoder : Exposing -> Encode.Value -exposingEncoder exposing_ = - case exposing_ of - All -> - Encode.object - [ ( "type", Encode.string "All" ) - ] - - Only set -> - Encode.object - [ ( "type", Encode.string "Only" ) - , ( "set", EncodeX.everySet Encode.string set ) - ] - - -exposingDecoder : Decode.Decoder Exposing -exposingDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "All" -> - Decode.succeed All - - "Only" -> - Decode.map Only (Decode.field "set" (DecodeX.everySet compare Decode.string)) - - _ -> - Decode.fail ("Unknown Exposing's type: " ++ type_) - ) + Only set -> + onlyEncoder set + ) + |> Serialize.variant0 All + |> Serialize.variant1 Only (S.everySet compare Serialize.string) + |> Serialize.finishCustomType diff --git a/src/Compiler/Serialize.elm b/src/Compiler/Serialize.elm index a385baca9..0d4ee6878 100644 --- a/src/Compiler/Serialize.elm +++ b/src/Compiler/Serialize.elm @@ -6,7 +6,7 @@ module Compiler.Serialize exposing ) import Compiler.Data.NonEmptyList as NE -import Compiler.Data.OneOrMore exposing (OneOrMore) +import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) import Serialize as S exposing (Codec) @@ -41,5 +41,16 @@ nonempty codec = oneOrMore : Codec e a -> Codec e (OneOrMore a) -oneOrMore _ = - Debug.todo "oneOrMore" +oneOrMore codec = + S.customType + (\oneEncoder moreEncoder value -> + case value of + OneOrMore.One x -> + oneEncoder x + + OneOrMore.More a b -> + moreEncoder a b + ) + |> S.variant1 OneOrMore.One codec + |> S.variant2 OneOrMore.More (S.lazy (\() -> oneOrMore codec)) (S.lazy (\() -> oneOrMore codec)) + |> S.finishCustomType diff --git a/src/Compiler/Type/Error.elm b/src/Compiler/Type/Error.elm index 71a4abdd2..566a6df22 100644 --- a/src/Compiler/Type/Error.elm +++ b/src/Compiler/Type/Error.elm @@ -12,23 +12,20 @@ module Compiler.Type.Error exposing , iteratedDealias , toComparison , toDoc - , typeDecoder - , typeEncoder + , typeCodec ) import Compiler.Data.Bag as Bag import Compiler.Data.Name as Name exposing (Name) import Compiler.Elm.ModuleName as ModuleName -import Compiler.Json.Decode as DecodeX -import Compiler.Json.Encode as EncodeX import Compiler.Reporting.Doc as D import Compiler.Reporting.Render.Type as RT import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Serialize as S import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Maybe.Extra as Maybe import Prelude +import Serialize exposing (Codec) import System.TypeCheck.IO as IO @@ -833,232 +830,118 @@ extToStatus ext1 ext2 = -- ENCODERS and DECODERS -typeEncoder : Type -> Encode.Value -typeEncoder type_ = - case type_ of - Lambda x y zs -> - Encode.object - [ ( "type", Encode.string "Lambda" ) - , ( "x", typeEncoder x ) - , ( "y", typeEncoder y ) - , ( "zs", Encode.list typeEncoder zs ) - ] - - Infinite -> - Encode.object - [ ( "type", Encode.string "Infinite" ) - ] - - Error -> - Encode.object - [ ( "type", Encode.string "Error" ) - ] - - FlexVar name -> - Encode.object - [ ( "type", Encode.string "FlexVar" ) - , ( "name", Encode.string name ) - ] - - FlexSuper s x -> - Encode.object - [ ( "type", Encode.string "FlexSuper" ) - , ( "s", superEncoder s ) - , ( "x", Encode.string x ) - ] - - RigidVar name -> - Encode.object - [ ( "type", Encode.string "RigidVar" ) - , ( "name", Encode.string name ) - ] - - RigidSuper s x -> - Encode.object - [ ( "type", Encode.string "RigidSuper" ) - , ( "s", superEncoder s ) - , ( "x", Encode.string x ) - ] - - Type home name args -> - Encode.object - [ ( "type", Encode.string "Type" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "args", Encode.list typeEncoder args ) - ] - - Record msgType decoder -> - Encode.object - [ ( "type", Encode.string "Record" ) - , ( "msgType", EncodeX.assocListDict Encode.string typeEncoder msgType ) - , ( "decoder", extensionEncoder decoder ) - ] - - Unit -> - Encode.object - [ ( "type", Encode.string "Unit" ) - ] +typeCodec : Codec e Type +typeCodec = + Serialize.customType + (\lambdaEncoder infiniteEncoder errorCodecEncoder flexVarEncoder flexSuperEncoder rigidVarEncoder rigidSuperEncoder typeCodecEncoder recordEncoder unitEncoder tupleEncoder aliasEncoder value -> + case value of + Lambda x y zs -> + lambdaEncoder x y zs + + Infinite -> + infiniteEncoder + + Error -> + errorCodecEncoder + + FlexVar name -> + flexVarEncoder name + + FlexSuper s x -> + flexSuperEncoder s x + + RigidVar name -> + rigidVarEncoder name + + RigidSuper s x -> + rigidSuperEncoder s x + + Type home name args -> + typeCodecEncoder home name args + + Record msgType decoder -> + recordEncoder msgType decoder + + Unit -> + unitEncoder + + Tuple a b maybeC -> + tupleEncoder a b maybeC + + Alias home name args tipe -> + aliasEncoder home name args tipe + ) + |> Serialize.variant3 + Lambda + (Serialize.lazy (\() -> typeCodec)) + (Serialize.lazy (\() -> typeCodec)) + (Serialize.list (Serialize.lazy (\() -> typeCodec))) + |> Serialize.variant0 Infinite + |> Serialize.variant0 Error + |> Serialize.variant1 FlexVar Serialize.string + |> Serialize.variant2 FlexSuper superCodec Serialize.string + |> Serialize.variant1 RigidVar Serialize.string + |> Serialize.variant2 RigidSuper superCodec Serialize.string + |> Serialize.variant3 + Type + ModuleName.canonicalCodec + Serialize.string + (Serialize.list (Serialize.lazy (\() -> typeCodec))) + |> Serialize.variant2 Record (S.assocListDict compare Serialize.string (Serialize.lazy (\() -> typeCodec))) extensionCodec + |> Serialize.variant0 Unit + |> Serialize.variant3 + Tuple + (Serialize.lazy (\() -> typeCodec)) + (Serialize.lazy (\() -> typeCodec)) + (Serialize.maybe (Serialize.lazy (\() -> typeCodec))) + |> Serialize.variant4 + Alias + ModuleName.canonicalCodec + Serialize.string + (Serialize.list (Serialize.tuple Serialize.string (Serialize.lazy (\() -> typeCodec)))) + (Serialize.lazy (\() -> typeCodec)) + |> Serialize.finishCustomType + + +superCodec : Codec e Super +superCodec = + Serialize.customType + (\numberEncoder comparableEncoder appendableEncoder compAppendEncoder value -> + case value of + Number -> + numberEncoder - Tuple a b maybeC -> - Encode.object - [ ( "type", Encode.string "Tuple" ) - , ( "a", typeEncoder a ) - , ( "b", typeEncoder b ) - , ( "maybeC", EncodeX.maybe typeEncoder maybeC ) - ] - - Alias home name args tipe -> - Encode.object - [ ( "type", Encode.string "Alias" ) - , ( "home", ModuleName.canonicalEncoder home ) - , ( "name", Encode.string name ) - , ( "args", Encode.list (EncodeX.jsonPair Encode.string typeEncoder) args ) - , ( "tipe", typeEncoder tipe ) - ] - - -typeDecoder : Decode.Decoder Type -typeDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Lambda" -> - Decode.map3 Lambda - (Decode.field "x" typeDecoder) - (Decode.field "y" typeDecoder) - (Decode.field "zs" (Decode.list typeDecoder)) - - "Infinite" -> - Decode.succeed Infinite - - "Error" -> - Decode.succeed Error - - "FlexVar" -> - Decode.map FlexVar (Decode.field "name" Decode.string) - - "FlexSuper" -> - Decode.map2 FlexSuper - (Decode.field "s" superDecoder) - (Decode.field "x" Decode.string) - - "RigidVar" -> - Decode.map RigidVar (Decode.field "name" Decode.string) - - "RigidSuper" -> - Decode.map2 RigidSuper - (Decode.field "s" superDecoder) - (Decode.field "x" Decode.string) - - "Type" -> - Decode.map3 Type - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list typeDecoder)) - - "Record" -> - Decode.map2 Record - (Decode.field "msgType" (DecodeX.assocListDict compare Decode.string typeDecoder)) - (Decode.field "decoder" extensionDecoder) - - "Unit" -> - Decode.succeed Unit - - "Tuple" -> - Decode.map3 Tuple - (Decode.field "a" typeDecoder) - (Decode.field "b" typeDecoder) - (Decode.field "maybeC" (Decode.maybe typeDecoder)) - - "Alias" -> - Decode.map4 Alias - (Decode.field "home" ModuleName.canonicalDecoder) - (Decode.field "name" Decode.string) - (Decode.field "args" (Decode.list (DecodeX.jsonPair Decode.string typeDecoder))) - (Decode.field "tipe" typeDecoder) - - _ -> - Decode.fail ("Unknown Type's type: " ++ type_) - ) - - -superEncoder : Super -> Encode.Value -superEncoder super = - case super of - Number -> - Encode.string "Number" - - Comparable -> - Encode.string "Comparable" - - Appendable -> - Encode.string "Appendable" - - CompAppend -> - Encode.string "CompAppend" - - -superDecoder : Decode.Decoder Super -superDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "Number" -> - Decode.succeed Number - - "Comparable" -> - Decode.succeed Comparable - - "Appendable" -> - Decode.succeed Appendable - - "CompAppend" -> - Decode.succeed CompAppend - - _ -> - Decode.fail ("Unknown Super: " ++ str) - ) - - -extensionEncoder : Extension -> Encode.Value -extensionEncoder extension = - case extension of - Closed -> - Encode.object - [ ( "type", Encode.string "Closed" ) - ] + Comparable -> + comparableEncoder - FlexOpen x -> - Encode.object - [ ( "type", Encode.string "FlexOpen" ) - , ( "x", Encode.string x ) - ] + Appendable -> + appendableEncoder - RigidOpen x -> - Encode.object - [ ( "type", Encode.string "RigidOpen" ) - , ( "x", Encode.string x ) - ] - - -extensionDecoder : Decode.Decoder Extension -extensionDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Closed" -> - Decode.succeed Closed - - "FlexOpen" -> - Decode.map FlexOpen (Decode.field "x" Decode.string) - - "RigidOpen" -> - Decode.map RigidOpen (Decode.field "x" Decode.string) - - _ -> - Decode.fail ("Unknown Extension's type: " ++ type_) - ) + CompAppend -> + compAppendEncoder + ) + |> Serialize.variant0 Number + |> Serialize.variant0 Comparable + |> Serialize.variant0 Appendable + |> Serialize.variant0 CompAppend + |> Serialize.finishCustomType + + +extensionCodec : Codec e Extension +extensionCodec = + Serialize.customType + (\closedEncoder flexOpenEncoder rigidOpenEncoder value -> + case value of + Closed -> + closedEncoder + + FlexOpen x -> + flexOpenEncoder x + + RigidOpen x -> + rigidOpenEncoder x + ) + |> Serialize.variant0 Closed + |> Serialize.variant1 FlexOpen Serialize.string + |> Serialize.variant1 RigidOpen Serialize.string + |> Serialize.finishCustomType diff --git a/src/Serialize.elm b/src/Serialize.elm new file mode 100644 index 000000000..4393fbda1 --- /dev/null +++ b/src/Serialize.elm @@ -0,0 +1,1947 @@ +module Serialize exposing + ( encodeToJson, decodeFromJson, encodeToBytes, decodeFromBytes, encodeToString, decodeFromString, getJsonDecoder + , Codec, Error(..) + , string, bool, float, int, unit, bytes, byte + , maybe, list, array, dict, set, tuple, triple, result, enum + , RecordCodec, record, field, finishRecord + , CustomTypeCodec, customType, variant0, variant1, variant2, variant3, variant4, variant5, variant6, variant7, variant8, finishCustomType, VariantEncoder + , map, mapValid, mapError + , lazy + , variant9 + ) + +{-| Ref.: **Initial implementation from `MartinSStewart/elm-serialize/1.3.1`** + + +# Serialization + +You have three options when encoding data. You can represent the data either as json, bytes, or a string. +Here's some advice when choosing: + + - If performance is important, use `encodeToJson` and `decodeFromJson` + - If space efficiency is important, use `encodeToBytes` and `decodeFromBytes`\* + - `encodeToString` and `decodeFromString` are good for URL safe strings but otherwise one of the other choices is probably better. + +\*`encodeToJson` is more compact when encoding integers with 6 or fewer digits. You may want to try both `encodeToBytes` and `encodeToJson` and see which is better for your use case. + +@docs encodeToJson, decodeFromJson, encodeToBytes, decodeFromBytes, encodeToString, decodeFromString, getJsonDecoder + + +# Definition + +@docs Codec, Error + + +# Primitives + +@docs string, bool, float, int, unit, bytes, byte + + +# Data Structures + +@docs maybe, list, array, dict, set, tuple, triple, result, enum + + +# Records + +@docs RecordCodec, record, field, finishRecord + + +# Custom Types + +@docs CustomTypeCodec, customType, variant0, variant1, variant2, variant3, variant4, variant5, variant6, variant7, variant8, finishCustomType, VariantEncoder + + +# Mapping + +@docs map, mapValid, mapError + + +# Stack unsafe + +@docs lazy + +-} + +import Array exposing (Array) +import Base64 +import Bytes +import Bytes.Decode as BD +import Bytes.Encode as BE +import Dict exposing (Dict) +import Json.Decode as JD +import Json.Encode as JE +import Regex exposing (Regex) +import Set exposing (Set) +import Toop exposing (T4(..), T5(..), T6(..), T7(..), T8(..), T9(..)) + + + +-- DEFINITION + + +{-| A value that knows how to encode and decode an Elm data structure. +-} +type Codec e a + = Codec + { encoder : a -> BE.Encoder + , decoder : BD.Decoder (Result (Error e) a) + , jsonEncoder : a -> JE.Value + , jsonDecoder : JD.Decoder (Result (Error e) a) + } + + +{-| Possible errors that can occur when decoding. + + - `CustomError` - An error caused by `andThen` returning an Err value. + - `DataCorrupted` - This most likely will occur if you make breaking changes to your codec and try to decode old data\*. Have a look at `How do I change my codecs and still be able to decode old data?` in the readme for how to avoid introducing breaking changes. + - `SerializerOutOfDate` - When encoding, this package will include a version number. This makes it possible for me to make improvements to how data gets encoded without introducing breaking changes to your codecs. This error then, says that you're trying to decode data encoded with a newer version of elm-serialize. + +\*It's possible for corrupted data to still succeed in decoding (but with nonsense Elm values). +This is because internally we're just encoding Elm values and not storing any kind of structural information. +So if you encoded an Int and then a Float, and then tried decoding it as a Float and then an Int, there's no way for the decoder to know it read the data in the wrong order. + +-} +type Error e + = CustomError e + | DataCorrupted + | SerializerOutOfDate + + +version : Int +version = + 1 + + + +-- DECODE + + +endian : Bytes.Endianness +endian = + Bytes.BE + + +{-| Extracts the `Decoder` contained inside the `Codec`. +-} +getBytesDecoderHelper : Codec e a -> BD.Decoder (Result (Error e) a) +getBytesDecoderHelper (Codec m) = + m.decoder + + +{-| Extracts the json `Decoder` contained inside the `Codec`. +-} +getJsonDecoderHelper : Codec e a -> JD.Decoder (Result (Error e) a) +getJsonDecoderHelper (Codec m) = + m.jsonDecoder + + +{-| Run a `Codec` to turn a sequence of bytes into an Elm value. +-} +decodeFromBytes : Codec e a -> Bytes.Bytes -> Result (Error e) a +decodeFromBytes codec bytes_ = + let + decoder = + BD.unsignedInt8 + |> BD.andThen + (\value -> + if value <= 0 then + Err DataCorrupted |> BD.succeed + + else if value == version then + getBytesDecoderHelper codec + + else + Err SerializerOutOfDate |> BD.succeed + ) + in + case BD.decode decoder bytes_ of + Just value -> + value + + Nothing -> + Err DataCorrupted + + + +--{-| Get the decoder from a `Codec` which you can use inside a elm/bytes decoder. Note that if you do this, you lose any error information that might have been returned. +---} +--getBytesDecoder : Codec e a -> BD.Decoder a +--getBytesDecoder codec = +-- BD.unsignedInt8 +-- |> BD.andThen +-- (\value -> +-- if value <= 0 then +-- BD.fail +-- +-- else if value == version then +-- getBytesDecoderHelper codec +-- |> BD.andThen +-- (\result_ -> +-- case result_ of +-- Ok ok -> +-- BD.succeed ok +-- +-- Err _ -> +-- BD.fail +-- ) +-- +-- else +-- BD.fail +-- ) + + +{-| Run a `Codec` to turn a String encoded with `encodeToString` into an Elm value. +-} +decodeFromString : Codec e a -> String -> Result (Error e) a +decodeFromString codec base64 = + case decode base64 of + Just bytes_ -> + decodeFromBytes codec bytes_ + + Nothing -> + Err DataCorrupted + + +{-| Run a `Codec` to turn a json value encoded with `encodeToJson` into an Elm value. +-} +decodeFromJson : Codec e a -> JE.Value -> Result (Error e) a +decodeFromJson codec json = + let + decoder = + JD.index 0 JD.int + |> JD.andThen + (\value -> + if value <= 0 then + Err DataCorrupted |> JD.succeed + + else if value == version then + JD.index 1 (getJsonDecoderHelper codec) + + else + Err SerializerOutOfDate |> JD.succeed + ) + in + case JD.decodeValue decoder json of + Ok value -> + value + + Err _ -> + Err DataCorrupted + + +{-| Get the decoder from a `Codec` which you can use inside a elm/json decoder. + + import Json.Decode + import Serialize + + type alias Point = + { x : Float, y : Float } + + pointCodec : Serialize.Codec e Point + pointCodec = + Serialize.record Point + |> Serialize.field .x Serialize.float + |> Serialize.field .y Serialize.float + |> Serialize.finishRecord + + pointDecoder : Json.Decode.Decoder Point + pointDecoder = + -- Since pointCodec doesn't have any custom error values, we can use `never` for our errorToString parameter. + Serialize.getJsonDecoder never pointCodec + +-} +getJsonDecoder : (e -> String) -> Codec e a -> JD.Decoder a +getJsonDecoder errorToString codec = + JD.value + |> JD.andThen + (\value -> + case decodeFromJson codec value of + Ok ok -> + JD.succeed ok + + Err (CustomError error) -> + errorToString error |> JD.fail + + Err DataCorrupted -> + JD.fail "Data corrupted (elm-serialize error)" + + Err SerializerOutOfDate -> + JD.fail "Serializer out of date (elm-serialize error)" + ) + + +decode : String -> Maybe Bytes.Bytes +decode base64text = + let + replaceChar rematch = + case rematch.match of + "-" -> + "+" + + _ -> + "/" + + strlen = + String.length base64text + in + if strlen == 0 then + BE.encode (BE.sequence []) |> Just + + else + let + hanging = + modBy 4 strlen + + ilen = + if hanging == 0 then + 0 + + else + 4 - hanging + in + Regex.replace replaceFromUrl replaceChar (base64text ++ String.repeat ilen "=") |> Base64.toBytes + + +replaceFromUrl : Regex +replaceFromUrl = + Regex.fromString "[-_]" |> Maybe.withDefault Regex.never + + + +-- ENCODE + + +{-| Extracts the encoding function contained inside the `Codec`. +-} +getBytesEncoderHelper : Codec e a -> a -> BE.Encoder +getBytesEncoderHelper (Codec m) = + m.encoder + + +{-| Extracts the json encoding function contained inside the `Codec`. +-} +getJsonEncoderHelper : Codec e a -> a -> JE.Value +getJsonEncoderHelper (Codec m) = + m.jsonEncoder + + +{-| Convert an Elm value into a sequence of bytes. +-} +encodeToBytes : Codec e a -> a -> Bytes.Bytes +encodeToBytes codec value = + BE.sequence + [ BE.unsignedInt8 version + , value |> getBytesEncoderHelper codec + ] + |> BE.encode + + +{-| Convert an Elm value into a string. This string contains only url safe characters, so you can do the following: + + import Serialize as S + + myUrl = + "www.mywebsite.com/?data=" ++ S.encodeToString S.float 1234 + +and not risk generating an invalid url. + +-} +encodeToString : Codec e a -> a -> String +encodeToString codec = + encodeToBytes codec >> replaceBase64Chars + + +{-| Convert an Elm value into json data. +-} +encodeToJson : Codec e a -> a -> JE.Value +encodeToJson codec value = + JE.list + identity + [ JE.int version + , value |> getJsonEncoderHelper codec + ] + + +replaceBase64Chars : Bytes.Bytes -> String +replaceBase64Chars = + let + replaceChar rematch = + case rematch.match of + "+" -> + "-" + + "/" -> + "_" + + _ -> + "" + in + Base64.fromBytes >> Maybe.withDefault "" >> Regex.replace replaceForUrl replaceChar + + +replaceForUrl : Regex +replaceForUrl = + Regex.fromString "[\\+/=]" |> Maybe.withDefault Regex.never + + + +-- BASE + + +build : + (a -> BE.Encoder) + -> BD.Decoder (Result (Error e) a) + -> (a -> JE.Value) + -> JD.Decoder (Result (Error e) a) + -> Codec e a +build encoder_ decoder_ jsonEncoder jsonDecoder = + Codec + { encoder = encoder_ + , decoder = decoder_ + , jsonEncoder = jsonEncoder + , jsonDecoder = jsonDecoder + } + + +{-| Codec for serializing a `String` +-} +string : Codec e String +string = + build + (\text -> + BE.sequence + [ BE.unsignedInt32 endian (BE.getStringWidth text) + , BE.string text + ] + ) + (BD.unsignedInt32 endian + |> BD.andThen + (\charCount -> BD.string charCount |> BD.map Ok) + ) + JE.string + (JD.string |> JD.map Ok) + + +{-| Codec for serializing a `Bool` +-} +bool : Codec e Bool +bool = + build + (\value -> + if value then + BE.unsignedInt8 1 + + else + BE.unsignedInt8 0 + ) + (BD.unsignedInt8 + |> BD.map + (\value -> + case value of + 0 -> + Ok False + + 1 -> + Ok True + + _ -> + Err DataCorrupted + ) + ) + JE.bool + (JD.bool |> JD.map Ok) + + +{-| Codec for serializing an `Int` +-} +int : Codec e Int +int = + build + (toFloat >> BE.float64 endian) + (BD.float64 endian |> BD.map (round >> Ok)) + JE.int + (JD.int |> JD.map Ok) + + +{-| Codec for serializing a `Float` +-} +float : Codec e Float +float = + build + (BE.float64 endian) + (BD.float64 endian |> BD.map Ok) + JE.float + (JD.float |> JD.map Ok) + + + +-- DATA STRUCTURES + + +{-| Codec for serializing a `Maybe` + + import Serialize as S + + maybeIntCodec : S.Codec e (Maybe Int) + maybeIntCodec = + S.maybe S.int + +-} +maybe : Codec e a -> Codec e (Maybe a) +maybe justCodec = + customType + (\nothingEncoder justEncoder value -> + case value of + Nothing -> + nothingEncoder + + Just value_ -> + justEncoder value_ + ) + |> variant0 Nothing + |> variant1 Just justCodec + |> finishCustomType + + +{-| Codec for serializing a `List` + + import Serialize as S + + listOfStringsCodec : S.Codec e (List String) + listOfStringsCodec = + S.list S.string + +-} +list : Codec e a -> Codec e (List a) +list codec = + build + (listEncode (getBytesEncoderHelper codec)) + (BD.unsignedInt32 endian + |> BD.andThen + (\length -> BD.loop ( length, [] ) (listStep (getBytesDecoderHelper codec))) + ) + (JE.list (getJsonEncoderHelper codec)) + (JD.list (getJsonDecoderHelper codec) + |> JD.map + (List.foldr + (\value state -> + case ( value, state ) of + ( Ok ok, Ok okState ) -> + ok :: okState |> Ok + + ( _, Err _ ) -> + state + + ( Err error, Ok _ ) -> + Err error + ) + (Ok []) + ) + ) + + +listEncode : (a -> BE.Encoder) -> List a -> BE.Encoder +listEncode encoder_ list_ = + list_ + |> List.map encoder_ + |> (::) (BE.unsignedInt32 endian (List.length list_)) + |> BE.sequence + + +listStep : BD.Decoder (Result (Error e) a) -> ( Int, List a ) -> BD.Decoder (BD.Step ( Int, List a ) (Result (Error e) (List a))) +listStep decoder_ ( n, xs ) = + if n <= 0 then + BD.succeed (BD.Done (xs |> List.reverse |> Ok)) + + else + BD.map + (\x -> + case x of + Ok ok -> + BD.Loop ( n - 1, ok :: xs ) + + Err err -> + BD.Done (Err err) + ) + decoder_ + + +{-| Codec for serializing an `Array` +-} +array : Codec e a -> Codec e (Array a) +array codec = + list codec |> mapHelper (Result.map Array.fromList) Array.toList + + +{-| Codec for serializing a `Dict` + + import Serialize as S + + type alias Name = + String + + peoplesAgeCodec : S.Codec e (Dict Name Int) + peoplesAgeCodec = + S.dict S.string S.int + +-} +dict : Codec e comparable -> Codec e a -> Codec e (Dict comparable a) +dict keyCodec valueCodec = + list (tuple keyCodec valueCodec) + |> mapHelper (Result.map Dict.fromList) Dict.toList + + +{-| Codec for serializing a `Set` +-} +set : Codec e comparable -> Codec e (Set comparable) +set codec = + list codec |> mapHelper (Result.map Set.fromList) Set.toList + + +{-| Codec for serializing `()` (aka `Unit`). +-} +unit : Codec e () +unit = + build + (always (BE.sequence [])) + (BD.succeed (Ok ())) + (\_ -> JE.int 0) + (JD.succeed (Ok ())) + + +{-| Codec for serializing a tuple with 2 elements + + import Serialize as S + + pointCodec : S.Codec e ( Float, Float ) + pointCodec = + S.tuple S.float S.float + +-} +tuple : Codec e a -> Codec e b -> Codec e ( a, b ) +tuple codecFirst codecSecond = + record Tuple.pair + |> field Tuple.first codecFirst + |> field Tuple.second codecSecond + |> finishRecord + + +{-| Codec for serializing a tuple with 3 elements + + import Serialize as S + + pointCodec : S.Codec e ( Float, Float, Float ) + pointCodec = + S.tuple S.float S.float S.float + +-} +triple : Codec e a -> Codec e b -> Codec e c -> Codec e ( a, b, c ) +triple codecFirst codecSecond codecThird = + record (\a b c -> ( a, b, c )) + |> field (\( a, _, _ ) -> a) codecFirst + |> field (\( _, b, _ ) -> b) codecSecond + |> field (\( _, _, c ) -> c) codecThird + |> finishRecord + + +{-| Codec for serializing a `Result` +-} +result : Codec e error -> Codec e value -> Codec e (Result error value) +result errorCodec valueCodec = + customType + (\errEncoder okEncoder value -> + case value of + Err err -> + errEncoder err + + Ok ok -> + okEncoder ok + ) + |> variant1 Err errorCodec + |> variant1 Ok valueCodec + |> finishCustomType + + +{-| Codec for serializing [`Bytes`](https://package.elm-lang.org/packages/elm/bytes/latest/). +This is useful in combination with `mapValid` for encoding and decoding data using some specialized format. + + import Image exposing (Image) + import Serialize as S + + imageCodec : S.Codec String Image + imageCodec = + S.bytes + |> S.mapValid + (Image.decode >> Result.fromMaybe "Failed to decode PNG image.") + Image.toPng + +-} +bytes : Codec e Bytes.Bytes +bytes = + build + (\bytes_ -> + BE.sequence + [ BE.unsignedInt32 endian (Bytes.width bytes_) + , BE.bytes bytes_ + ] + ) + (BD.unsignedInt32 endian |> BD.andThen (\length -> BD.bytes length |> BD.map Ok)) + (replaceBase64Chars >> JE.string) + (JD.string + |> JD.map + (\text -> + case decode text of + Just bytes_ -> + Ok bytes_ + + Nothing -> + Err DataCorrupted + ) + ) + + +{-| Codec for serializing an integer ranging from 0 to 255. +This is useful if you have a small integer you want to serialize and not use up a lot of space. + + import Serialize as S + + type alias Color = + { red : Int + , green : Int + , blue : Int + } + + color : S.Codec e Color + color = + Color.record Color + |> S.field .red byte + |> S.field .green byte + |> S.field .blue byte + |> S.finishRecord + +**Warning:** values greater than 255 or less than 0 will wrap around. +So if you encode -1 you'll get back 255 and if you encode 257 you'll get back 1. + +-} +byte : Codec e Int +byte = + build + BE.unsignedInt8 + (BD.unsignedInt8 |> BD.map Ok) + (modBy 256 >> JE.int) + (JD.int |> JD.map Ok) + + +{-| A codec for serializing an item from a list of possible items. +If you try to encode an item that isn't in the list then the first item is defaulted to. + + import Serialize as S + + type DaysOfWeek + = Monday + | Tuesday + | Wednesday + | Thursday + | Friday + | Saturday + | Sunday + + daysOfWeekCodec : S.Codec e DaysOfWeek + daysOfWeekCodec = + S.enum Monday [ Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday ] + +Note that inserting new items in the middle of the list or removing items is a breaking change. +It's safe to add items to the end of the list though. + +-} +enum : a -> List a -> Codec e a +enum defaultItem items = + let + getIndex value = + items + |> findIndex ((==) value) + |> Maybe.withDefault -1 + |> (+) 1 + + getItem index = + if index < 0 then + Err DataCorrupted + + else if index > List.length items then + Err DataCorrupted + + else + getAt (index - 1) items |> Maybe.withDefault defaultItem |> Ok + in + build + (getIndex >> BE.unsignedInt32 endian) + (BD.unsignedInt32 endian |> BD.map getItem) + (getIndex >> JE.int) + (JD.int |> JD.map getItem) + + +getAt : Int -> List a -> Maybe a +getAt idx xs = + if idx < 0 then + Nothing + + else + List.head <| List.drop idx xs + + +{-| +-} +findIndex : (a -> Bool) -> List a -> Maybe Int +findIndex = + findIndexHelp 0 + + +{-| +-} +findIndexHelp : Int -> (a -> Bool) -> List a -> Maybe Int +findIndexHelp index predicate list_ = + case list_ of + [] -> + Nothing + + x :: xs -> + if predicate x then + Just index + + else + findIndexHelp (index + 1) predicate xs + + + +-- OBJECTS + + +{-| A partially built Codec for a record. +-} +type RecordCodec e a b + = RecordCodec + { encoder : a -> List BE.Encoder + , decoder : BD.Decoder (Result (Error e) b) + , jsonEncoder : a -> List JE.Value + , jsonDecoder : JD.Decoder (Result (Error e) b) + , fieldIndex : Int + } + + +{-| Start creating a codec for a record. + + import Serialize as S + + type alias Point = + { x : Int + , y : Int + } + + pointCodec : S.Codec e Point + pointCodec = + S.record Point + -- Note that adding, removing, or reordering fields will prevent you from decoding any data you've previously encoded. + |> S.field .x S.int + |> S.field .y S.int + |> S.finishRecord + +-} +record : b -> RecordCodec e a b +record ctor = + RecordCodec + { encoder = \_ -> [] + , decoder = BD.succeed (Ok ctor) + , jsonEncoder = \_ -> [] + , jsonDecoder = JD.succeed (Ok ctor) + , fieldIndex = 0 + } + + +{-| Add a field to the record we are creating a codec for. +-} +field : (a -> f) -> Codec e f -> RecordCodec e a (f -> b) -> RecordCodec e a b +field getter codec (RecordCodec recordCodec) = + RecordCodec + { encoder = \v -> (getBytesEncoderHelper codec <| getter v) :: recordCodec.encoder v + , decoder = + BD.map2 + (\f x -> + case ( f, x ) of + ( Ok fOk, Ok xOk ) -> + fOk xOk |> Ok + + ( Err err, _ ) -> + Err err + + ( _, Err err ) -> + Err err + ) + recordCodec.decoder + (getBytesDecoderHelper codec) + , jsonEncoder = \v -> (getJsonEncoderHelper codec <| getter v) :: recordCodec.jsonEncoder v + , jsonDecoder = + JD.map2 + (\f x -> + case ( f, x ) of + ( Ok fOk, Ok xOk ) -> + fOk xOk |> Ok + + ( Err err, _ ) -> + Err err + + ( _, Err err ) -> + Err err + ) + recordCodec.jsonDecoder + (JD.index recordCodec.fieldIndex (getJsonDecoderHelper codec)) + , fieldIndex = recordCodec.fieldIndex + 1 + } + + +{-| Finish creating a codec for a record. +-} +finishRecord : RecordCodec e a a -> Codec e a +finishRecord (RecordCodec codec) = + Codec + { encoder = codec.encoder >> List.reverse >> BE.sequence + , decoder = codec.decoder + , jsonEncoder = codec.jsonEncoder >> List.reverse >> JE.list identity + , jsonDecoder = codec.jsonDecoder + } + + + +-- CUSTOM + + +{-| A partially built codec for a custom type. +-} +type CustomTypeCodec a e match v + = CustomTypeCodec + { match : match + , jsonMatch : match + , decoder : Int -> BD.Decoder (Result (Error e) v) -> BD.Decoder (Result (Error e) v) + , jsonDecoder : Int -> JD.Decoder (Result (Error e) v) -> JD.Decoder (Result (Error e) v) + , idCounter : Int + } + + +{-| Starts building a `Codec` for a custom type. +You need to pass a pattern matching function, see the FAQ for details. + + import Serialize as S + + type Semaphore + = Red Int String Bool + | Yellow Float + | Green + + semaphoreCodec : S.Codec e Semaphore + semaphoreCodec = + S.customType + (\redEncoder yellowEncoder greenEncoder value -> + case value of + Red i s b -> + redEncoder i s b + + Yellow f -> + yellowEncoder f + + Green -> + greenEncoder + ) + -- Note that removing a variant, inserting a variant before an existing one, or swapping two variants will prevent you from decoding any data you've previously encoded. + |> S.variant3 Red S.int S.string S.bool + |> S.variant1 Yellow S.float + |> S.variant0 Green + -- It's safe to add new variants here later though + |> S.finishCustomType + +-} +customType : match -> CustomTypeCodec { youNeedAtLeastOneVariant : () } e match value +customType match = + CustomTypeCodec + { match = match + , jsonMatch = match + , decoder = \_ -> identity + , jsonDecoder = \_ -> identity + , idCounter = 0 + } + + +{-| -} +type VariantEncoder + = VariantEncoder ( BE.Encoder, JE.Value ) + + +variant : + ((List BE.Encoder -> VariantEncoder) -> a) + -> ((List JE.Value -> VariantEncoder) -> a) + -> BD.Decoder (Result (Error error) v) + -> JD.Decoder (Result (Error error) v) + -> CustomTypeCodec z error (a -> b) v + -> CustomTypeCodec () error b v +variant matchPiece matchJsonPiece decoderPiece jsonDecoderPiece (CustomTypeCodec am) = + let + enc : List BE.Encoder -> VariantEncoder + enc v = + ( BE.unsignedInt16 endian am.idCounter :: v |> BE.sequence + , JE.null + ) + |> VariantEncoder + + jsonEnc : List JE.Value -> VariantEncoder + jsonEnc v = + ( BE.sequence [] + , JE.int am.idCounter :: v |> JE.list identity + ) + |> VariantEncoder + + decoder_ : Int -> BD.Decoder (Result (Error error) v) -> BD.Decoder (Result (Error error) v) + decoder_ tag orElse = + if tag == am.idCounter then + decoderPiece + + else + am.decoder tag orElse + + jsonDecoder_ : Int -> JD.Decoder (Result (Error error) v) -> JD.Decoder (Result (Error error) v) + jsonDecoder_ tag orElse = + if tag == am.idCounter then + jsonDecoderPiece + + else + am.jsonDecoder tag orElse + in + CustomTypeCodec + { match = am.match <| matchPiece enc + , jsonMatch = am.jsonMatch <| matchJsonPiece jsonEnc + , decoder = decoder_ + , jsonDecoder = jsonDecoder_ + , idCounter = am.idCounter + 1 + } + + +{-| Define a variant with 0 parameters for a custom type. +-} +variant0 : v -> CustomTypeCodec z e (VariantEncoder -> a) v -> CustomTypeCodec () e a v +variant0 ctor = + variant + (\c -> c []) + (\c -> c []) + (BD.succeed (Ok ctor)) + (JD.succeed (Ok ctor)) + + +{-| Define a variant with 1 parameters for a custom type. +-} +variant1 : + (a -> v) + -> Codec error a + -> CustomTypeCodec z error ((a -> VariantEncoder) -> b) v + -> CustomTypeCodec () error b v +variant1 ctor m1 = + variant + (\c v -> + c + [ getBytesEncoderHelper m1 v + ] + ) + (\c v -> + c + [ getJsonEncoderHelper m1 v + ] + ) + (BD.map (result1 ctor) (getBytesDecoderHelper m1)) + (JD.map (result1 ctor) (JD.index 1 (getJsonDecoderHelper m1))) + + +result1 : + (value -> a) + -> Result error value + -> Result error a +result1 ctor value = + case value of + Ok ok -> + ctor ok |> Ok + + Err err -> + Err err + + +{-| Define a variant with 2 parameters for a custom type. +-} +variant2 : + (a -> b -> v) + -> Codec error a + -> Codec error b + -> CustomTypeCodec z error ((a -> b -> VariantEncoder) -> c) v + -> CustomTypeCodec () error c v +variant2 ctor m1 m2 = + variant + (\c v1 v2 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + ] + |> c + ) + (\c v1 v2 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + ] + |> c + ) + (BD.map2 + (result2 ctor) + (getBytesDecoderHelper m1) + (getBytesDecoderHelper m2) + ) + (JD.map2 + (result2 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.index 2 (getJsonDecoderHelper m2)) + ) + + +result2 : + (value -> a -> b) + -> Result error value + -> Result error a + -> Result error b +result2 ctor v1 v2 = + case ( v1, v2 ) of + ( Ok ok1, Ok ok2 ) -> + ctor ok1 ok2 |> Ok + + ( Err err, _ ) -> + Err err + + ( _, Err err ) -> + Err err + + +{-| Define a variant with 3 parameters for a custom type. +-} +variant3 : + (a -> b -> c -> v) + -> Codec error a + -> Codec error b + -> Codec error c + -> CustomTypeCodec z error ((a -> b -> c -> VariantEncoder) -> partial) v + -> CustomTypeCodec () error partial v +variant3 ctor m1 m2 m3 = + variant + (\c v1 v2 v3 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + , getBytesEncoderHelper m3 v3 + ] + |> c + ) + (\c v1 v2 v3 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + , getJsonEncoderHelper m3 v3 + ] + |> c + ) + (BD.map3 + (result3 ctor) + (getBytesDecoderHelper m1) + (getBytesDecoderHelper m2) + (getBytesDecoderHelper m3) + ) + (JD.map3 + (result3 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.index 2 (getJsonDecoderHelper m2)) + (JD.index 3 (getJsonDecoderHelper m3)) + ) + + +result3 : + (value -> a -> b -> c) + -> Result error value + -> Result error a + -> Result error b + -> Result error c +result3 ctor v1 v2 v3 = + case ( v1, v2, v3 ) of + ( Ok ok1, Ok ok2, Ok ok3 ) -> + ctor ok1 ok2 ok3 |> Ok + + ( Err err, _, _ ) -> + Err err + + ( _, Err err, _ ) -> + Err err + + ( _, _, Err err ) -> + Err err + + +{-| Define a variant with 4 parameters for a custom type. +-} +variant4 : + (a -> b -> c -> d -> v) + -> Codec error a + -> Codec error b + -> Codec error c + -> Codec error d + -> CustomTypeCodec z error ((a -> b -> c -> d -> VariantEncoder) -> partial) v + -> CustomTypeCodec () error partial v +variant4 ctor m1 m2 m3 m4 = + variant + (\c v1 v2 v3 v4 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + , getBytesEncoderHelper m3 v3 + , getBytesEncoderHelper m4 v4 + ] + |> c + ) + (\c v1 v2 v3 v4 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + , getJsonEncoderHelper m3 v3 + , getJsonEncoderHelper m4 v4 + ] + |> c + ) + (BD.map4 + (result4 ctor) + (getBytesDecoderHelper m1) + (getBytesDecoderHelper m2) + (getBytesDecoderHelper m3) + (getBytesDecoderHelper m4) + ) + (JD.map4 + (result4 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.index 2 (getJsonDecoderHelper m2)) + (JD.index 3 (getJsonDecoderHelper m3)) + (JD.index 4 (getJsonDecoderHelper m4)) + ) + + +result4 : + (value -> a -> b -> c -> d) + -> Result error value + -> Result error a + -> Result error b + -> Result error c + -> Result error d +result4 ctor v1 v2 v3 v4 = + case T4 v1 v2 v3 v4 of + T4 (Ok ok1) (Ok ok2) (Ok ok3) (Ok ok4) -> + ctor ok1 ok2 ok3 ok4 |> Ok + + T4 (Err err) _ _ _ -> + Err err + + T4 _ (Err err) _ _ -> + Err err + + T4 _ _ (Err err) _ -> + Err err + + T4 _ _ _ (Err err) -> + Err err + + +{-| Define a variant with 5 parameters for a custom type. +-} +variant5 : + (a -> b -> c -> d -> e -> v) + -> Codec error a + -> Codec error b + -> Codec error c + -> Codec error d + -> Codec error e + -> CustomTypeCodec z error ((a -> b -> c -> d -> e -> VariantEncoder) -> partial) v + -> CustomTypeCodec () error partial v +variant5 ctor m1 m2 m3 m4 m5 = + variant + (\c v1 v2 v3 v4 v5 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + , getBytesEncoderHelper m3 v3 + , getBytesEncoderHelper m4 v4 + , getBytesEncoderHelper m5 v5 + ] + |> c + ) + (\c v1 v2 v3 v4 v5 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + , getJsonEncoderHelper m3 v3 + , getJsonEncoderHelper m4 v4 + , getJsonEncoderHelper m5 v5 + ] + |> c + ) + (BD.map5 + (result5 ctor) + (getBytesDecoderHelper m1) + (getBytesDecoderHelper m2) + (getBytesDecoderHelper m3) + (getBytesDecoderHelper m4) + (getBytesDecoderHelper m5) + ) + (JD.map5 + (result5 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.index 2 (getJsonDecoderHelper m2)) + (JD.index 3 (getJsonDecoderHelper m3)) + (JD.index 4 (getJsonDecoderHelper m4)) + (JD.index 5 (getJsonDecoderHelper m5)) + ) + + +result5 : + (value -> a -> b -> c -> d -> e) + -> Result error value + -> Result error a + -> Result error b + -> Result error c + -> Result error d + -> Result error e +result5 ctor v1 v2 v3 v4 v5 = + case T5 v1 v2 v3 v4 v5 of + T5 (Ok ok1) (Ok ok2) (Ok ok3) (Ok ok4) (Ok ok5) -> + ctor ok1 ok2 ok3 ok4 ok5 |> Ok + + T5 (Err err) _ _ _ _ -> + Err err + + T5 _ (Err err) _ _ _ -> + Err err + + T5 _ _ (Err err) _ _ -> + Err err + + T5 _ _ _ (Err err) _ -> + Err err + + T5 _ _ _ _ (Err err) -> + Err err + + +{-| Define a variant with 6 parameters for a custom type. +-} +variant6 : + (a -> b -> c -> d -> e -> f -> v) + -> Codec error a + -> Codec error b + -> Codec error c + -> Codec error d + -> Codec error e + -> Codec error f + -> CustomTypeCodec z error ((a -> b -> c -> d -> e -> f -> VariantEncoder) -> partial) v + -> CustomTypeCodec () error partial v +variant6 ctor m1 m2 m3 m4 m5 m6 = + variant + (\c v1 v2 v3 v4 v5 v6 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + , getBytesEncoderHelper m3 v3 + , getBytesEncoderHelper m4 v4 + , getBytesEncoderHelper m5 v5 + , getBytesEncoderHelper m6 v6 + ] + |> c + ) + (\c v1 v2 v3 v4 v5 v6 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + , getJsonEncoderHelper m3 v3 + , getJsonEncoderHelper m4 v4 + , getJsonEncoderHelper m5 v5 + , getJsonEncoderHelper m6 v6 + ] + |> c + ) + (BD.map5 + (result6 ctor) + (getBytesDecoderHelper m1) + (getBytesDecoderHelper m2) + (getBytesDecoderHelper m3) + (getBytesDecoderHelper m4) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m5) + (getBytesDecoderHelper m6) + ) + ) + (JD.map5 + (result6 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.index 2 (getJsonDecoderHelper m2)) + (JD.index 3 (getJsonDecoderHelper m3)) + (JD.index 4 (getJsonDecoderHelper m4)) + (JD.map2 Tuple.pair + (JD.index 5 (getJsonDecoderHelper m5)) + (JD.index 6 (getJsonDecoderHelper m6)) + ) + ) + + +result6 : + (value -> a -> b -> c -> d -> e -> f) + -> Result error value + -> Result error a + -> Result error b + -> Result error c + -> ( Result error d, Result error e ) + -> Result error f +result6 ctor v1 v2 v3 v4 ( v5, v6 ) = + case T6 v1 v2 v3 v4 v5 v6 of + T6 (Ok ok1) (Ok ok2) (Ok ok3) (Ok ok4) (Ok ok5) (Ok ok6) -> + ctor ok1 ok2 ok3 ok4 ok5 ok6 |> Ok + + T6 (Err err) _ _ _ _ _ -> + Err err + + T6 _ (Err err) _ _ _ _ -> + Err err + + T6 _ _ (Err err) _ _ _ -> + Err err + + T6 _ _ _ (Err err) _ _ -> + Err err + + T6 _ _ _ _ (Err err) _ -> + Err err + + T6 _ _ _ _ _ (Err err) -> + Err err + + +{-| Define a variant with 7 parameters for a custom type. +-} +variant7 : + (a -> b -> c -> d -> e -> f -> g -> v) + -> Codec error a + -> Codec error b + -> Codec error c + -> Codec error d + -> Codec error e + -> Codec error f + -> Codec error g + -> CustomTypeCodec z error ((a -> b -> c -> d -> e -> f -> g -> VariantEncoder) -> partial) v + -> CustomTypeCodec () error partial v +variant7 ctor m1 m2 m3 m4 m5 m6 m7 = + variant + (\c v1 v2 v3 v4 v5 v6 v7 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + , getBytesEncoderHelper m3 v3 + , getBytesEncoderHelper m4 v4 + , getBytesEncoderHelper m5 v5 + , getBytesEncoderHelper m6 v6 + , getBytesEncoderHelper m7 v7 + ] + |> c + ) + (\c v1 v2 v3 v4 v5 v6 v7 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + , getJsonEncoderHelper m3 v3 + , getJsonEncoderHelper m4 v4 + , getJsonEncoderHelper m5 v5 + , getJsonEncoderHelper m6 v6 + , getJsonEncoderHelper m7 v7 + ] + |> c + ) + (BD.map5 + (result7 ctor) + (getBytesDecoderHelper m1) + (getBytesDecoderHelper m2) + (getBytesDecoderHelper m3) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m4) + (getBytesDecoderHelper m5) + ) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m6) + (getBytesDecoderHelper m7) + ) + ) + (JD.map5 + (result7 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.index 2 (getJsonDecoderHelper m2)) + (JD.index 3 (getJsonDecoderHelper m3)) + (JD.map2 Tuple.pair + (JD.index 4 (getJsonDecoderHelper m4)) + (JD.index 5 (getJsonDecoderHelper m5)) + ) + (JD.map2 Tuple.pair + (JD.index 6 (getJsonDecoderHelper m6)) + (JD.index 7 (getJsonDecoderHelper m7)) + ) + ) + + +result7 : + (value -> a -> b -> c -> d -> e -> f -> g) + -> Result error value + -> Result error a + -> Result error b + -> ( Result error c, Result error d ) + -> ( Result error e, Result error f ) + -> Result error g +result7 ctor v1 v2 v3 ( v4, v5 ) ( v6, v7 ) = + case T7 v1 v2 v3 v4 v5 v6 v7 of + T7 (Ok ok1) (Ok ok2) (Ok ok3) (Ok ok4) (Ok ok5) (Ok ok6) (Ok ok7) -> + ctor ok1 ok2 ok3 ok4 ok5 ok6 ok7 |> Ok + + T7 (Err err) _ _ _ _ _ _ -> + Err err + + T7 _ (Err err) _ _ _ _ _ -> + Err err + + T7 _ _ (Err err) _ _ _ _ -> + Err err + + T7 _ _ _ (Err err) _ _ _ -> + Err err + + T7 _ _ _ _ (Err err) _ _ -> + Err err + + T7 _ _ _ _ _ (Err err) _ -> + Err err + + T7 _ _ _ _ _ _ (Err err) -> + Err err + + +{-| Define a variant with 8 parameters for a custom type. +-} +variant8 : + (a -> b -> c -> d -> e -> f -> g -> h -> v) + -> Codec error a + -> Codec error b + -> Codec error c + -> Codec error d + -> Codec error e + -> Codec error f + -> Codec error g + -> Codec error h + -> CustomTypeCodec z error ((a -> b -> c -> d -> e -> f -> g -> h -> VariantEncoder) -> partial) v + -> CustomTypeCodec () error partial v +variant8 ctor m1 m2 m3 m4 m5 m6 m7 m8 = + variant + (\c v1 v2 v3 v4 v5 v6 v7 v8 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + , getBytesEncoderHelper m3 v3 + , getBytesEncoderHelper m4 v4 + , getBytesEncoderHelper m5 v5 + , getBytesEncoderHelper m6 v6 + , getBytesEncoderHelper m7 v7 + , getBytesEncoderHelper m8 v8 + ] + |> c + ) + (\c v1 v2 v3 v4 v5 v6 v7 v8 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + , getJsonEncoderHelper m3 v3 + , getJsonEncoderHelper m4 v4 + , getJsonEncoderHelper m5 v5 + , getJsonEncoderHelper m6 v6 + , getJsonEncoderHelper m7 v7 + , getJsonEncoderHelper m8 v8 + ] + |> c + ) + (BD.map5 + (result8 ctor) + (getBytesDecoderHelper m1) + (getBytesDecoderHelper m2) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m3) + (getBytesDecoderHelper m4) + ) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m5) + (getBytesDecoderHelper m6) + ) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m7) + (getBytesDecoderHelper m8) + ) + ) + (JD.map5 + (result8 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.index 2 (getJsonDecoderHelper m2)) + (JD.map2 Tuple.pair + (JD.index 3 (getJsonDecoderHelper m3)) + (JD.index 4 (getJsonDecoderHelper m4)) + ) + (JD.map2 Tuple.pair + (JD.index 5 (getJsonDecoderHelper m5)) + (JD.index 6 (getJsonDecoderHelper m6)) + ) + (JD.map2 Tuple.pair + (JD.index 7 (getJsonDecoderHelper m7)) + (JD.index 8 (getJsonDecoderHelper m8)) + ) + ) + + +result8 : + (value -> a -> b -> c -> d -> e -> f -> g -> h) + -> Result error value + -> Result error a + -> ( Result error b, Result error c ) + -> ( Result error d, Result error e ) + -> ( Result error f, Result error g ) + -> Result error h +result8 ctor v1 v2 ( v3, v4 ) ( v5, v6 ) ( v7, v8 ) = + case T8 v1 v2 v3 v4 v5 v6 v7 v8 of + T8 (Ok ok1) (Ok ok2) (Ok ok3) (Ok ok4) (Ok ok5) (Ok ok6) (Ok ok7) (Ok ok8) -> + ctor ok1 ok2 ok3 ok4 ok5 ok6 ok7 ok8 |> Ok + + T8 (Err err) _ _ _ _ _ _ _ -> + Err err + + T8 _ (Err err) _ _ _ _ _ _ -> + Err err + + T8 _ _ (Err err) _ _ _ _ _ -> + Err err + + T8 _ _ _ (Err err) _ _ _ _ -> + Err err + + T8 _ _ _ _ (Err err) _ _ _ -> + Err err + + T8 _ _ _ _ _ (Err err) _ _ -> + Err err + + T8 _ _ _ _ _ _ (Err err) _ -> + Err err + + T8 _ _ _ _ _ _ _ (Err err) -> + Err err + + +{-| Define a variant with 9 parameters for a custom type. +-} +variant9 : + (a -> b -> c -> d -> e -> f -> g -> h -> i -> v) + -> Codec error a + -> Codec error b + -> Codec error c + -> Codec error d + -> Codec error e + -> Codec error f + -> Codec error g + -> Codec error h + -> Codec error i + -> CustomTypeCodec z error ((a -> b -> c -> d -> e -> f -> g -> h -> i -> VariantEncoder) -> partial) v + -> CustomTypeCodec () error partial v +variant9 ctor m1 m2 m3 m4 m5 m6 m7 m8 m9 = + variant + (\c v1 v2 v3 v4 v5 v6 v7 v8 v9 -> + [ getBytesEncoderHelper m1 v1 + , getBytesEncoderHelper m2 v2 + , getBytesEncoderHelper m3 v3 + , getBytesEncoderHelper m4 v4 + , getBytesEncoderHelper m5 v5 + , getBytesEncoderHelper m6 v6 + , getBytesEncoderHelper m7 v7 + , getBytesEncoderHelper m8 v8 + , getBytesEncoderHelper m9 v9 + ] + |> c + ) + (\c v1 v2 v3 v4 v5 v6 v7 v8 v9 -> + [ getJsonEncoderHelper m1 v1 + , getJsonEncoderHelper m2 v2 + , getJsonEncoderHelper m3 v3 + , getJsonEncoderHelper m4 v4 + , getJsonEncoderHelper m5 v5 + , getJsonEncoderHelper m6 v6 + , getJsonEncoderHelper m7 v7 + , getJsonEncoderHelper m8 v8 + , getJsonEncoderHelper m9 v9 + ] + |> c + ) + (BD.map5 + (result9 ctor) + (getBytesDecoderHelper m1) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m2) + (getBytesDecoderHelper m3) + ) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m4) + (getBytesDecoderHelper m5) + ) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m6) + (getBytesDecoderHelper m7) + ) + (BD.map2 Tuple.pair + (getBytesDecoderHelper m8) + (getBytesDecoderHelper m9) + ) + ) + (JD.map5 + (result9 ctor) + (JD.index 1 (getJsonDecoderHelper m1)) + (JD.map2 Tuple.pair + (JD.index 2 (getJsonDecoderHelper m2)) + (JD.index 3 (getJsonDecoderHelper m3)) + ) + (JD.map2 Tuple.pair + (JD.index 4 (getJsonDecoderHelper m4)) + (JD.index 5 (getJsonDecoderHelper m5)) + ) + (JD.map2 Tuple.pair + (JD.index 6 (getJsonDecoderHelper m6)) + (JD.index 7 (getJsonDecoderHelper m7)) + ) + (JD.map2 Tuple.pair + (JD.index 8 (getJsonDecoderHelper m8)) + (JD.index 9 (getJsonDecoderHelper m9)) + ) + ) + + +result9 : + (value -> a -> b -> c -> d -> e -> f -> g -> h -> i) + -> Result error value + -> ( Result error a, Result error b ) + -> ( Result error c, Result error d ) + -> ( Result error e, Result error f ) + -> ( Result error g, Result error h ) + -> Result error i +result9 ctor v1 ( v2, v3 ) ( v4, v5 ) ( v6, v7 ) ( v8, v9 ) = + case T9 v1 v2 v3 v4 v5 v6 v7 v8 v9 of + T9 (Ok ok1) (Ok ok2) (Ok ok3) (Ok ok4) (Ok ok5) (Ok ok6) (Ok ok7) (Ok ok8) (Ok ok9) -> + ctor ok1 ok2 ok3 ok4 ok5 ok6 ok7 ok8 ok9 |> Ok + + T9 (Err err) _ _ _ _ _ _ _ _ -> + Err err + + T9 _ (Err err) _ _ _ _ _ _ _ -> + Err err + + T9 _ _ (Err err) _ _ _ _ _ _ -> + Err err + + T9 _ _ _ (Err err) _ _ _ _ _ -> + Err err + + T9 _ _ _ _ (Err err) _ _ _ _ -> + Err err + + T9 _ _ _ _ _ (Err err) _ _ _ -> + Err err + + T9 _ _ _ _ _ _ (Err err) _ _ -> + Err err + + T9 _ _ _ _ _ _ _ (Err err) _ -> + Err err + + T9 _ _ _ _ _ _ _ _ (Err err) -> + Err err + + +{-| Finish creating a codec for a custom type. +-} +finishCustomType : CustomTypeCodec () e (a -> VariantEncoder) a -> Codec e a +finishCustomType (CustomTypeCodec am) = + build + (am.match >> (\(VariantEncoder ( a, _ )) -> a)) + (BD.unsignedInt16 endian + |> BD.andThen + (\tag -> + am.decoder tag (BD.succeed (Err DataCorrupted)) + ) + ) + (am.jsonMatch >> (\(VariantEncoder ( _, a )) -> a)) + (JD.index 0 JD.int + |> JD.andThen + (\tag -> + am.jsonDecoder tag (JD.succeed (Err DataCorrupted)) + ) + ) + + + +---- MAPPING + + +{-| Map from one codec to another codec + + import Serialize as S + + type UserId + = UserId Int + + userIdCodec : S.Codec e UserId + userIdCodec = + S.int |> S.map UserId (\(UserId id) -> id) + +Note that there's nothing preventing you from encoding Elm values that will map to some different value when you decode them. +I recommend writing tests for Codecs that use `map` to make sure you get back the same Elm value you put in. +[Here's some helper functions to get you started.](https://github.com/MartinSStewart/elm-geometry-serialize/blob/6f2244c28631ede1b864cb43541d1573dc628904/tests/Tests.elm#L49-L74) + +-} +map : (a -> b) -> (b -> a) -> Codec e a -> Codec e b +map fromBytes_ toBytes_ codec = + mapHelper + (\value -> + case value of + Ok ok -> + fromBytes_ ok |> Ok + + Err err -> + Err err + ) + toBytes_ + codec + + +mapHelper : (Result (Error e) a -> Result (Error e) b) -> (b -> a) -> Codec e a -> Codec e b +mapHelper fromBytes_ toBytes_ codec = + build + (\v -> toBytes_ v |> getBytesEncoderHelper codec) + (getBytesDecoderHelper codec |> BD.map fromBytes_) + (\v -> toBytes_ v |> getJsonEncoderHelper codec) + (getJsonDecoderHelper codec |> JD.map fromBytes_) + + +{-| Map from one codec to another codec in a way that can potentially fail when decoding. + + -- Email module is from https://package.elm-lang.org/packages/tricycle/elm-email/1.0.2/ + + + import Email + import Serialize as S + + emailCodec : S.Codec String Float + emailCodec = + S.string + |> S.mapValid + (\text -> + case Email.fromString text of + Just email -> + Ok email + + Nothing -> + Err "Invalid email" + ) + Email.toString + +Note that there's nothing preventing you from encoding Elm values that will produce Err when you decode them. +I recommend writing tests for Codecs that use `mapValid` to make sure you get back the same Elm value you put in. +[Here's some helper functions to get you started.](https://github.com/MartinSStewart/elm-geometry-serialize/blob/6f2244c28631ede1b864cb43541d1573dc628904/tests/Tests.elm#L49-L74) + +-} +mapValid : (a -> Result e b) -> (b -> a) -> Codec e a -> Codec e b +mapValid fromBytes_ toBytes_ codec = + build + (\v -> toBytes_ v |> getBytesEncoderHelper codec) + (getBytesDecoderHelper codec + |> BD.map + (\value -> + case value of + Ok ok -> + fromBytes_ ok |> Result.mapError CustomError + + Err err -> + Err err + ) + ) + (\v -> toBytes_ v |> getJsonEncoderHelper codec) + (getJsonDecoderHelper codec + |> JD.map + (\value -> + case value of + Ok ok -> + fromBytes_ ok |> Result.mapError CustomError + + Err err -> + Err err + ) + ) + + +{-| Map errors generated by `mapValid`. +-} +mapError : (e1 -> e2) -> Codec e1 a -> Codec e2 a +mapError mapFunc codec = + build + (getBytesEncoderHelper codec) + (getBytesDecoderHelper codec |> BD.map (mapErrorHelper mapFunc)) + (getJsonEncoderHelper codec) + (getJsonDecoderHelper codec |> JD.map (mapErrorHelper mapFunc)) + + +mapErrorHelper : (e -> a) -> Result (Error e) b -> Result (Error a) b +mapErrorHelper mapFunc = + Result.mapError + (\error -> + case error of + CustomError custom -> + mapFunc custom |> CustomError + + DataCorrupted -> + DataCorrupted + + SerializerOutOfDate -> + SerializerOutOfDate + ) + + + +-- STACK UNSAFE + + +{-| Handle situations where you need to define a codec in terms of itself. + + import Serialize as S + + type Peano + = Peano (Maybe Peano) + + {-| The compiler will complain that this function causes an infinite loop. + -} + badPeanoCodec : S.Codec e Peano + badPeanoCodec = + S.maybe badPeanoCodec |> S.map Peano (\(Peano a) -> a) + + {-| Now the compiler is happy! + -} + goodPeanoCodec : S.Codec e Peano + goodPeanoCodec = + S.maybe (S.lazy (\() -> goodPeanoCodec)) |> S.map Peano (\(Peano a) -> a) + +**Warning:** This is not stack safe. + +In general if you have a type that contains itself, like with our the Peano example, then you're at risk of a stack overflow while decoding. +Even if you're translating your nested data into a list before encoding, you're at risk, because the function translating back after decoding can cause a stack overflow if the original value was nested deeply enough. +Be careful here, and test your codecs using elm-test with larger inputs than you ever expect to see in real life. + +-} +lazy : (() -> Codec e a) -> Codec e a +lazy f = + build + (\value -> getBytesEncoderHelper (f ()) value) + (BD.succeed () |> BD.andThen (\() -> getBytesDecoderHelper (f ()))) + (\value -> getJsonEncoderHelper (f ()) value) + (JD.succeed () |> JD.andThen (\() -> getJsonDecoderHelper (f ()))) diff --git a/src/Terminal/Publish.elm b/src/Terminal/Publish.elm index 3af2ff60f..edd9666c0 100644 --- a/src/Terminal/Publish.elm +++ b/src/Terminal/Publish.elm @@ -24,6 +24,7 @@ import Compiler.Json.Decode as D import Compiler.Json.String as Json import Compiler.Reporting.Doc as D import List.Extra as List +import Serialize import System.Exit as Exit import System.IO as IO exposing (IO) import System.Process as Process @@ -514,7 +515,7 @@ register manager pkg vsn docs commitHash sha = Http.upload manager url [ Http.filePart "elm.json" "elm.json" - , Http.jsonPart "docs.json" "docs.json" (Docs.jsonEncoder docs) + , Http.jsonPart "docs.json" "docs.json" (Serialize.encodeToJson Docs.jsonCodec docs) , Http.filePart "README.md" "README.md" , Http.stringPart "github-hash" (Http.shaToChars sha) ] diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index 4cdc1f9d7..f9df21df5 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -1266,4 +1266,48 @@ httpExceptionContentDecoder = httpExceptionContentCodec : Codec e HttpExceptionContent httpExceptionContentCodec = - Debug.todo "httpExceptionContentCodec" + Serialize.customType + (\statusCodeExceptionEncoder tooManyRedirectsEncoder connectionFailureEncoder value -> + case value of + StatusCodeException response body -> + statusCodeExceptionEncoder response body + + TooManyRedirects responses -> + tooManyRedirectsEncoder responses + + ConnectionFailure someException -> + connectionFailureEncoder someException + ) + |> Serialize.variant2 StatusCodeException httpResponseCodec Serialize.string + |> Serialize.variant1 TooManyRedirects (Serialize.list httpResponseCodec) + |> Serialize.variant1 ConnectionFailure someExceptionCodec + |> Serialize.finishCustomType + + +httpResponseCodec : Codec e (HttpResponse body) +httpResponseCodec = + Serialize.customType + (\httpResponseCodecEncoder (HttpResponse httpResponse) -> + httpResponseCodecEncoder httpResponse + ) + |> Serialize.variant1 + HttpResponse + (Serialize.record + (\responseStatus responseHeaders -> + { responseStatus = responseStatus, responseHeaders = responseHeaders } + ) + |> Serialize.field .responseStatus httpStatusCodec + |> Serialize.field .responseHeaders (Serialize.list (Serialize.tuple Serialize.string Serialize.string)) + |> Serialize.finishRecord + ) + |> Serialize.finishCustomType + + +httpStatusCodec : Codec e HttpStatus +httpStatusCodec = + Serialize.customType + (\httpStatusCodecEncoder (HttpStatus statusCode statusMessage) -> + httpStatusCodecEncoder statusCode statusMessage + ) + |> Serialize.variant2 HttpStatus Serialize.int Serialize.string + |> Serialize.finishCustomType From 0ce32ec40cc6357bb0892247d0e6936799dc39b5 Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Wed, 11 Dec 2024 18:45:16 +0000 Subject: [PATCH 6/7] 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) From 5ac445143369073a780c11add348657a32e52bfd Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Wed, 11 Dec 2024 19:30:21 +0000 Subject: [PATCH 7/7] fix elm-review warnings --- review/src/ReviewConfig.elm | 5 +- src/Builder/Elm/Outline.elm | 37 --------- src/Compiler/AST/Utils/Binop.elm | 49 ----------- src/Compiler/Json/Decode.elm | 73 ----------------- src/Compiler/Json/Encode.elm | 113 -------------------------- src/Compiler/Reporting/Doc.elm | 16 +--- src/Data/Map.elm | 2 +- src/Serialize.elm | 16 +++- src/System/IO.elm | 42 +++++++++- src/Utils/Main.elm | 135 ------------------------------- 10 files changed, 58 insertions(+), 430 deletions(-) diff --git a/review/src/ReviewConfig.elm b/review/src/ReviewConfig.elm index 344bcadd3..12848e065 100644 --- a/review/src/ReviewConfig.elm +++ b/review/src/ReviewConfig.elm @@ -38,9 +38,8 @@ config = [ Docs.ReviewAtDocs.rule , NoConfusingPrefixOperator.rule , NoDebug.Log.rule - - -- , NoDebug.TodoOrToString.rule - -- |> Rule.ignoreErrorsForDirectories [ "tests/" ] + , NoDebug.TodoOrToString.rule + |> Rule.ignoreErrorsForDirectories [ "tests/" ] , NoExposingEverything.rule , NoImportingEverything.rule [] , NoMissingTypeAnnotation.rule diff --git a/src/Builder/Elm/Outline.elm b/src/Builder/Elm/Outline.elm index bddf98007..901595c84 100644 --- a/src/Builder/Elm/Outline.elm +++ b/src/Builder/Elm/Outline.elm @@ -10,8 +10,6 @@ module Builder.Elm.Outline exposing , flattenExposed , read , srcDirCodec - , srcDirDecoder - , srcDirEncoder , write ) @@ -29,8 +27,6 @@ import Compiler.Json.Decode as D import Compiler.Json.Encode as E import Compiler.Parse.Primitives as P import Data.Map as Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) import System.IO as IO exposing (IO) import Utils.Main as Utils exposing (FilePath) @@ -423,39 +419,6 @@ boundParser bound tooLong = Err (P.PErr P.Consumed row newCol (\_ _ -> tooLong)) -srcDirEncoder : SrcDir -> Encode.Value -srcDirEncoder srcDir = - case srcDir of - AbsoluteSrcDir dir -> - Encode.object - [ ( "type", Encode.string "AbsoluteSrcDir" ) - , ( "dir", Encode.string dir ) - ] - - RelativeSrcDir dir -> - Encode.object - [ ( "type", Encode.string "RelativeSrcDir" ) - , ( "dir", Encode.string dir ) - ] - - -srcDirDecoder : Decode.Decoder SrcDir -srcDirDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "AbsoluteSrcDir" -> - Decode.map AbsoluteSrcDir (Decode.field "dir" Decode.string) - - "RelativeSrcDir" -> - Decode.map RelativeSrcDir (Decode.field "dir" Decode.string) - - _ -> - Decode.fail ("Failed to decode SrcDir's type: " ++ type_) - ) - - srcDirCodec : Codec e SrcDir srcDirCodec = Serialize.customType diff --git a/src/Compiler/AST/Utils/Binop.elm b/src/Compiler/AST/Utils/Binop.elm index 3c084c2f0..bea5ee8ab 100644 --- a/src/Compiler/AST/Utils/Binop.elm +++ b/src/Compiler/AST/Utils/Binop.elm @@ -2,15 +2,9 @@ module Compiler.AST.Utils.Binop exposing ( Associativity(..) , Precedence , associativityCodec - , associativityDecoder - , associativityEncoder , precedenceCodec - , precedenceDecoder - , precedenceEncoder ) -import Json.Decode as Decode -import Json.Encode as Encode import Serialize exposing (Codec) @@ -28,54 +22,11 @@ type Associativity | Right -precedenceEncoder : Precedence -> Encode.Value -precedenceEncoder = - Encode.int - - -precedenceDecoder : Decode.Decoder Precedence -precedenceDecoder = - Decode.int - - precedenceCodec : Codec e Precedence precedenceCodec = Serialize.int -associativityEncoder : Associativity -> Encode.Value -associativityEncoder associativity = - case associativity of - Left -> - Encode.string "Left" - - Non -> - Encode.string "Non" - - Right -> - Encode.string "Right" - - -associativityDecoder : Decode.Decoder Associativity -associativityDecoder = - Decode.string - |> Decode.andThen - (\str -> - case str of - "Left" -> - Decode.succeed Left - - "Non" -> - Decode.succeed Non - - "Right" -> - Decode.succeed Right - - _ -> - Decode.fail ("Unknown Associativity: " ++ str) - ) - - associativityCodec : Codec e Associativity associativityCodec = Serialize.customType diff --git a/src/Compiler/Json/Decode.elm b/src/Compiler/Json/Decode.elm index 431160056..60f7a6006 100644 --- a/src/Compiler/Json/Decode.elm +++ b/src/Compiler/Json/Decode.elm @@ -7,107 +7,34 @@ module Compiler.Json.Decode exposing , Problem(..) , StringProblem(..) , apply - , assocListDict , bind , customString , dict - , everySet , failure , field , fmap , fromByteString , int - , jsonPair , list , mapError , nonEmptyList - , nonempty , oneOf - , oneOrMore , pair , pairs , pure - , result , string ) import Compiler.Data.NonEmptyList as NE -import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) import Compiler.Json.String as Json import Compiler.Parse.Keyword as K import Compiler.Parse.Primitives as P exposing (Col, Row) import Compiler.Reporting.Annotation as A import Data.Map as Dict exposing (Dict) -import Data.Set as EverySet exposing (EverySet) -import Json.Decode as Decode import Utils.Crash exposing (crash) --- CORE HELPERS - - -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 toComparable) - - -jsonPair : Decode.Decoder a -> Decode.Decoder b -> Decode.Decoder ( a, b ) -jsonPair firstDecoder secondDecoder = - Decode.map2 Tuple.pair - (Decode.field "a" firstDecoder) - (Decode.field "b" secondDecoder) - - -everySet : (a -> comparable) -> Decode.Decoder a -> Decode.Decoder (EverySet comparable a) -everySet toComparable decoder = - Decode.list decoder - |> Decode.map (EverySet.fromList toComparable) - - -nonempty : Decode.Decoder a -> Decode.Decoder (NE.Nonempty a) -nonempty decoder = - Decode.list decoder - |> Decode.andThen - (\values -> - case values of - x :: xs -> - Decode.succeed (NE.Nonempty x xs) - - [] -> - Decode.fail "Empty list when it should have at least one element (non-empty list)!" - ) - - -oneOrMore : Decode.Decoder a -> Decode.Decoder (OneOrMore a) -oneOrMore decoder = - Decode.oneOf - [ Decode.map OneOrMore.one (Decode.field "one" decoder) - , Decode.map2 OneOrMore.more - (Decode.field "left" (Decode.lazy (\_ -> oneOrMore decoder))) - (Decode.field "right" (Decode.lazy (\_ -> oneOrMore decoder))) - ] - - -result : Decode.Decoder x -> Decode.Decoder a -> Decode.Decoder (Result x a) -result errDecoder successDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "Err" -> - Decode.map Err (Decode.field "value" errDecoder) - - "Ok" -> - Decode.map Ok (Decode.field "value" successDecoder) - - _ -> - Decode.fail ("Failed to decode result's type: " ++ type_) - ) - - - -- RUNNERS diff --git a/src/Compiler/Json/Encode.elm b/src/Compiler/Json/Encode.elm index 890df1c51..892aad592 100644 --- a/src/Compiler/Json/Encode.elm +++ b/src/Compiler/Json/Encode.elm @@ -1,104 +1,25 @@ module Compiler.Json.Encode exposing ( Value(..) , array - , assocListDict , bool , chars , dict , encodeUgly - , everySet , int - , jsonPair , list - , maybe , name - , nonempty , null - , number , object - , oneOrMore - , result , string - , toJsonValue , write , writeUgly ) -import Compiler.Data.NonEmptyList as NE -import Compiler.Data.OneOrMore exposing (OneOrMore(..)) import Data.Map as Dict exposing (Dict) -import Data.Set as EverySet exposing (EverySet) -import Json.Encode as Encode import System.IO as IO exposing (IO(..)) --- CORE HELPERS - - -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 -jsonPair firstEncoder secondEncoder ( a, b ) = - Encode.object - [ ( "a", firstEncoder a ) - , ( "b", secondEncoder b ) - ] - - -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 -result errEncoder successEncoder resultValue = - case resultValue of - Ok value -> - Encode.object - [ ( "type", Encode.string "Ok" ) - , ( "value", successEncoder value ) - ] - - Err err -> - Encode.object - [ ( "type", Encode.string "Err" ) - , ( "value", errEncoder err ) - ] - - -maybe : (a -> Encode.Value) -> Maybe a -> Encode.Value -maybe encoder maybeValue = - case maybeValue of - Just value -> - encoder value - - Nothing -> - Encode.null - - -nonempty : (a -> Encode.Value) -> NE.Nonempty a -> Encode.Value -nonempty encoder (NE.Nonempty x xs) = - Encode.list encoder (x :: xs) - - -oneOrMore : (a -> Encode.Value) -> OneOrMore a -> Encode.Value -oneOrMore encoder oneOrMore_ = - case oneOrMore_ of - One value -> - Encode.object [ ( "one", encoder value ) ] - - More left right -> - Encode.object - [ ( "left", oneOrMore encoder left ) - , ( "right", oneOrMore encoder right ) - ] - - - -- VALUES @@ -142,11 +63,6 @@ int = Integer -number : Float -> Value -number = - Number - - null : Value null = Null @@ -359,32 +275,3 @@ encodeObject indent first rest = encodeField : String -> ( String, Value ) -> String encodeField indent ( key, value ) = "\"" ++ key ++ "\": " ++ encodeHelp indent value - - - --- JSON VALUE - - -toJsonValue : Value -> Encode.Value -toJsonValue value = - case value of - Array arr -> - Encode.list toJsonValue arr - - Object obj -> - Encode.object (List.map (Tuple.mapSecond toJsonValue) obj) - - StringVal builder -> - Encode.string builder - - Boolean boolean -> - Encode.bool boolean - - Integer n -> - Encode.int n - - Number scientific -> - Encode.float scientific - - Null -> - Encode.null diff --git a/src/Compiler/Reporting/Doc.elm b/src/Compiler/Reporting/Doc.elm index 911fca56e..f8c5e8d34 100644 --- a/src/Compiler/Reporting/Doc.elm +++ b/src/Compiler/Reporting/Doc.elm @@ -12,7 +12,7 @@ module Compiler.Reporting.Doc exposing , stack, reflow, commaSep , toSimpleNote, toFancyNote, toSimpleHint, toFancyHint , link, fancyLink, reflowLink, makeLink, makeNakedLink - , args, moreArgs, ordinal, intToOrdinal, cycle + , args, ordinal, intToOrdinal, cycle ) {-| @@ -30,7 +30,7 @@ module Compiler.Reporting.Doc exposing @docs stack, reflow, commaSep @docs toSimpleNote, toFancyNote, toSimpleHint, toFancyHint @docs link, fancyLink, reflowLink, makeLink, makeNakedLink -@docs args, moreArgs, ordinal, intToOrdinal, cycle +@docs args, ordinal, intToOrdinal, cycle -} @@ -212,18 +212,6 @@ args n = ) -moreArgs : Int -> String -moreArgs n = - String.fromInt n - ++ " more" - ++ (if n == 1 then - " argument" - - else - " arguments" - ) - - ordinal : Index.ZeroBased -> String ordinal index = intToOrdinal (Index.toHuman index) diff --git a/src/Data/Map.elm b/src/Data/Map.elm index af2e0f30e..1c4a8a23a 100644 --- a/src/Data/Map.elm +++ b/src/Data/Map.elm @@ -277,7 +277,7 @@ merge : -> Dict comparable k b -> result -> result -merge keyComparison leftStep bothStep rightStep (D leftDict) (D rightDict) initialResult = +merge _ leftStep bothStep rightStep (D leftDict) (D rightDict) initialResult = Dict.merge (\_ ( k, a ) -> leftStep k a) (\_ ( k, a ) ( _, b ) -> bothStep k a b) diff --git a/src/Serialize.elm b/src/Serialize.elm index 4393fbda1..75f628959 100644 --- a/src/Serialize.elm +++ b/src/Serialize.elm @@ -4,10 +4,9 @@ module Serialize exposing , string, bool, float, int, unit, bytes, byte , maybe, list, array, dict, set, tuple, triple, result, enum , RecordCodec, record, field, finishRecord - , CustomTypeCodec, customType, variant0, variant1, variant2, variant3, variant4, variant5, variant6, variant7, variant8, finishCustomType, VariantEncoder + , CustomTypeCodec, customType, variant0, variant1, variant2, variant3, variant4, variant5, variant6, variant7, variant8, variant9, finishCustomType, VariantEncoder , map, mapValid, mapError , lazy - , variant9 ) {-| Ref.: **Initial implementation from `MartinSStewart/elm-serialize/1.3.1`** @@ -49,7 +48,7 @@ Here's some advice when choosing: # Custom Types -@docs CustomTypeCodec, customType, variant0, variant1, variant2, variant3, variant4, variant5, variant6, variant7, variant8, finishCustomType, VariantEncoder +@docs CustomTypeCodec, customType, variant0, variant1, variant2, variant3, variant4, variant5, variant6, variant7, variant8, variant9, finishCustomType, VariantEncoder # Mapping @@ -141,6 +140,7 @@ getJsonDecoderHelper (Codec m) = decodeFromBytes : Codec e a -> Bytes.Bytes -> Result (Error e) a decodeFromBytes codec bytes_ = let + decoder : BD.Decoder (Result (Error e) a) decoder = BD.unsignedInt8 |> BD.andThen @@ -208,6 +208,7 @@ decodeFromString codec base64 = decodeFromJson : Codec e a -> JE.Value -> Result (Error e) a decodeFromJson codec json = let + decoder : JD.Decoder (Result (Error e) a) decoder = JD.index 0 JD.int |> JD.andThen @@ -274,6 +275,7 @@ getJsonDecoder errorToString codec = decode : String -> Maybe Bytes.Bytes decode base64text = let + replaceChar : Regex.Match -> String replaceChar rematch = case rematch.match of "-" -> @@ -282,6 +284,7 @@ decode base64text = _ -> "/" + strlen : Int strlen = String.length base64text in @@ -290,9 +293,11 @@ decode base64text = else let + hanging : Int hanging = modBy 4 strlen + ilen : Int ilen = if hanging == 0 then 0 @@ -366,6 +371,7 @@ encodeToJson codec value = replaceBase64Chars : Bytes.Bytes -> String replaceBase64Chars = let + replaceChar : Regex.Match -> String replaceChar rematch = case rematch.match of "+" -> @@ -758,12 +764,14 @@ It's safe to add items to the end of the list though. enum : a -> List a -> Codec e a enum defaultItem items = let + getIndex : a -> Int getIndex value = items |> findIndex ((==) value) |> Maybe.withDefault -1 |> (+) 1 + getItem : Int -> Result (Error e) a getItem index = if index < 0 then Err DataCorrupted @@ -1944,4 +1952,4 @@ lazy f = (\value -> getBytesEncoderHelper (f ()) value) (BD.succeed () |> BD.andThen (\() -> getBytesDecoderHelper (f ()))) (\value -> getJsonEncoderHelper (f ()) value) - (JD.succeed () |> JD.andThen (\() -> getJsonDecoderHelper (f ()))) + (JD.lazy (\() -> getJsonDecoderHelper (f ()))) diff --git a/src/System/IO.elm b/src/System/IO.elm index acda3e0dc..1792bfc0c 100644 --- a/src/System/IO.elm +++ b/src/System/IO.elm @@ -137,6 +137,10 @@ run app = , recvDirCanonicalizePath (\{ index, value } -> DirCanonicalizePathMsg index value) , recvBinaryDecodeFileOrFail (\{ index, value } -> BinaryDecodeFileOrFailMsg index value) , recvWrite WriteMsg + , recvDirRemoveFile DirRemoveFileMsg + , recvDirRemoveDirectoryRecursive DirRemoveDirectoryRecursiveMsg + , recvDirWithCurrentDirectory DirWithCurrentDirectoryMsg + , recvReplGetInputLineWithInitial (\{ index, value } -> ReplGetInputLineWithInitialMsg index value) , recvNewEmptyMVar (\{ index, value } -> NewEmptyMVarMsg index value) , recvReadMVar (\{ index, value } -> ReadMVarMsg index value) , recvPutMVar PutMVarMsg @@ -212,6 +216,10 @@ type Msg | DirCanonicalizePathMsg Int FilePath | BinaryDecodeFileOrFailMsg Int Encode.Value | WriteMsg Int + | DirRemoveFileMsg Int + | DirRemoveDirectoryRecursiveMsg Int + | DirWithCurrentDirectoryMsg Int + | ReplGetInputLineWithInitialMsg Int (Maybe String) | NewEmptyMVarMsg Int Int | ReadMVarMsg Int Encode.Value | PutMVarMsg Int @@ -575,6 +583,38 @@ update msg model = _ -> crash "WriteMsg" + DirRemoveFileMsg index -> + case Dict.get index model.next of + Just (DirRemoveFileNext fn) -> + update (PureMsg index (fn ())) model + + _ -> + crash "DirRemoveFileMsg" + + DirRemoveDirectoryRecursiveMsg index -> + case Dict.get index model.next of + Just (DirRemoveDirectoryRecursiveNext fn) -> + update (PureMsg index (fn ())) model + + _ -> + crash "DirRemoveDirectoryRecursiveMsg" + + DirWithCurrentDirectoryMsg index -> + case Dict.get index model.next of + Just (DirWithCurrentDirectoryNext fn) -> + update (PureMsg index (fn ())) model + + _ -> + crash "DirWithCurrentDirectoryMsg" + + ReplGetInputLineWithInitialMsg index value -> + case Dict.get index model.next of + Just (ReplGetInputLineWithInitialNext fn) -> + update (PureMsg index (fn value)) model + + _ -> + crash "ReplGetInputLineWithInitialMsg" + port sendGetLine : Int -> Cmd msg @@ -744,7 +784,7 @@ port recvDirWithCurrentDirectory : (Int -> msg) -> Sub msg port sendReplGetInputLineWithInitial : { index : Int, prompt : String, left : String, right : String } -> Cmd msg -port recvReplGetInputLineWithInitial : (Maybe String -> msg) -> Sub msg +port recvReplGetInputLineWithInitial : ({ index : Int, value : Maybe String } -> msg) -> Sub msg diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index 0baebe3e2..72b101b77 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -57,8 +57,6 @@ module Utils.Main exposing , fpTakeExtension , fpTakeFileName , httpExceptionContentCodec - , httpExceptionContentDecoder - , httpExceptionContentEncoder , httpHLocation , httpResponseHeaders , httpResponseStatus @@ -75,8 +73,6 @@ module Utils.Main exposing , listTraverse_ , lockWithFileLock , mVarCodec - , mVarDecoder - , mVarEncoder , mapFindMin , mapFromKeys , mapFromListWith @@ -94,7 +90,6 @@ module Utils.Main exposing , mapUnionWith , mapUnions , mapUnionsWith - , maybeEncoder , maybeMapM , maybeTraverseTask , newChan @@ -116,8 +111,6 @@ module Utils.Main exposing , sequenceListMaybe , sequenceNonemptyListResult , someExceptionCodec - , someExceptionDecoder - , someExceptionEncoder , takeMVar , unlines , unzip3 @@ -129,16 +122,11 @@ 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 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 import Prelude import Serialize exposing (Codec) @@ -196,16 +184,6 @@ mapFromListWith toComparable f = Map.empty -maybeEncoder : (a -> Encode.Value) -> Maybe a -> Encode.Value -maybeEncoder encoder maybeValue = - case maybeValue of - Just value -> - encoder value - - Nothing -> - Encode.null - - eitherLefts : List (Result e a) -> List e eitherLefts = List.filterMap @@ -1130,16 +1108,6 @@ replGetInputLineWithInitial prompt ( left, right ) = -- ENCODERS and DECODERS -mVarEncoder : MVar a -> Encode.Value -mVarEncoder (MVar ref) = - Encode.int ref - - -mVarDecoder : Decode.Decoder (MVar a) -mVarDecoder = - Decode.map MVar Decode.int - - mVarCodec : Codec e (MVar a) mVarCodec = Serialize.int |> Serialize.map MVar (\(MVar ref) -> ref) @@ -1155,16 +1123,6 @@ chItemCodec codec = |> Serialize.finishCustomType -someExceptionEncoder : SomeException -> Encode.Value -someExceptionEncoder _ = - Encode.object [ ( "type", Encode.string "SomeException" ) ] - - -someExceptionDecoder : Decode.Decoder SomeException -someExceptionDecoder = - Decode.succeed SomeException - - someExceptionCodec : Codec e SomeException someExceptionCodec = Serialize.customType @@ -1175,99 +1133,6 @@ someExceptionCodec = |> Serialize.finishCustomType -httpResponseEncoder : HttpResponse body -> Encode.Value -httpResponseEncoder (HttpResponse httpResponse) = - Encode.object - [ ( "type", Encode.string "HttpResponse" ) - , ( "responseStatus", httpStatusEncoder httpResponse.responseStatus ) - , ( "responseHeaders", httpResponseHeadersEncoder httpResponse.responseHeaders ) - ] - - -httpResponseDecoder : Decode.Decoder (HttpResponse body) -httpResponseDecoder = - Decode.map2 - (\responseStatus responseHeaders -> - HttpResponse - { responseStatus = responseStatus - , responseHeaders = responseHeaders - } - ) - (Decode.field "responseStatus" httpStatusDecoder) - (Decode.field "responseHeaders" httpResponseHeadersDecoder) - - -httpStatusEncoder : HttpStatus -> Encode.Value -httpStatusEncoder (HttpStatus statusCode statusMessage) = - Encode.object - [ ( "type", Encode.string "HttpStatus" ) - , ( "statusCode", Encode.int statusCode ) - , ( "statusMessage", Encode.string statusMessage ) - ] - - -httpStatusDecoder : Decode.Decoder HttpStatus -httpStatusDecoder = - Decode.map2 HttpStatus - (Decode.field "statusCode" Decode.int) - (Decode.field "statusMessage" Decode.string) - - -httpResponseHeadersEncoder : HttpResponseHeaders -> Encode.Value -httpResponseHeadersEncoder = - Encode.list (E.jsonPair Encode.string Encode.string) - - -httpResponseHeadersDecoder : Decode.Decoder HttpResponseHeaders -httpResponseHeadersDecoder = - Decode.list (D.jsonPair Decode.string Decode.string) - - -httpExceptionContentEncoder : HttpExceptionContent -> Encode.Value -httpExceptionContentEncoder httpExceptionContent = - case httpExceptionContent of - StatusCodeException response body -> - Encode.object - [ ( "type", Encode.string "StatusCodeException" ) - , ( "response", httpResponseEncoder response ) - , ( "body", Encode.string body ) - ] - - TooManyRedirects responses -> - Encode.object - [ ( "type", Encode.string "TooManyRedirects" ) - , ( "responses", Encode.list httpResponseEncoder responses ) - ] - - ConnectionFailure someException -> - Encode.object - [ ( "type", Encode.string "ConnectionFailure" ) - , ( "someException", someExceptionEncoder someException ) - ] - - -httpExceptionContentDecoder : Decode.Decoder HttpExceptionContent -httpExceptionContentDecoder = - Decode.field "type" Decode.string - |> Decode.andThen - (\type_ -> - case type_ of - "StatusCodeException" -> - Decode.map2 StatusCodeException - (Decode.field "response" httpResponseDecoder) - (Decode.field "body" Decode.string) - - "TooManyRedirects" -> - Decode.map TooManyRedirects (Decode.field "responses" (Decode.list httpResponseDecoder)) - - "ConnectionFailure" -> - Decode.map ConnectionFailure (Decode.field "someException" someExceptionDecoder) - - _ -> - Decode.fail ("Failed to decode HttpExceptionContent's type: " ++ type_) - ) - - httpExceptionContentCodec : Codec e HttpExceptionContent httpExceptionContentCodec = Serialize.customType