on 2469006 help sign in
212 files changed+10149−23139
since splitsnapshots
unifiedsplit
.github/CONTRIBUTING.md+20−18 .github/PULL_REQUEST_TEMPLATE.md−18 .github/workflows/set-issue-expectations.yml−21 .github/workflows/set-pull-expectations.yml−19 .gitignore−1 .travis.yml−28 ContributorAgreement.pdf LICENSE+25−6 README.md+5−10 builder/src/BackgroundWriter.hs−42 builder/src/Build.hs−1251 builder/src/Deps/Bump.hs−37 builder/src/Deps/Diff.hs+8−10 builder/src/Deps/Plan.hs+64 builder/src/Deps/Registry.hs+73−40 builder/src/Deps/Solver.hs+149−258 builder/src/Elm/Bump.hs+137 builder/src/Elm/Details.hs+223−479 builder/src/Elm/Diff.hs+284 builder/src/Elm/Install.hs+448 builder/src/Elm/Outline.hs+147−157 builder/src/Elm/Publish.hs+255 builder/src/File.hs+5−28 builder/src/Generate.hs−211 builder/src/Http.hs+1−14 builder/src/Reporting.hs+27−122 builder/src/Reporting/Exit.hs+64−2015 builder/src/Reporting/Exit/Assets.hs+227 builder/src/Reporting/Exit/Bump.hs+51 builder/src/Reporting/Exit/Compile.hs+104 builder/src/Reporting/Exit/Crawl.hs+345 builder/src/Reporting/Exit/Deps.hs+123 builder/src/Reporting/Exit/Diff.hs+73 builder/src/Reporting/Exit/Help.hs+12−11 builder/src/Reporting/Exit/Http.hs+104 builder/src/Reporting/Exit/Init.hs+48 builder/src/Reporting/Exit/Install.hs+82 builder/src/Reporting/Exit/Make.hs+75 builder/src/Reporting/Exit/Publish.hs+241 builder/src/Reporting/Task.hs−17 builder/src/Stuff.hs+9−9 cabal.config−2 compiler/src/AST/Canonical.hs+9−12 compiler/src/AST/Optimized.hs+40−101 compiler/src/AST/Source.hs+19−36 compiler/src/AST/Utils/Binop.hs+6−5 compiler/src/AST/Utils/Shader.hs+4−51 compiler/src/AST/Utils/Type.hs+1 compiler/src/Canonicalize/Environment.hs+20−50 compiler/src/Canonicalize/Environment/Dups.hs+3−6 compiler/src/Canonicalize/Environment/Foreign.hs+37−49 compiler/src/Canonicalize/Environment/Local.hs+8−8 compiler/src/Canonicalize/Expression.hs+7−6 compiler/src/Canonicalize/Module.hs+19−31 compiler/src/Canonicalize/Pattern.hs+2−3 compiler/src/Compile.hs+19−27 compiler/src/Data/Map/Utils.hs−43 compiler/src/Data/Name.hs+177−166 compiler/src/Data/NonEmptyList.hs−78 compiler/src/Data/OneOrMore.hs+24−39 compiler/src/Data/Utf8.hs+300−158 compiler/src/Elm/Compiler.hs+99 compiler/src/Elm/Compiler/Imports.hs+13−4 compiler/src/Elm/Compiler/Type.hs+35−33 compiler/src/Elm/Compiler/Type/Extract.hs+20−69 compiler/src/Elm/Constraint.hs+77−55 compiler/src/Elm/Docs.hs+158−218 compiler/src/Elm/Float.hs−51 compiler/src/Elm/Interface.hs+14−17 compiler/src/Elm/Kernel.hs+127−132 compiler/src/Elm/Licenses.hs+65−48 compiler/src/Elm/ModuleName.hs+46−72 compiler/src/Elm/Package.hs+89−220 compiler/src/Elm/String.hs−133 compiler/src/Elm/Version.hs+50−79 compiler/src/Generate/Html.hs+4−17 compiler/src/Generate/JavaScript.hs+87−97 compiler/src/Generate/JavaScript/Builder.hs+217−207 compiler/src/Generate/JavaScript/Expression.hs+45−46 compiler/src/Generate/JavaScript/Functions.hs+3−2 compiler/src/Generate/JavaScript/Name.hs+12−22 compiler/src/Generate/Mode.hs+3−2 compiler/src/Json/Decode.hs+180−333 compiler/src/Json/Encode.hs+21−37 compiler/src/Json/String.hs−192 compiler/src/Nitpick/Debug.hs+18−6 compiler/src/Nitpick/PatternMatches.hs+9−10 compiler/src/Optimize/DecisionTree.hs+5−5 compiler/src/Optimize/Module.hs+38−35 compiler/src/Optimize/Names.hs+7−1 compiler/src/Optimize/Port.hs+3−3 compiler/src/Parse/Declaration.hs+131−180 compiler/src/Parse/Docs.hs+275 compiler/src/Parse/Expression.hs+341−330 compiler/src/Parse/Keyword.hs+84−83 compiler/src/Parse/Module.hs+259−330 compiler/src/Parse/Number.hs+34−37 compiler/src/Parse/Pattern.hs+130−138 compiler/src/Parse/Primitives.hs+123−199 compiler/src/Parse/Repl.hs+117 compiler/src/Parse/Shader.hs+24−25 compiler/src/Parse/Space.hs−273 compiler/src/Parse/Symbol.hs+37−22 compiler/src/Parse/Type.hs+103−101 compiler/src/Parse/String.hs → compiler/src/Parse/Utf8.hs+94−104 compiler/src/Parse/Utils.hs+259 compiler/src/Parse/Variable.hs+49−54 compiler/src/Reporting/Annotation.hs+1−1 compiler/src/Reporting/Doc.hs+54−96 compiler/src/Reporting/Error.hs+22−175 compiler/src/Reporting/Error/Canonicalize.hs+127−115 compiler/src/Reporting/Error/Docs.hs+23−132 compiler/src/Reporting/Error/Import.hs−162 compiler/src/Reporting/Error/Json.hs+270−280 compiler/src/Reporting/Error/Main.hs+6−6 compiler/src/Reporting/Error/Pattern.hs+8−9 compiler/src/Reporting/Error/Syntax.hs+626−5687 compiler/src/Reporting/Error/Type.hs+32−53 compiler/src/Reporting/Render/Code.hs+10−154 compiler/src/Reporting/Render/Type/Localizer.hs+27−7 compiler/src/Reporting/Report.hs+63 compiler/src/Reporting/Result.hs+2−12 compiler/src/Reporting/Warning.hs+3−3 compiler/src/Type/Constrain/Module.hs+3−3 compiler/src/Type/Error.hs+123−14 compiler/src/Type/Solve.hs+3−11 compiler/src/Type/Unify.hs+10−12 docs/elm.json/application.md+2−2 docs/elm.json/package.md+1−1 docs/upgrade-instructions/0.19.1.md−60 elm.cabal+98−69 hints/bad-recursion.md−133 hints/comparing-custom-types.md−98 hints/comparing-records.md−85 hints/implicit-casts.md−50 hints/import-cycles.md−184 hints/imports.md−126 hints/infinite-type.md−42 hints/init.md−55 hints/missing-patterns.md−139 hints/optimize.md−59 hints/port-modules.md−32 hints/recursive-alias.md−162 hints/repl.md−73 hints/shadowing.md−70 hints/tuples.md−19 hints/type-annotations.md−60 installers/README.md−32 installers/linux/Dockerfile−39 installers/linux/README.md−93 installers/mac/Distribution.xml+3−5 installers/mac/README.md−93 installers/mac/Resources/en.lproj/background.png installers/mac/Resources/en.lproj/conclusion.rtf+6−13 installers/mac/Resources/en.lproj/welcome.rtf+4−9 installers/mac/helper-scripts/elm-startup.sh+1−1 installers/mac/make-installer.sh+3−30 installers/npm/PUBLISHING.md+141−29 installers/npm/README.md+23−30 installers/npm/bin/elm+41−47 installers/npm/download.js−114 installers/npm/index.js+21 installers/npm/install.js−4 installers/npm/package.json+15−13 installers/npm/troubleshooting.md−76 installers/win/Nsisfile.nsi+16−16 installers/win/README.md+3−18 installers/win/file.ico installers/win/inst.dat+2−1 installers/win/logo.ico installers/win/uninst.dat+2−1 installers/win/welcome.bmp reactor/assets/waiting.gif reactor/elm.json+2−2 reactor/src/Index.elm+15−20 reactor/src/Index/Navigator.elm+1−1 roadmap.md−29 terminal/impl/Terminal/Helpers.hs−148 terminal/src/Bump.hs+8−158 terminal/src/Develop.hs+77−70 terminal/src/Develop/Generate/Index.hs+74−149 terminal/src/Develop/StaticFiles.hs+7−1 terminal/src/Develop/StaticFiles/Build.hs+29−46 terminal/src/Diff.hs+6−348 terminal/src/Init.hs+36−40 terminal/src/Install.hs+14−401 terminal/src/Main.hs+36−32 terminal/src/Make.hs+32−257 terminal/src/Publish.hs+8−529 terminal/src/Repl.hs+197−522 terminal/impl/Terminal.hs → terminal/src/Terminal/Args.hs+27−33 terminal/impl/Terminal/Chomp.hs → terminal/src/Terminal/Args/Chomp.hs+5−4 terminal/impl/Terminal/Error.hs → terminal/src/Terminal/Args/Error.hs+18−28 terminal/src/Terminal/Args/Helpers.hs+125 terminal/impl/Terminal/Internal.hs → terminal/src/Terminal/Args/Internal.hs+8−8 docs/upgrade-instructions/0.16.md → upgrade-docs/0.16.md docs/upgrade-instructions/0.17.md → upgrade-docs/0.17.md docs/upgrade-instructions/0.18.md → upgrade-docs/0.18.md docs/upgrade-instructions/0.19.0.md → upgrade-docs/0.19.md docs/upgrade-instructions/earlier.md → upgrade-docs/earlier.md worker/elm.cabal−210 worker/elm.json−26 worker/nginx.conf−22 worker/outlines/compile/elm.json−32 worker/outlines/repl/elm.json−19 worker/src/Artifacts.hs−155 worker/src/Cors.hs−48 worker/src/Endpoint/Compile.hs−323 worker/src/Endpoint/Quotes.hs−114 worker/src/Endpoint/Repl.hs−244 worker/src/Errors.elm−217 worker/src/Main.hs−73
.github/CONTRIBUTING.md+20−18
@@ -4,15 +4,10 @@ Thanks helping with the development of Elm! This document describes the basic
44standards for opening pull requests and making the review process as smooth as
55possible.
66
7+## Licensing
78
8−## Expectations
9−
10−- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
11−- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).
12−- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.
13−
14−Finally, please be patient with the core team. They are trying their best with limited resources!
15−
9+You need to sign the [contributor agreement](ContributorAgreement.pdf)
10+and send it to <info@elm-lang.org> before opening your pull request.
1611
1712## Style Guide
1813
@@ -22,20 +17,27 @@ Finally, please be patient with the core team. They are trying their best with l
2217[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be
2318[js]: https://google.github.io/styleguide/javascriptguide.xml
2419
25−
2620## Branches
2721
28−[The master branch][master] is the home of the next release of the compiler
29−so new features and improvements get merged there. Most pull requests
30−should target this branch!
31−
32−[master]: http://github.com/elm-lang/elm/tree/master
22+ * [The master branch][master] is the home of the next release of the compiler
23+ so new features and improvements get merged there. Most pull requests
24+ should target this branch!
3325
26+ * [The stable branch][stable] is for tagging releases and critical bug fixes.
27+ This branch is handy for folks who want to build the most recent public
28+ release from source.
3429
35−## Licensing
36−
37−Nothing extra to do for this. The default on GitHub described [here](https://docs.github.com/en/github/site-policy/github-terms-of-service#6-contributions-under-repository-license) is that:
30+[master]: http://github.com/elm-lang/elm/tree/master
31+[stable]: http://github.com/elm-lang/elm/tree/stable
3832
39−> Whenever you add Content to a repository containing notice of a license, you license that Content under the same terms, and you agree that you have the right to license that Content under those terms. If you have a separate agreement to license that Content under different terms, such as a contributor license agreement, that agreement will supersede.
33+If you are working on a fairly large feature, we will probably want to merge it
34+in as its own branch and do some testing before bringing it into the master
35+branch. This way we can keep releases of the master branch independent of new
36+features.
4037
38+Note that the master branch of the compiler should always be in sync with the
39+master branch of the [website][], and the stable branch of the compiler should
40+always be in sync with the stable branch of the [website][]. Make sure that
41+your changes maintain this compatibility.
4142
43+[website]: https://github.com/elm-lang/elm-lang.org
.github/PULL_REQUEST_TEMPLATE.mddeleted−18
@@ -1,18 +0,0 @@
1−
2−**Quick Summary:** ???
3−
4−
5−## SSCCE
6−
7−```elm
8−
9−```
10−
11−- **Elm:** ???
12−- **Browser:** ???
13−- **Operating System:** ???
14−
15−
16−## Additional Details
17−
18−???
.github/workflows/set-issue-expectations.ymldeleted−21
@@ -1,21 +0,0 @@
1−name: Set Issue Expectations
2−on:
3− issues:
4− types: [opened]
5−jobs:
6− comment-on-issue:
7− name: Comment On Issue
8− runs-on: ubuntu-latest
9− steps:
10− - uses: actions/github@v1.0.0
11− env:
12− GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
13− with:
14− args: |
15− comment "Thanks for reporting this! To set expectations:
16−
17− - Issues are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
18− - Ask questions in a [community forum](https://elm-lang.org/community). You will get an answer quicker that way!
19− - If you experience something similar, open a new issue. [We like duplicates](https://github.com/elm/expectations/blob/master/duplicates.md).
20−
21− Finally, please be patient with the core team. They are trying their best with limited resources."
.github/workflows/set-pull-expectations.ymldeleted−19
@@ -1,19 +0,0 @@
1−on:
2− pull_request_target:
3− types: [opened]
4−
5−jobs:
6− comment-on-pull:
7− name: Comment On Pull
8− runs-on: ubuntu-latest
9− steps:
10− - uses: actions/github-script@v3
11− with:
12− github-token: ${{secrets.GITHUB_TOKEN}}
13− script: |
14− github.issues.createComment({
15− issue_number: context.issue.number,
16− owner: context.repo.owner,
17− repo: context.repo.repo,
18− body: "Thanks for suggesting these code changes. To set expectations:\n\n- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.\n- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).\n- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.\n\nFinally, please be patient with the core team. They are trying their best with limited resources."
19− })
.gitignore−1
@@ -5,4 +5,3 @@ cabal-dev
55cabal.sandbox.config
66.DS_Store
77*~
8−travis.log
.travis.ymldeleted−28
@@ -1,28 +0,0 @@
1−language: minimal
2−services: docker
3−
4−env:
5− global:
6− - LINUX_ARCHIVE=binary-for-linux-64-bit.gz
7−
8−before_install:
9− - docker build -t elm -f installers/linux/Dockerfile .
10− - docker cp $(docker create elm):/usr/local/bin/elm .
11− - gzip -9 -c elm > $LINUX_ARCHIVE
12−
13−deploy:
14− provider: releases
15− api_key:
16− secure: Yz2Lo4u9rZQ7Ee7ohAsrZpkqsYDUerCSMdSQIH8ryrf7phHhiloPEkTKsM+NupHqU/LEAVsunxbau4QrCEjA2vPavAPVk8cKomRUWK/YjbXHKa24hPkal2c+A2bnMQ6w3qYk/PjL9rW+Goq++/SNLcYZwHBV0Chl2blivMwWCSA=
17− file: $LINUX_ARCHIVE
18− skip_cleanup: true
19− on:
20− branch: master
21− tags: true
22−
23−notifications:
24− email:
25− recipients:
26− - rlefevre@dmy.fr
27− on_success: change
28− on_failure: change
ContributorAgreement.pdfnew file

Binary file not shown.

LICENSE+25−6
@@ -1,11 +1,30 @@
1−Copyright 2012-present Evan Czaplicki
1+Copyright (c) 2012-present, Evan Czaplicki
22
3−Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
3+All rights reserved.
44
5−1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
67
7−2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
810
9−3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
1015
11−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
16+ * Neither the name of Evan Czaplicki nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+5−10
@@ -1,22 +1,17 @@
1−# Elm
1+# The Elm Compiler
22
3−A delightful language for reliable webapps.
3+Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
44
5−Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
6−
7−
8−<br>
95
106## Install
117
12−✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
8+Follow [these instructions][installer]!
139
14−For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
10+ [installer]: https://guide.elm-lang.org/install.html
1511
16−<br>
1712
1813## Help
1914
2015If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
2116
22−[slack]: http://elmlang.herokuapp.com/
17+[slack]: http://elmlang.herokuapp.com/
builder/src/BackgroundWriter.hsdeleted−42
@@ -1,42 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module BackgroundWriter
3− ( Scope
4− , withScope
5− , writeBinary
6− )
7− where
8−
9−
10−import Control.Concurrent (forkIO)
11−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
12−import qualified Data.Binary as Binary
13−import Data.Foldable (traverse_)
14−
15−import qualified File
16−
17−
18−
19−-- BACKGROUND WRITER
20−
21−
22−newtype Scope =
23− Scope (MVar [MVar ()])
24−
25−
26−withScope :: (Scope -> IO a) -> IO a
27−withScope callback =
28− do workList <- newMVar []
29− result <- callback (Scope workList)
30− mvars <- takeMVar workList
31− traverse_ takeMVar mvars
32− return result
33−
34−
35−writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
36−writeBinary (Scope workList) path value =
37− do mvar <- newEmptyMVar
38− _ <- forkIO (File.writeBinary path value >> putMVar mvar ())
39− oldWork <- takeMVar workList
40− let !newWork = mvar:oldWork
41− putMVar workList newWork
42−
builder/src/Build.hsdeleted−1251
@@ -1,1251 +0,0 @@
1−{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3−module Build
4− ( fromExposed
5− , fromPaths
6− , fromRepl
7− , Artifacts(..)
8− , Root(..)
9− , Module(..)
10− , CachedInterface(..)
11− , ReplArtifacts(..)
12− , DocsGoal(..)
13− , getRootNames
14− )
15− where
16−
17−
18−import Control.Concurrent (forkIO)
19−import Control.Concurrent.MVar
20−import Control.Monad (filterM, mapM_, sequence_)
21−import qualified Data.ByteString as B
22−import qualified Data.Char as Char
23−import qualified Data.Graph as Graph
24−import qualified Data.List as List
25−import qualified Data.Map.Utils as Map
26−import qualified Data.Map.Strict as Map
27−import Data.Map.Strict ((!))
28−import qualified Data.Maybe as Maybe
29−import qualified Data.Name as Name
30−import qualified Data.NonEmptyList as NE
31−import qualified Data.OneOrMore as OneOrMore
32−import qualified Data.Set as Set
33−import qualified System.Directory as Dir
34−import qualified System.FilePath as FP
35−import System.FilePath ((</>), (<.>))
36−
37−import qualified AST.Canonical as Can
38−import qualified AST.Source as Src
39−import qualified AST.Optimized as Opt
40−import qualified Compile
41−import qualified Elm.Details as Details
42−import qualified Elm.Docs as Docs
43−import qualified Elm.Interface as I
44−import qualified Elm.ModuleName as ModuleName
45−import qualified Elm.Outline as Outline
46−import qualified Elm.Package as Pkg
47−import qualified File
48−import qualified Json.Encode as E
49−import qualified Parse.Module as Parse
50−import qualified Reporting
51−import qualified Reporting.Annotation as A
52−import qualified Reporting.Error as Error
53−import qualified Reporting.Error.Docs as EDocs
54−import qualified Reporting.Error.Syntax as Syntax
55−import qualified Reporting.Error.Import as Import
56−import qualified Reporting.Exit as Exit
57−import qualified Reporting.Render.Type.Localizer as L
58−import qualified Stuff
59−
60−
61−
62−-- ENVIRONMENT
63−
64−
65−data Env =
66− Env
67− { _key :: Reporting.BKey
68− , _root :: FilePath
69− , _project :: Parse.ProjectType
70− , _srcDirs :: [AbsoluteSrcDir]
71− , _buildID :: Details.BuildID
72− , _locals :: Map.Map ModuleName.Raw Details.Local
73− , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
74− }
75−
76−
77−makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
78−makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
79− case validOutline of
80− Details.ValidApp givenSrcDirs ->
81− do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82− return $ Env key root Parse.Application srcDirs buildID locals foreigns
83−
84− Details.ValidPkg pkg _ _ ->
85− do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
86− return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
87−
88−
89−
90−-- SOURCE DIRECTORY
91−
92−
93−newtype AbsoluteSrcDir =
94− AbsoluteSrcDir FilePath
95−
96−
97−toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
98−toAbsoluteSrcDir root srcDir =
99− AbsoluteSrcDir <$> Dir.canonicalizePath
100− (
101− case srcDir of
102− Outline.AbsoluteSrcDir dir -> dir
103− Outline.RelativeSrcDir dir -> root </> dir
104− )
105−
106−
107−addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
108−addRelative (AbsoluteSrcDir srcDir) path =
109− srcDir </> path
110−
111−
112−
113−-- FORK
114−
115−
116−-- PERF try using IORef semephore on file crawl phase?
117−-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
118−-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
119−--
120−fork :: IO a -> IO (MVar a)
121−fork work =
122− do mvar <- newEmptyMVar
123− _ <- forkIO $ putMVar mvar =<< work
124− return mvar
125−
126−
127−{-# INLINE forkWithKey #-}
128−forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
129−forkWithKey func dict =
130− Map.traverseWithKey (\k v -> fork (func k v)) dict
131−
132−
133−
134−-- FROM EXPOSED
135−
136−
137−fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
138−fromExposed style root details docsGoal exposed@(NE.List e es) =
139− Reporting.trackBuild style $ \key ->
140− do env <- makeEnv key root details
141− dmvar <- Details.loadInterfaces root details
142−
143− -- crawl
144− mvar <- newEmptyMVar
145− let docsNeed = toDocsNeed docsGoal
146− roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
147− putMVar mvar roots
148− mapM_ readMVar roots
149− statuses <- traverse readMVar =<< readMVar mvar
150−
151− -- compile
152− midpoint <- checkMidpoint dmvar statuses
153− case midpoint of
154− Left problem ->
155− return (Left (Exit.BuildProjectProblem problem))
156−
157− Right foreigns ->
158− do rmvar <- newEmptyMVar
159− resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
160− putMVar rmvar resultMVars
161− results <- traverse readMVar resultMVars
162− writeDetails root details results
163− finalizeExposed root docsGoal exposed results
164−
165−
166−
167−-- FROM PATHS
168−
169−
170−data Artifacts =
171− Artifacts
172− { _name :: Pkg.Name
173− , _deps :: Dependencies
174− , _roots :: NE.List Root
175− , _modules :: [Module]
176− }
177−
178−
179−data Module
180− = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
181− | Cached ModuleName.Raw Bool (MVar CachedInterface)
182−
183−
184−type Dependencies =
185− Map.Map ModuleName.Canonical I.DependencyInterface
186−
187−
188−fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
189−fromPaths style root details paths =
190− Reporting.trackBuild style $ \key ->
191− do env <- makeEnv key root details
192−
193− elroots <- findRoots env paths
194− case elroots of
195− Left problem ->
196− return (Left (Exit.BuildProjectProblem problem))
197−
198− Right lroots ->
199− do -- crawl
200− dmvar <- Details.loadInterfaces root details
201− smvar <- newMVar Map.empty
202− srootMVars <- traverse (fork . crawlRoot env smvar) lroots
203− sroots <- traverse readMVar srootMVars
204− statuses <- traverse readMVar =<< readMVar smvar
205−
206− midpoint <- checkMidpointAndRoots dmvar statuses sroots
207− case midpoint of
208− Left problem ->
209− return (Left (Exit.BuildProjectProblem problem))
210−
211− Right foreigns ->
212− do -- compile
213− rmvar <- newEmptyMVar
214− resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
215− putMVar rmvar resultsMVars
216− rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
217− results <- traverse readMVar resultsMVars
218− writeDetails root details results
219− toArtifacts env foreigns results <$> traverse readMVar rrootMVars
220−
221−
222−
223−-- GET ROOT NAMES
224−
225−
226−getRootNames :: Artifacts -> NE.List ModuleName.Raw
227−getRootNames (Artifacts _ _ roots _) =
228− fmap getRootName roots
229−
230−
231−getRootName :: Root -> ModuleName.Raw
232−getRootName root =
233− case root of
234− Inside name -> name
235− Outside name _ _ -> name
236−
237−
238−
239−-- CRAWL
240−
241−
242−type StatusDict =
243− Map.Map ModuleName.Raw (MVar Status)
244−
245−
246−data Status
247− = SCached Details.Local
248− | SChanged Details.Local B.ByteString Src.Module DocsNeed
249− | SBadImport Import.Problem
250− | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
251− | SForeign Pkg.Name
252− | SKernel
253−
254−
255−crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
256−crawlDeps env mvar deps blockedValue =
257− do statusDict <- takeMVar mvar
258− let depsDict = Map.fromKeys (\_ -> ()) deps
259− let newsDict = Map.difference depsDict statusDict
260− statuses <- Map.traverseWithKey crawlNew newsDict
261− putMVar mvar (Map.union statuses statusDict)
262− mapM_ readMVar statuses
263− return blockedValue
264− where
265− crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
266−
267−
268−crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
269−crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
270− do let fileName = ModuleName.toFilePath name <.> "elm"
271−
272− paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
273−
274− case paths of
275− [path] ->
276− case Map.lookup name foreigns of
277− Just (Details.Foreign dep deps) ->
278− return $ SBadImport $ Import.Ambiguous path [] dep deps
279−
280− Nothing ->
281− do newTime <- File.getTime path
282− case Map.lookup name locals of
283− Nothing ->
284− crawlFile env mvar docsNeed name path newTime buildID
285−
286− Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
287− if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
288− then crawlFile env mvar docsNeed name path newTime lastChange
289− else crawlDeps env mvar deps (SCached local)
290−
291− p1:p2:ps ->
292− return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
293−
294− [] ->
295− case Map.lookup name foreigns of
296− Just (Details.Foreign dep deps) ->
297− case deps of
298− [] ->
299− return $ SForeign dep
300−
301− d:ds ->
302− return $ SBadImport $ Import.AmbiguousForeign dep d ds
303−
304− Nothing ->
305− if Name.isKernel name && Parse.isKernel projectType then
306− do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
307− return $ if exists then SKernel else SBadImport Import.NotFound
308− else
309− return $ SBadImport Import.NotFound
310−
311−
312−crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
313−crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
314− do source <- File.readUtf8 (root </> path)
315−
316− case Parse.fromByteString projectType source of
317− Left err ->
318− return $ SBadSyntax path time source err
319−
320− Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
321− case maybeActualName of
322− Nothing ->
323− return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
324−
325− Just name@(A.At _ actualName) ->
326− if expectedName == actualName then
327− let
328− deps = map Src.getImportName imports
329− local = Details.Local path time deps (any isMain values) lastChange buildID
330− in
331− crawlDeps env mvar deps (SChanged local source modul docsNeed)
332− else
333− return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
334−
335−
336−isMain :: A.Located Src.Value -> Bool
337−isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
338− name == Name._main
339−
340−
341−
342−-- CHECK MODULE
343−
344−
345−type ResultDict =
346− Map.Map ModuleName.Raw (MVar Result)
347−
348−
349−data Result
350− = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
351− | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
352− | RCached Bool Details.BuildID (MVar CachedInterface)
353− | RNotFound Import.Problem
354− | RProblem Error.Module
355− | RBlocked
356− | RForeign I.Interface
357− | RKernel
358−
359−
360−data CachedInterface
361− = Unneeded
362− | Loaded I.Interface
363− | Corrupted
364−
365−
366−checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
367−checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
368− case status of
369− SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
370− do results <- readMVar resultsMVar
371− depsStatus <- checkDeps root results deps lastCompile
372− case depsStatus of
373− DepsChange ifaces ->
374− do source <- File.readUtf8 path
375− case Parse.fromByteString projectType source of
376− Right modul -> compile env (DocsNeed False) local source ifaces modul
377− Left err ->
378− return $ RProblem $
379− Error.Module name path time source (Error.BadSyntax err)
380−
381− DepsSame _ _ ->
382− do mvar <- newMVar Unneeded
383− return (RCached hasMain lastChange mvar)
384−
385− DepsBlock ->
386− return RBlocked
387−
388− DepsNotFound problems ->
389− do source <- File.readUtf8 path
390− return $ RProblem $ Error.Module name path time source $
391− case Parse.fromByteString projectType source of
392− Right (Src.Module _ _ _ imports _ _ _ _ _) ->
393− Error.BadImports (toImportErrors env results imports problems)
394−
395− Left err ->
396− Error.BadSyntax err
397−
398− SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
399− do results <- readMVar resultsMVar
400− depsStatus <- checkDeps root results deps lastCompile
401− case depsStatus of
402− DepsChange ifaces ->
403− compile env docsNeed local source ifaces modul
404−
405− DepsSame same cached ->
406− do maybeLoaded <- loadInterfaces root same cached
407− case maybeLoaded of
408− Nothing -> return RBlocked
409− Just ifaces -> compile env docsNeed local source ifaces modul
410−
411− DepsBlock ->
412− return RBlocked
413−
414− DepsNotFound problems ->
415− return $ RProblem $ Error.Module name path time source $
416− Error.BadImports (toImportErrors env results imports problems)
417−
418− SBadImport importProblem ->
419− return (RNotFound importProblem)
420−
421− SBadSyntax path time source err ->
422− return $ RProblem $ Error.Module name path time source $
423− Error.BadSyntax err
424−
425− SForeign home ->
426− case foreigns ! ModuleName.Canonical home name of
427− I.Public iface -> return (RForeign iface)
428− I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
429−
430− SKernel ->
431− return RKernel
432−
433−
434−
435−-- CHECK DEPS
436−
437−
438−data DepsStatus
439− = DepsChange (Map.Map ModuleName.Raw I.Interface)
440− | DepsSame [Dep] [CDep]
441− | DepsBlock
442− | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
443−
444−
445−checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
446−checkDeps root results deps lastCompile =
447− checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
448−
449−
450−type Dep = (ModuleName.Raw, I.Interface)
451−type CDep = (ModuleName.Raw, MVar CachedInterface)
452−
453−
454−checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
455−checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
456− case deps of
457− dep:otherDeps ->
458− do result <- readMVar (results ! dep)
459− case result of
460− RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
461− checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
462−
463− RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
464− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
465−
466− RCached _ lastChange mvar ->
467− checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
468−
469− RNotFound prob ->
470− checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
471−
472− RProblem _ ->
473− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
474−
475− RBlocked ->
476− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
477−
478− RForeign iface ->
479− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
480−
481− RKernel ->
482− checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
483−
484−
485− [] ->
486− case reverse importProblems of
487− p:ps ->
488− return $ DepsNotFound (NE.List p ps)
489−
490− [] ->
491− if isBlocked then
492− return $ DepsBlock
493−
494− else if null new && lastDepChange <= lastCompile then
495− return $ DepsSame same cached
496−
497− else
498− do maybeLoaded <- loadInterfaces root same cached
499− case maybeLoaded of
500− Nothing -> return DepsBlock
501− Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
502−
503−
504−
505−-- TO IMPORT ERROR
506−
507−
508−toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
509−toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
510− let
511− knownModules =
512− Set.unions
513− [ Map.keysSet foreigns
514− , Map.keysSet locals
515− , Map.keysSet results
516− ]
517−
518− unimportedModules =
519− Set.difference knownModules (Set.fromList (map Src.getImportName imports))
520−
521− regionDict =
522− Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
523−
524− toError (name, problem) =
525− Import.Error (regionDict ! name) name unimportedModules problem
526− in
527− fmap toError problems
528−
529−
530−
531−-- LOAD CACHED INTERFACES
532−
533−
534−loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
535−loadInterfaces root same cached =
536− do loading <- traverse (fork . loadInterface root) cached
537− maybeLoaded <- traverse readMVar loading
538− case sequence maybeLoaded of
539− Nothing ->
540− return Nothing
541−
542− Just loaded ->
543− return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
544−
545−
546−loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
547−loadInterface root (name, ciMvar) =
548− do cachedInterface <- takeMVar ciMvar
549− case cachedInterface of
550− Corrupted ->
551− do putMVar ciMvar cachedInterface
552− return Nothing
553−
554− Loaded iface ->
555− do putMVar ciMvar cachedInterface
556− return (Just (name, iface))
557−
558− Unneeded ->
559− do maybeIface <- File.readBinary (Stuff.elmi root name)
560− case maybeIface of
561− Nothing ->
562− do putMVar ciMvar Corrupted
563− return Nothing
564−
565− Just iface ->
566− do putMVar ciMvar (Loaded iface)
567− return (Just (name, iface))
568−
569−
570−
571−-- CHECK PROJECT
572−
573−
574−checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575−checkMidpoint dmvar statuses =
576− case checkForCycles statuses of
577− Nothing ->
578− do maybeForeigns <- readMVar dmvar
579− case maybeForeigns of
580− Nothing -> return (Left Exit.BP_CannotLoadDependencies)
581− Just fs -> return (Right fs)
582−
583− Just (NE.List name names) ->
584− do _ <- readMVar dmvar
585− return (Left (Exit.BP_Cycle name names))
586−
587−
588−checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
589−checkMidpointAndRoots dmvar statuses sroots =
590− case checkForCycles statuses of
591− Nothing ->
592− case checkUniqueRoots statuses sroots of
593− Nothing ->
594− do maybeForeigns <- readMVar dmvar
595− case maybeForeigns of
596− Nothing -> return (Left Exit.BP_CannotLoadDependencies)
597− Just fs -> return (Right fs)
598−
599− Just problem ->
600− do _ <- readMVar dmvar
601− return (Left problem)
602−
603− Just (NE.List name names) ->
604− do _ <- readMVar dmvar
605− return (Left (Exit.BP_Cycle name names))
606−
607−
608−
609−-- CHECK FOR CYCLES
610−
611−
612−checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
613−checkForCycles modules =
614− let
615− !graph = Map.foldrWithKey addToGraph [] modules
616− !sccs = Graph.stronglyConnComp graph
617− in
618− checkForCyclesHelp sccs
619−
620−
621−checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
622−checkForCyclesHelp sccs =
623− case sccs of
624− [] ->
625− Nothing
626−
627− scc:otherSccs ->
628− case scc of
629− Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
630− Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
631− Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
632−
633−
634−type Node =
635− ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
636−
637−
638−addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
639−addToGraph name status graph =
640− let
641− dependencies =
642− case status of
643− SCached (Details.Local _ _ deps _ _ _) -> deps
644− SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
645− SBadImport _ -> []
646− SBadSyntax _ _ _ _ -> []
647− SForeign _ -> []
648− SKernel -> []
649− in
650− (name, name, dependencies) : graph
651−
652−
653−
654−-- CHECK UNIQUE ROOTS
655−
656−
657−checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
658−checkUniqueRoots insides sroots =
659− let
660− outsidesDict =
661− Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
662− in
663− case Map.traverseWithKey checkOutside outsidesDict of
664− Left problem ->
665− Just problem
666−
667− Right outsides ->
668− case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
669− Right () -> Nothing
670− Left problem -> Just problem
671−
672−
673−rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
674−rootStatusToNamePathPair sroot =
675− case sroot of
676− SInside _ -> Nothing
677− SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
678− SOutsideErr _ -> Nothing
679−
680−
681−checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
682−checkOutside name paths =
683− case OneOrMore.destruct NE.List paths of
684− NE.List p [] -> Right p
685− NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
686−
687−
688−checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
689−checkInside name p1 status =
690− case status of
691− SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
692− SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
693− SBadImport _ -> Right ()
694− SBadSyntax _ _ _ _ -> Right ()
695− SForeign _ -> Right ()
696− SKernel -> Right ()
697−
698−
699−
700−-- COMPILE MODULE
701−
702−
703−compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
704−compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
705− let
706− pkg = projectTypeToPkg projectType
707− in
708− case Compile.compile pkg ifaces modul of
709− Right (Compile.Artifacts canonical annotations objects) ->
710− case makeDocs docsNeed canonical of
711− Left err ->
712− return $ RProblem $
713− Error.Module (Src.getName modul) path time source (Error.BadDocs err)
714−
715− Right docs ->
716− do let name = Src.getName modul
717− let iface = I.fromModule pkg canonical annotations
718− let elmi = Stuff.elmi root name
719− File.writeBinary (Stuff.elmo root name) objects
720− maybeOldi <- File.readBinary elmi
721− case maybeOldi of
722− Just oldi | oldi == iface ->
723− do -- iface should be fully forced by equality check
724− Reporting.report key Reporting.BDone
725− let local = Details.Local path time deps main lastChange buildID
726− return (RSame local iface objects docs)
727−
728− _ ->
729− do -- iface may be lazy still
730− File.writeBinary elmi iface
731− Reporting.report key Reporting.BDone
732− let local = Details.Local path time deps main buildID buildID
733− return (RNew local iface objects docs)
734−
735− Left err ->
736− return $ RProblem $
737− Error.Module (Src.getName modul) path time source err
738−
739−
740−projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
741−projectTypeToPkg projectType =
742− case projectType of
743− Parse.Package pkg -> pkg
744− Parse.Application -> Pkg.dummyName
745−
746−
747−
748−-- WRITE DETAILS
749−
750−
751−writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
752−writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
753− File.writeBinary (Stuff.details root) $
754− Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
755−
756−
757−addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
758−addNewLocal name result locals =
759− case result of
760− RNew local _ _ _ -> Map.insert name local locals
761− RSame local _ _ _ -> Map.insert name local locals
762− RCached _ _ _ -> locals
763− RNotFound _ -> locals
764− RProblem _ -> locals
765− RBlocked -> locals
766− RForeign _ -> locals
767− RKernel -> locals
768−
769−
770−
771−-- FINALIZE EXPOSED
772−
773−
774−finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
775−finalizeExposed root docsGoal exposed results =
776− case foldr (addImportProblems results) [] (NE.toList exposed) of
777− p:ps ->
778− return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
779−
780− [] ->
781− case Map.foldr addErrors [] results of
782− [] -> Right <$> finalizeDocs docsGoal results
783− e:es -> return $ Left $ Exit.BuildBadModules root e es
784−
785−
786−addErrors :: Result -> [Error.Module] -> [Error.Module]
787−addErrors result errors =
788− case result of
789− RNew _ _ _ _ -> errors
790− RSame _ _ _ _ -> errors
791− RCached _ _ _ -> errors
792− RNotFound _ -> errors
793− RProblem e -> e:errors
794− RBlocked -> errors
795− RForeign _ -> errors
796− RKernel -> errors
797−
798−
799−addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
800−addImportProblems results name problems =
801− case results ! name of
802− RNew _ _ _ _ -> problems
803− RSame _ _ _ _ -> problems
804− RCached _ _ _ -> problems
805− RNotFound p -> (name, p) : problems
806− RProblem _ -> problems
807− RBlocked -> problems
808− RForeign _ -> problems
809− RKernel -> problems
810−
811−
812−
813−-- DOCS
814−
815−
816−data DocsGoal a where
817− KeepDocs :: DocsGoal Docs.Documentation
818− WriteDocs :: FilePath -> DocsGoal ()
819− IgnoreDocs :: DocsGoal ()
820−
821−
822−newtype DocsNeed =
823− DocsNeed { needsDocs :: Bool }
824−
825−
826−toDocsNeed :: DocsGoal a -> DocsNeed
827−toDocsNeed goal =
828− case goal of
829− IgnoreDocs -> DocsNeed False
830− WriteDocs _ -> DocsNeed True
831− KeepDocs -> DocsNeed True
832−
833−
834−makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
835−makeDocs (DocsNeed isNeeded) modul =
836− if isNeeded then
837− case Docs.fromModule modul of
838− Right docs -> Right (Just docs)
839− Left err -> Left err
840− else
841− Right Nothing
842−
843−
844−finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
845−finalizeDocs goal results =
846− case goal of
847− KeepDocs ->
848− return $ Map.mapMaybe toDocs results
849−
850− WriteDocs path ->
851− E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
852−
853− IgnoreDocs ->
854− return ()
855−
856−
857−toDocs :: Result -> Maybe Docs.Module
858−toDocs result =
859− case result of
860− RNew _ _ _ d -> d
861− RSame _ _ _ d -> d
862− RCached _ _ _ -> Nothing
863− RNotFound _ -> Nothing
864− RProblem _ -> Nothing
865− RBlocked -> Nothing
866− RForeign _ -> Nothing
867− RKernel -> Nothing
868−
869−
870−
871−--------------------------------------------------------------------------------
872−------ NOW FOR SOME REPL STUFF -------------------------------------------------
873−--------------------------------------------------------------------------------
874−
875−
876−-- FROM REPL
877−
878−
879−data ReplArtifacts =
880− ReplArtifacts
881− { _repl_home :: ModuleName.Canonical
882− , _repl_modules :: [Module]
883− , _repl_localizer :: L.Localizer
884− , _repl_annotations :: Map.Map Name.Name Can.Annotation
885− }
886−
887−
888−fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
889−fromRepl root details source =
890− do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
891− case Parse.fromByteString projectType source of
892− Left syntaxError ->
893− return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
894−
895− Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
896− do dmvar <- Details.loadInterfaces root details
897−
898− let deps = map Src.getImportName imports
899− mvar <- newMVar Map.empty
900− crawlDeps env mvar deps ()
901−
902− statuses <- traverse readMVar =<< readMVar mvar
903− midpoint <- checkMidpoint dmvar statuses
904−
905− case midpoint of
906− Left problem ->
907− return $ Left $ Exit.ReplProjectProblem problem
908−
909− Right foreigns ->
910− do rmvar <- newEmptyMVar
911− resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
912− putMVar rmvar resultMVars
913− results <- traverse readMVar resultMVars
914− writeDetails root details results
915− depsStatus <- checkDeps root resultMVars deps 0
916− finalizeReplArtifacts env source modul depsStatus resultMVars results
917−
918−
919−finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
920−finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
921− let
922− pkg =
923− projectTypeToPkg projectType
924−
925− compileInput ifaces =
926− case Compile.compile pkg ifaces modul of
927− Right (Compile.Artifacts canonical annotations objects) ->
928− let
929− h = Can._name canonical
930− m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
931− ms = Map.foldrWithKey addInside [] results
932− in
933− return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
934−
935− Left errors ->
936− return $ Left $ Exit.ReplBadInput source errors
937− in
938− case depsStatus of
939− DepsChange ifaces ->
940− compileInput ifaces
941−
942− DepsSame same cached ->
943− do maybeLoaded <- loadInterfaces root same cached
944− case maybeLoaded of
945− Just ifaces -> compileInput ifaces
946− Nothing -> return $ Left $ Exit.ReplBadCache
947−
948− DepsBlock ->
949− case Map.foldr addErrors [] results of
950− [] -> return $ Left $ Exit.ReplBlocked
951− e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
952−
953− DepsNotFound problems ->
954− return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
955− toImportErrors env resultMVars imports problems
956−
957−
958−
959−--------------------------------------------------------------------------------
960−--------------------------------------------------------------------------------
961−------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
962−--------------------------------------------------------------------------------
963−--------------------------------------------------------------------------------
964−
965−
966−
967−-- FIND ROOT
968−
969−
970−data RootLocation
971− = LInside ModuleName.Raw
972− | LOutside FilePath
973−
974−
975−findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
976−findRoots env paths =
977− do mvars <- traverse (fork . getRootInfo env) paths
978− einfos <- traverse readMVar mvars
979− return $ checkRoots =<< sequence einfos
980−
981−
982−checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
983−checkRoots infos =
984− let
985− toOneOrMore loc@(RootInfo absolute _ _) =
986− (absolute, OneOrMore.one loc)
987−
988− fromOneOrMore loc locs =
989− case locs of
990− [] -> Right ()
991− loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
992− in
993− fmap (\_ -> fmap _location infos) $
994− traverse (OneOrMore.destruct fromOneOrMore) $
995− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
996−
997−
998−
999−-- ROOT INFO
1000−
1001−
1002−data RootInfo =
1003− RootInfo
1004− { _absolute :: FilePath
1005− , _relative :: FilePath
1006− , _location :: RootLocation
1007− }
1008−
1009−
1010−getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1011−getRootInfo env path =
1012− do exists <- File.exists path
1013− if exists
1014− then getRootInfoHelp env path =<< Dir.canonicalizePath path
1015− else return (Left (Exit.BP_PathUnknown path))
1016−
1017−
1018−getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1019−getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
1020− let
1021− (dirs, file) = FP.splitFileName absolutePath
1022− (final, ext) = FP.splitExtension file
1023− in
1024− if ext /= ".elm"
1025− then
1026− return $ Left $ Exit.BP_WithBadExtension path
1027− else
1028− let
1029− absoluteSegments = FP.splitDirectories dirs ++ [final]
1030− in
1031− case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
1032− [] ->
1033− return $ Right $ RootInfo absolutePath path (LOutside path)
1034−
1035− [(_, Right names)] ->
1036− do let name = Name.fromChars (List.intercalate "." names)
1037− matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
1038− case matchingDirs of
1039− d1:d2:_ ->
1040− do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
1041− let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1042− return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1043−
1044− _ ->
1045− return $ Right $ RootInfo absolutePath path (LInside name)
1046−
1047− [(s, Left names)] ->
1048− return $ Left $ Exit.BP_RootNameInvalid path s names
1049−
1050− (s1,_):(s2,_):_ ->
1051− return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1052−
1053−
1054−
1055−isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
1056−isInsideSrcDirByName names srcDir =
1057− File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1058−
1059−
1060−isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1061−isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
1062− case dropPrefix (FP.splitDirectories srcDir) segments of
1063− Nothing ->
1064− Nothing
1065−
1066− Just names ->
1067− if all isGoodName names
1068− then Just (srcDir, Right names)
1069− else Just (srcDir, Left names)
1070−
1071−
1072−isGoodName :: [Char] -> Bool
1073−isGoodName name =
1074− case name of
1075− [] ->
1076− False
1077−
1078− char:chars ->
1079− Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1080−
1081−
1082−-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083−--
1084−dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1085−dropPrefix roots paths =
1086− case roots of
1087− [] ->
1088− Just paths
1089−
1090− r:rs ->
1091− case paths of
1092− [] -> Nothing
1093− p:ps -> if r == p then dropPrefix rs ps else Nothing
1094−
1095−
1096−
1097−-- CRAWL ROOTS
1098−
1099−
1100−data RootStatus
1101− = SInside ModuleName.Raw
1102− | SOutsideOk Details.Local B.ByteString Src.Module
1103− | SOutsideErr Error.Module
1104−
1105−
1106−crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
1107−crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1108− case root of
1109− LInside name ->
1110− do statusMVar <- newEmptyMVar
1111− statusDict <- takeMVar mvar
1112− putMVar mvar (Map.insert name statusMVar statusDict)
1113− putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1114− return (SInside name)
1115−
1116− LOutside path ->
1117− do time <- File.getTime path
1118− source <- File.readUtf8 path
1119− case Parse.fromByteString projectType source of
1120− Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1121− do let deps = map Src.getImportName imports
1122− let local = Details.Local path time deps (any isMain values) buildID buildID
1123− crawlDeps env mvar deps (SOutsideOk local source modul)
1124−
1125− Left syntaxError ->
1126− return $ SOutsideErr $
1127− Error.Module "???" path time source (Error.BadSyntax syntaxError)
1128−
1129−
1130−
1131−-- CHECK ROOTS
1132−
1133−
1134−data RootResult
1135− = RInside ModuleName.Raw
1136− | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1137− | ROutsideErr Error.Module
1138− | ROutsideBlocked
1139−
1140−
1141−checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
1142−checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
1143− case rootStatus of
1144− SInside name ->
1145− return (RInside name)
1146−
1147− SOutsideErr err ->
1148− return (ROutsideErr err)
1149−
1150− SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1151− do depsStatus <- checkDeps root results deps lastCompile
1152− case depsStatus of
1153− DepsChange ifaces ->
1154− compileOutside env local source ifaces modul
1155−
1156− DepsSame same cached ->
1157− do maybeLoaded <- loadInterfaces root same cached
1158− case maybeLoaded of
1159− Nothing -> return ROutsideBlocked
1160− Just ifaces -> compileOutside env local source ifaces modul
1161−
1162− DepsBlock ->
1163− return ROutsideBlocked
1164−
1165− DepsNotFound problems ->
1166− return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1167− Error.BadImports (toImportErrors env results imports problems)
1168−
1169−
1170−compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
1171−compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
1172− let
1173− pkg = projectTypeToPkg projectType
1174− name = Src.getName modul
1175− in
1176− case Compile.compile pkg ifaces modul of
1177− Right (Compile.Artifacts canonical annotations objects) ->
1178− do Reporting.report key Reporting.BDone
1179− return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1180−
1181− Left errors ->
1182− return $ ROutsideErr $ Error.Module name path time source errors
1183−
1184−
1185−
1186−-- TO ARTIFACTS
1187−
1188−
1189−data Root
1190− = Inside ModuleName.Raw
1191− | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1192−
1193−
1194−toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
1195−toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
1196− case gatherProblemsOrMains results rootResults of
1197− Left (NE.List e es) ->
1198− Left (Exit.BuildBadModules root e es)
1199−
1200− Right roots ->
1201− Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
1202− Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
1203−
1204−
1205−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
1206−gatherProblemsOrMains results (NE.List rootResult rootResults) =
1207− let
1208− addResult result (es, roots) =
1209− case result of
1210− RInside n -> ( es, Inside n : roots)
1211− ROutsideOk n i o -> ( es, Outside n i o : roots)
1212− ROutsideErr e -> (e:es, roots)
1213− ROutsideBlocked -> ( es, roots)
1214−
1215− errors = Map.foldr addErrors [] results
1216− in
1217− case (rootResult, foldr addResult (errors, []) rootResults) of
1218− (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1219− (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1220− (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1221− (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1222− (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1223− (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1224− (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1225−
1226−
1227−addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1228−addInside name result modules =
1229− case result of
1230− RNew _ iface objs _ -> Fresh name iface objs : modules
1231− RSame _ iface objs _ -> Fresh name iface objs : modules
1232− RCached main _ mvar -> Cached name main mvar : modules
1233− RNotFound _ -> error (badInside name)
1234− RProblem _ -> error (badInside name)
1235− RBlocked -> error (badInside name)
1236− RForeign _ -> modules
1237− RKernel -> modules
1238−
1239−
1240−badInside :: ModuleName.Raw -> [Char]
1241−badInside name =
1242− "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1243−
1244−
1245−addOutside :: RootResult -> [Module] -> [Module]
1246−addOutside root modules =
1247− case root of
1248− RInside _ -> modules
1249− ROutsideOk name iface objs -> Fresh name iface objs : modules
1250− ROutsideErr _ -> modules
1251− ROutsideBlocked -> modules
builder/src/Deps/Bump.hsdeleted−37
@@ -1,37 +0,0 @@
1−module Deps.Bump
2− ( getPossibilities
3− )
4− where
5−
6−
7−import qualified Data.List as List
8−
9−import qualified Deps.Registry as Registry
10−import qualified Elm.Magnitude as M
11−import qualified Elm.Version as V
12−
13−
14−
15−-- GET POSSIBILITIES
16−
17−
18−getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)]
19−getPossibilities (Registry.KnownVersions latest previous) =
20− let
21− allVersions = reverse (latest:previous)
22− minorPoints = map last (List.groupBy sameMajor allVersions)
23− patchPoints = map last (List.groupBy sameMinor allVersions)
24− in
25− (latest, V.bumpMajor latest, M.MAJOR)
26− : map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
27− ++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
28−
29−
30−sameMajor :: V.Version -> V.Version -> Bool
31−sameMajor (V.Version major1 _ _) (V.Version major2 _ _) =
32− major1 == major2
33−
34−
35−sameMinor :: V.Version -> V.Version -> Bool
36−sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) =
37− major1 == major2 && minor1 == minor2
builder/src/Deps/Diff.hs+8−10
@@ -18,7 +18,7 @@ import qualified Data.List as List
1818import qualified Data.Map as Map
1919import qualified Data.Name as Name
2020import qualified Data.Set as Set
21−import qualified System.Directory as Dir
21+import qualified Data.Utf8 as Utf8
2222import System.FilePath ((</>))
2323
2424import qualified Deps.Website as Website
@@ -204,7 +204,7 @@ isSameName :: Name.Name -> Name.Name -> Bool
204204isSameName oldFullName newFullName =
205205 let
206206 dedot name =
207− reverse (Name.splitDots name)
207+ reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))
208208 in
209209 case ( dedot oldFullName, dedot newFullName ) of
210210 (oldName:[], newName:_) ->
@@ -357,13 +357,12 @@ changeMagnitude (Changes added changed removed) =
357357
358358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359359getDocs cache manager name version =
360− do let home = Stuff.package cache name version
361− let path = home </> "docs.json"
360+ do let path = Stuff.package cache name version </> "docs.json"
362361 exists <- File.exists path
363362 if exists
364363 then
365− do bytes <- File.readUtf8 path
366− case D.fromByteString Docs.decoder bytes of
364+ do result <- D.fromFile Docs.decoder path
365+ case result of
367366 Right docs ->
368367 return $ Right docs
369368
@@ -372,12 +371,11 @@ getDocs cache manager name version =
372371 return $ Left Exit.DP_Cache
373372 else
374373 do let url = Website.metadata name version "docs.json"
375− Http.get manager url [] Exit.DP_Http $ \body ->
374+ Http.post manager url [] Exit.DP_Http $ \body ->
376375 case D.fromByteString Docs.decoder body of
377376 Right docs ->
378− do Dir.createDirectoryIfMissing True home
379− File.writeUtf8 path body
377+ do File.writeUtf8 path body
380378 return $ Right docs
381379
382380 Left _ ->
383− return $ Left $ Exit.DP_Data url body
381+ return $ Left Exit.DP_Data
builder/src/Deps/Plan.hsnew file+64
@@ -0,0 +1,64 @@
1+module Install.Plan where
2+
3+import qualified Data.Map as Map
4+
5+import qualified Elm.Package.Solution as S
6+import qualified Elm.Package as Package
7+
8+
9+data Plan =
10+ Plan
11+ { installs :: Map.Map Package.Name Package.Version
12+ , upgrades :: Map.Map Package.Name (Package.Version, Package.Version)
13+ , removals :: Map.Map Package.Name Package.Version
14+ }
15+
16+
17+create :: S.Solution -> S.Solution -> Plan
18+create old new =
19+ Plan
20+ { installs = Map.difference new old
21+ , upgrades = discardNoOps (Map.intersectionWith (,) old new)
22+ , removals = Map.difference old new
23+ }
24+ where
25+ discardNoOps updates =
26+ Map.mapMaybe isChanged updates
27+
28+ isChanged upgrade@(oldVersion,newVersion) =
29+ if oldVersion == newVersion
30+ then Nothing
31+ else Just upgrade
32+
33+
34+isEmpty :: Plan -> Bool
35+isEmpty (Plan installs upgrades removals) =
36+ Map.null installs
37+ && Map.null upgrades
38+ && Map.null removals
39+
40+
41+-- DISPLAY
42+
43+display :: Plan -> String
44+display (Plan installs upgrades removals) =
45+ "\n"
46+ ++ displayCategory "Install" displayInstall installs
47+ ++ displayCategory "Upgrade" displayUpgrade upgrades
48+ ++ displayCategory "Remove" displayRemove removals
49+ where
50+ displayCategory name render category =
51+ if Map.null category then "" else
52+ " " ++ name ++ ":"
53+ ++ concatMap (\entry -> "\n " ++ render entry) (Map.toList category)
54+ ++ "\n"
55+
56+ displayInstall (name, version) =
57+ Package.toString name ++ " " ++ Package.versionToString version
58+
59+ displayUpgrade (name, (old, new)) =
60+ Package.toString name ++ " ("
61+ ++ Package.versionToString old ++ " => " ++ Package.versionToString new ++ ")"
62+
63+ displayRemove (name, _version) =
64+ Package.toString name
builder/src/Deps/Registry.hs+73−40
@@ -16,8 +16,11 @@ module Deps.Registry
1616import Prelude hiding (read)
1717import Control.Monad (liftM2)
1818import Data.Binary (Binary, get, put)
19+import Data.Function (on)
1920import qualified Data.List as List
2021import qualified Data.Map.Strict as Map
22+import qualified Data.Name as Name
23+import qualified Data.Utf8 as Utf8
2124
2225import qualified Deps.Website as Website
2326import qualified Elm.Package as Pkg
@@ -25,8 +28,8 @@ import qualified Elm.Version as V
2528import qualified File
2629import qualified Http
2730import qualified Json.Decode as D
28−import qualified Parse.Primitives as P
29−import qualified Reporting.Exit as Exit
31+import qualified Reporting.Exit as E
32+import qualified Reporting.Suggest as Suggest
3033import qualified Stuff
3134
3235
@@ -54,14 +57,18 @@ data KnownVersions =
5457
5558read :: Stuff.PackageCache -> IO (Maybe Registry)
5659read cache =
57− File.readBinary (Stuff.registry cache)
60+ do let path = Stuff.registry cache
61+ exists <- File.exists path
62+ if exists
63+ then File.readBinary path
64+ else return Nothing
5865
5966
6067
6168-- FETCH
6269
6370
64−fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
71+fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
6572fetch manager cache =
6673 post manager "/all-packages" allPkgsDecoder $
6774 \versions ->
@@ -79,26 +86,33 @@ addEntry (KnownVersions _ vs) count =
7986
8087allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
8188allPkgsDecoder =
82− let
83− keyDecoder =
84− Pkg.keyDecoder bail
89+ do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))
90+ checkKeys pairs Map.empty
91+ where
92+ checkKeys pairs pkgs =
93+ case pairs of
94+ [] ->
95+ return pkgs
8596
86− versionsDecoder =
87− D.list (D.mapError (\_ -> ()) V.decoder)
97+ (key, versions) : rest ->
98+ case Pkg.fromString key of
99+ Right pkg ->
100+ case List.sortBy (flip compare) versions of
101+ [] ->
102+ D.failure ()
88103
89− toKnownVersions versions =
90− case List.sortBy (flip compare) versions of
91− v:vs -> return (KnownVersions v vs)
92− [] -> D.failure ()
93− in
94− D.dict keyDecoder (toKnownVersions =<< versionsDecoder)
104+ v:vs ->
105+ checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)
106+
107+ Left _ ->
108+ D.failure ()
95109
96110
97111
98112-- UPDATE
99113
100114
101−update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)
115+update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either E.RegistryProblem Registry)
102116update manager cache oldRegistry@(Registry size packages) =
103117 post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
104118 \news ->
@@ -130,33 +144,29 @@ addNew (name, version) versions =
130144 Map.alter (Just . add) name versions
131145
132146
133−
134−-- NEW PACKAGE DECODER
135−
136−
137147newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
138148newPkgDecoder =
139− D.customString newPkgParser bail
140−
149+ do str <- D.string
150+ case Utf8.split 0x40 {-@-} str of
151+ [key, value] ->
152+ case Pkg.fromString key of
153+ Right pkg ->
154+ case V.fromString value of
155+ Just vsn -> return (pkg, vsn)
156+ Nothing -> D.failure ()
141157
142−newPkgParser :: P.Parser () (Pkg.Name, V.Version)
143−newPkgParser =
144− do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
145− P.word1 0x40 {-@-} bail
146− vsn <- P.specialize (\_ _ _ -> ()) V.parser
147− return (pkg, vsn)
158+ Left _ ->
159+ D.failure ()
148160
149−
150−bail :: row -> col -> ()
151−bail _ _ =
152− ()
161+ _ ->
162+ D.failure ()
153163
154164
155165
156166-- LATEST
157167
158168
159−latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
169+latest :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
160170latest manager cache =
161171 do maybeOldRegistry <- read cache
162172 case maybeOldRegistry of
@@ -180,23 +190,46 @@ getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
180190getVersions' name (Registry _ versions) =
181191 case Map.lookup name versions of
182192 Just kvs -> Right kvs
183− Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
193+ Nothing -> Left $ nearbyNames name (Map.keys versions)
194+
195+
196+nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
197+nearbyNames (Pkg.Name author1 project1) possibleNames =
198+ let
199+ authorDist = authorDistance (Name.toChars author1)
200+ projectDist = projectDistance (Name.toChars project1)
201+
202+ addDistance name@(Pkg.Name author2 project2) =
203+ ( authorDist author2 + projectDist project2, name )
204+ in
205+ map snd $ take 4 $
206+ List.sortBy (compare `on` fst) $
207+ map addDistance possibleNames
208+
209+
210+authorDistance :: String -> Name.Name -> Int
211+authorDistance bad possibility =
212+ abs (Suggest.distance bad (Name.toChars possibility))
213+
214+
215+projectDistance :: String -> Name.Name -> Int
216+projectDistance bad possibility =
217+ if possibility == "elm" || possibility == "elm-explorations"
218+ then 0
219+ else abs (Suggest.distance bad (Name.toChars possibility))
184220
185221
186222
187223-- POST
188224
189225
190−post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
226+post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either E.RegistryProblem b)
191227post manager path decoder callback =
192− let
193− url = Website.route path []
194− in
195− Http.post manager url [] Exit.RP_Http $
228+ Http.post manager (Website.route path []) [] E.RP_Http $
196229 \body ->
197230 case D.fromByteString decoder body of
198231 Right a -> Right <$> callback a
199− Left _ -> return $ Left $ Exit.RP_Data url body
232+ Left _ -> return $ Left E.RP_Data
200233
201234
202235
builder/src/Deps/Solver.hs+149−258
@@ -1,25 +1,14 @@
11{-# LANGUAGE OverloadedStrings, Rank2Types #-}
22module Deps.Solver
3− ( Solver
4− , Result(..)
5− , Connection(..)
6− --
3+ ( online
4+ , offline
75 , Details(..)
8− , verify
9− --
10− , AppSolution(..)
11− , addToApp
12− --
13− , Env(..)
14− , initEnv
156 )
167 where
178
189
1910import Control.Monad (foldM)
20−import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
2111import qualified Data.Map as Map
22−import Data.Map ((!))
2312import qualified System.Directory as Dir
2413import System.FilePath ((</>))
2514
@@ -32,11 +21,52 @@ import qualified Elm.Version as V
3221import qualified File
3322import qualified Http
3423import qualified Json.Decode as D
35−import qualified Reporting.Exit as Exit
3624import qualified Stuff
3725
3826
3927
28+-- ONLINE / OFFLINE
29+
30+
31+online :: Stuff.PackageCache -> Http.Manager -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
32+online cache manager registry constraints =
33+ solve cache (Online manager) registry constraints
34+
35+
36+offline :: Stuff.PackageCache -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
37+offline cache registry constraints =
38+ solve cache Offline registry constraints
39+
40+
41+
42+-- SOLVE
43+
44+
45+data Details =
46+ Details V.Version (Map.Map Pkg.Name C.Constraint)
47+
48+
49+solve :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
50+solve cache connection registry constraints =
51+ let
52+ (Solver solver) = exploreGoals (Goals constraints Map.empty)
53+ in
54+ solver (State cache connection registry Map.empty [])
55+ (\(State _ _ _ cs _) vs _ -> return $ Right $ Map.mapWithKey (toDetails cs) vs)
56+ (\(State _ _ _ _ ps) -> return $ Left ps)
57+
58+
59+toDetails :: Map.Map (Pkg.Name, V.Version) Constraints -> Pkg.Name -> V.Version -> Details
60+toDetails constraints name vsn =
61+ case Map.lookup (name, vsn) constraints of
62+ Just (Constraints _ deps) ->
63+ Details vsn deps
64+
65+ Nothing ->
66+ error "compiler bug in Deps.Solver manifesting in toDetails"
67+
68+
69+
4070-- SOLVER
4171
4272
@@ -47,17 +77,21 @@ newtype Solver a =
4777 State
4878 -> (State -> a -> (State -> IO b) -> IO b)
4979 -> (State -> IO b)
50− -> (Exit.Solver -> IO b)
5180 -> IO b
5281 )
5382
5483
84+
85+-- STATE
86+
87+
5588data State =
5689 State
5790 { _cache :: Stuff.PackageCache
58− , _connection :: Connection
91+ , _internet :: Connection
5992 , _registry :: Registry.Registry
6093 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
94+ , _problems :: [Problem]
6195 }
6296
6397
@@ -73,126 +107,13 @@ data Connection
73107 | Offline
74108
75109
76−
77−-- RESULT
78−
79−
80−data Result a
81− = Ok a
82− | NoSolution
83− | NoOfflineSolution
84− | Err Exit.Solver
85−
86−
87−
88−-- VERIFY -- used by Elm.Details
89−
90−
91−data Details =
92− Details V.Version (Map.Map Pkg.Name C.Constraint)
93−
94−
95−verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96−verify cache connection registry constraints =
97− Stuff.withRegistryLock cache $
98− case try constraints of
99− Solver solver ->
100− solver (State cache connection registry Map.empty)
101− (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
102− (\_ -> return $ noSolution connection)
103− (\e -> return $ Err e)
104−
105−
106−addDeps :: State -> Pkg.Name -> V.Version -> Details
107−addDeps (State _ _ _ constraints) name vsn =
108− case Map.lookup (name, vsn) constraints of
109− Just (Constraints _ deps) -> Details vsn deps
110− Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
111−
112−
113−noSolution :: Connection -> Result a
114−noSolution connection =
115− case connection of
116− Online _ -> NoSolution
117− Offline -> NoOfflineSolution
118−
119−
120−
121−-- ADD TO APP - used in Install
122−
123−
124−data AppSolution =
125− AppSolution
126− { _old :: Map.Map Pkg.Name V.Version
127− , _new :: Map.Map Pkg.Name V.Version
128− , _app :: Outline.AppOutline
129− }
130−
131−
132−addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
133−addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134− Stuff.withRegistryLock cache $
135− let
136− allIndirects = Map.union indirect testIndirect
137− allDirects = Map.union direct testDirect
138− allDeps = Map.union allDirects allIndirects
139−
140− attempt toConstraint deps =
141− try (Map.insert pkg C.anything (Map.map toConstraint deps))
142− in
143− case
144− oneOf
145− ( attempt C.exactly allDeps )
146− [ attempt C.exactly allDirects
147− , attempt C.untilNextMinor allDirects
148− , attempt C.untilNextMajor allDirects
149− , attempt (\_ -> C.anything) allDirects
150− ]
151− of
152− Solver solver ->
153− solver (State cache connection registry Map.empty)
154− (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
155− (\_ -> return $ noSolution connection)
156− (\e -> return $ Err e)
157−
158−
159−toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
160−toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =
161− let
162− d = Map.intersection new (Map.insert pkg V.one direct)
163− i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
164− td = Map.intersection new (Map.delete pkg testDirect)
165− ti = Map.difference new (Map.unions [d,i,td])
166− in
167− AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)
168−
169−
170−getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
171−getTransitive constraints solution unvisited visited =
172− case unvisited of
173− [] ->
174− visited
175−
176− info@(pkg,vsn) : infos ->
177− if Map.member pkg visited
178− then getTransitive constraints solution infos visited
179− else
180− let
181− newDeps = _deps (constraints ! info)
182− newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
183− newVisited = Map.insert pkg vsn visited
184− in
185− getTransitive constraints solution infos $
186− getTransitive constraints solution newUnvisited newVisited
187−
188−
189−
190−-- TRY
191−
192−
193−try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
194−try constraints =
195− exploreGoals (Goals constraints Map.empty)
110+data Problem
111+ = BadCacheData Pkg.Name V.Version
112+ | BadHttpData Pkg.Name V.Version
113+ | BadHttp Http.Error
114+ | UnknownPackage [Pkg.Name]
115+ | ImpossibleConstraint Pkg.Name C.Constraint
116+ | UnavailableOffline Pkg.Name V.Version
196117
197118
198119
@@ -228,7 +149,7 @@ addVersion (Goals pending solved) name version =
228149 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
229150 return (Goals newPending (Map.insert name version solved))
230151 else
231− backtrack
152+ deadend
232153
233154
234155addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
@@ -237,7 +158,7 @@ addConstraint solved unsolved (name, newConstraint) =
237158 Just version ->
238159 if C.satisfies newConstraint version
239160 then return unsolved
240− else backtrack
161+ else deadend
241162
242163 Nothing ->
243164 case Map.lookup name unsolved of
@@ -247,7 +168,7 @@ addConstraint solved unsolved (name, newConstraint) =
247168 Just oldConstraint ->
248169 case C.intersect oldConstraint newConstraint of
249170 Nothing ->
250− backtrack
171+ deadend
251172
252173 Just mergedConstraint ->
253174 if oldConstraint == mergedConstraint
@@ -261,15 +182,18 @@ addConstraint solved unsolved (name, newConstraint) =
261182
262183getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
263184getRelevantVersions name constraint =
264− Solver $ \state@(State _ _ registry _) ok back _ ->
265− case Registry.getVersions name registry of
266− Just (Registry.KnownVersions newest previous) ->
185+ Solver $ \state@(State _ _ registry _ _) ok err ->
186+ case Registry.getVersions' name registry of
187+ Right (Registry.KnownVersions newest previous) ->
267188 case filter (C.satisfies constraint) (newest:previous) of
268− [] -> back state
269− v:vs -> ok state (v,vs) back
189+ [] ->
190+ err (addProblem (ImpossibleConstraint name constraint) state)
191+
192+ v:vs ->
193+ ok state (v,vs) err
270194
271− Nothing ->
272− back state
195+ Left suggestions ->
196+ err (addProblem (UnknownPackage suggestions) state)
273197
274198
275199
@@ -277,57 +201,59 @@ getRelevantVersions name constraint =
277201
278202
279203getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
280−getConstraints pkg vsn =
281− Solver $ \state@(State cache connection registry cDict) ok back err ->
282− do let key = (pkg, vsn)
204+getConstraints name version =
205+ Solver $ \state@(State cache connection registry cDict ps) ok err ->
206+ do let key = (name, version)
283207 case Map.lookup key cDict of
284208 Just cs ->
285− ok state cs back
209+ ok state cs err
286210
287211 Nothing ->
288− do let toNewState cs = State cache connection registry (Map.insert key cs cDict)
289− let home = Stuff.package cache pkg vsn
290− let path = home </> "elm.json"
291− outlineExists <- File.exists path
292− if outlineExists
293− then
294− do bytes <- File.readUtf8 path
295− case D.fromByteString constraintsDecoder bytes of
296− Right cs ->
297− case connection of
298− Online _ ->
299− ok (toNewState cs) cs back
300−
301− Offline ->
302− do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
303− if srcExists
304− then ok (toNewState cs) cs back
305− else back state
306−
307− Left _ ->
308− do File.remove path
309− err (Exit.SolverBadCacheData pkg vsn)
310− else
311− case connection of
312− Offline ->
313− back state
314−
315− Online manager ->
316− do let url = Website.metadata pkg vsn "elm.json"
317− result <- Http.get manager url [] id (return . Right)
318− case result of
319− Left httpProblem ->
320− err (Exit.SolverBadHttp pkg vsn httpProblem)
321−
322− Right body ->
323− case D.fromByteString constraintsDecoder body of
324− Right cs ->
325− do Dir.createDirectoryIfMissing True home
326− File.writeUtf8 path body
327− ok (toNewState cs) cs back
328−
329− Left _ ->
330− err (Exit.SolverBadHttpData pkg vsn url)
212+ do result <- getConstraintsHelp cache connection name version
213+ case result of
214+ Right cs ->
215+ ok (State cache connection registry (Map.insert key cs cDict) ps) cs err
216+
217+ Left p ->
218+ err (State cache connection registry cDict (p:ps))
219+
220+
221+getConstraintsHelp :: Stuff.PackageCache -> Connection -> Pkg.Name -> V.Version -> IO (Either Problem Constraints)
222+getConstraintsHelp cache connection name version =
223+ do let path = Stuff.package cache name version </> "elm.json"
224+ outlineExists <- File.exists path
225+ if outlineExists
226+ then
227+ do result <- D.fromFile constraintsDecoder path
228+ case result of
229+ Right cs ->
230+ case connection of
231+ Online _ ->
232+ return $ Right cs
233+
234+ Offline ->
235+ do srcExists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
236+ if srcExists
237+ then return $ Right cs
238+ else return $ Left (UnavailableOffline name version)
239+
240+ Left _ ->
241+ do File.remove path
242+ return $ Left (BadCacheData name version)
243+ else
244+ case connection of
245+ Offline ->
246+ return (Left (UnavailableOffline name version))
247+
248+ Online manager ->
249+ Http.post manager (Website.metadata name version "elm.json") [] BadHttp $ \body ->
250+ case D.fromByteString constraintsDecoder body of
251+ Right cs ->
252+ do File.writeUtf8 path body
253+ return $ Right cs
254+
255+ Left _ ->
256+ return $ Left (BadHttpData name version)
331257
332258
333259constraintsDecoder :: D.Decoder () Constraints
@@ -342,83 +268,46 @@ constraintsDecoder =
342268
343269
344270
345−-- ENVIRONMENT
346−
347−
348−data Env =
349− Env Stuff.PackageCache Http.Manager Connection Registry.Registry
350−
351−
352−initEnv :: IO (Either Exit.RegistryProblem Env)
353−initEnv =
354− do mvar <- newEmptyMVar
355− _ <- forkIO $ putMVar mvar =<< Http.getManager
356− cache <- Stuff.getPackageCache
357− Stuff.withRegistryLock cache $
358− do maybeRegistry <- Registry.read cache
359− manager <- readMVar mvar
360−
361− case maybeRegistry of
362− Nothing ->
363− do eitherRegistry <- Registry.fetch manager cache
364− case eitherRegistry of
365− Right latestRegistry ->
366− return $ Right $ Env cache manager (Online manager) latestRegistry
367−
368− Left problem ->
369− return $ Left $ problem
370−
371− Just cachedRegistry ->
372− do eitherRegistry <- Registry.update manager cache cachedRegistry
373− case eitherRegistry of
374− Right latestRegistry ->
375− return $ Right $ Env cache manager (Online manager) latestRegistry
376−
377− Left _ ->
378− return $ Right $ Env cache manager Offline cachedRegistry
379−
380−
381−
382271-- INSTANCES
383272
384273
385274instance Functor Solver where
386275 fmap func (Solver solver) =
387− Solver $ \state ok back err ->
276+ Solver $ \state ok err ->
388277 let
389− okA stateA arg backA = ok stateA (func arg) backA
278+ okA stateA arg errA = ok stateA (func arg) errA
390279 in
391− solver state okA back err
280+ solver state okA err
392281
393282
394283instance Applicative Solver where
395284 pure a =
396− Solver $ \state ok back _ -> ok state a back
285+ Solver $ \state ok err -> ok state a err
397286
398287 (<*>) (Solver solverFunc) (Solver solverArg) =
399− Solver $ \state ok back err ->
288+ Solver $ \state ok err ->
400289 let
401− okF stateF func backF =
290+ okF stateF func errF =
402291 let
403− okA stateA arg backA = ok stateA (func arg) backA
292+ okA stateA arg errA = ok stateA (func arg) errA
404293 in
405− solverArg stateF okA backF err
294+ solverArg stateF okA errF
406295 in
407− solverFunc state okF back err
296+ solverFunc state okF err
408297
409298
410299instance Monad Solver where
411300 return a =
412− Solver $ \state ok back _ -> ok state a back
301+ Solver $ \state ok err -> ok state a err
413302
414303 (>>=) (Solver solverA) callback =
415− Solver $ \state ok back err ->
304+ Solver $ \state ok err ->
416305 let
417− okA stateA a backA =
306+ okA stateA a errA =
418307 case callback a of
419− Solver solverB -> solverB stateA ok backA err
308+ Solver solverB -> solverB stateA ok errA
420309 in
421− solverA state okA back err
310+ solverA state okA err
422311
423312
424313oneOf :: Solver a -> [Solver a] -> Solver a
@@ -428,17 +317,19 @@ oneOf solver@(Solver solverHead) solvers =
428317 solver
429318
430319 s:ss ->
431− Solver $ \state0 ok back err ->
432− let
433− tryTail state1 =
434− let
435− (Solver solverTail) = oneOf s ss
436− in
437− solverTail state1 ok back err
438− in
439− solverHead state0 ok tryTail err
440−
441−
442−backtrack :: Solver a
443−backtrack =
444− Solver $ \state _ back _ -> back state
320+ Solver $ \state0 ok err ->
321+ solverHead state0 ok $ \state1 ->
322+ let
323+ (Solver solverTail) = oneOf s ss
324+ in
325+ solverTail state1 ok err
326+
327+
328+deadend :: Solver a
329+deadend =
330+ Solver $ \state _ err -> err state
331+
332+
333+addProblem :: Problem -> State -> State
334+addProblem problem (State cache registry cDict maybeManager problems) =
335+ State cache registry cDict maybeManager (problem:problems)
builder/src/Elm/Bump.hsnew file+137
@@ -0,0 +1,137 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Bump
3+ ( bump
4+ , toPossibleBumps
5+ )
6+ where
7+
8+
9+import Control.Monad.Trans (liftIO)
10+import qualified Data.List as List
11+
12+import qualified Deps.Cache as Cache
13+import qualified Deps.Diff as Diff
14+import qualified Elm.Project.Json as Project
15+import qualified Elm.Project.Summary as Summary
16+import qualified Elm.Version as V
17+import Reporting.Doc ((<>), (<+>))
18+import qualified Reporting.Doc as D
19+import qualified Reporting.Exit as Exit
20+import qualified Reporting.Exit.Bump as E
21+import qualified Reporting.Exit.Help as Help
22+import qualified Reporting.Progress.Terminal as Terminal
23+import qualified Reporting.Task as Task
24+
25+
26+
27+-- BUMP
28+
29+
30+bump :: Summary.Summary -> Task.Task ()
31+bump summary@(Summary.Summary root project _ _ _) =
32+ case project of
33+ Project.App _ ->
34+ Task.throw (Exit.Bump E.Application)
35+
36+ Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->
37+ do registry <- Cache.mandatoryUpdate
38+ case Cache.getVersions name registry of
39+ Left _suggestions ->
40+ checkNewPackage root info
41+
42+ Right publishedVersions ->
43+ let
44+ bumpableVersions =
45+ map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)
46+ in
47+ if elem version bumpableVersions then
48+ suggestVersion summary info
49+ else
50+ Task.throw $ Exit.Bump $ E.Unbumpable version $
51+ map head (List.group (List.sort bumpableVersions))
52+
53+
54+
55+-- VALID BUMPS
56+
57+
58+toPossibleBumps :: [V.Version] -> [(V.Version, V.Version, Diff.Magnitude)]
59+toPossibleBumps publishedVersions =
60+ case publishedVersions of
61+ [] ->
62+ []
63+
64+ _ ->
65+ let
66+ patchPoints =
67+ V.filterLatest V.majorAndMinor publishedVersions
68+
69+ minorPoints =
70+ V.filterLatest V._major publishedVersions
71+
72+ majorPoint =
73+ maximum publishedVersions
74+ in
75+ (majorPoint, V.bumpMajor majorPoint, Diff.MAJOR)
76+ : map (\v -> (v, V.bumpMinor v, Diff.MINOR)) minorPoints
77+ ++ map (\v -> (v, V.bumpPatch v, Diff.PATCH)) patchPoints
78+
79+
80+
81+-- CHECK NEW PACKAGE
82+
83+
84+checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()
85+checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =
86+ do liftIO $ putStrLn Terminal.newPackageOverview
87+ if version == V.one
88+ then
89+ liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"
90+ else
91+ changeVersion root info V.one $
92+ "It looks like the version in elm.json has been changed though!\n\
93+ \Would you like me to change it back to "
94+ <> D.fromUtf8 (V.toString V.one) <> "? [Y/n] "
95+
96+
97+
98+-- SUGGEST VERSION
99+
100+
101+suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()
102+suggestVersion (Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =
103+ do oldDocs <- Cache.getDocs name version
104+ newDocs <- Task.silently (error "TODO Project.generateDocs summary")
105+ let changes = Diff.diff oldDocs newDocs
106+ let newVersion = Diff.bump changes version
107+ changeVersion root info newVersion $
108+ let
109+ old = D.fromUtf8 $ V.toString version
110+ new = D.fromUtf8 $ V.toString newVersion
111+ mag = D.fromChars $ Diff.magnitudeToString (Diff.toMagnitude changes)
112+ in
113+ "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
114+ <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
115+ <> "\n"
116+ <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
117+
118+
119+
120+-- CHANGE VERSION
121+
122+
123+changeVersion :: FilePath -> Project.PkgInfo -> V.Version -> D.Doc -> Task.Task ()
124+changeVersion root info targetVersion explanation =
125+ do approved <- Task.getApproval explanation
126+ if not approved
127+ then
128+ liftIO $ putStrLn "Okay, I did not change anything!"
129+
130+ else
131+ do liftIO $ Project.write root $ Project.Pkg $
132+ info { Project._pkg_version = targetVersion }
133+
134+ liftIO $ Help.toStdout $
135+ "Version changed to "
136+ <> D.green (D.fromUtf8 (V.toString targetVersion))
137+ <> "!\n"
builder/src/Elm/Details.hs+223−479
@@ -2,48 +2,35 @@
22{-# LANGUAGE BangPatterns, OverloadedStrings #-}
33module Elm.Details
44 ( Details(..)
5− , BuildID
65 , ValidOutline(..)
76 , Local(..)
87 , Foreign(..)
9− , load
10− , loadObjects
11− , loadInterfaces
12− , verifyInstall
8+ , verify
139 )
1410 where
1511
1612
1713import Control.Concurrent (forkIO)
1814import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
19−import Control.Monad (liftM, liftM2, liftM3)
15+import Control.Monad (liftM, liftM2, liftM3, liftM4)
2016import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Either as Either
17+import Data.Foldable (traverse_)
2218import qualified Data.Map as Map
23−import qualified Data.Map.Utils as Map
2419import qualified Data.Map.Merge.Strict as Map
25−import qualified Data.Maybe as Maybe
26−import qualified Data.Name as Name
27−import qualified Data.NonEmptyList as NE
2820import qualified Data.OneOrMore as OneOrMore
2921import qualified Data.Set as Set
3022import qualified Data.Utf8 as Utf8
31−import Data.Word (Word64)
3223import qualified System.Directory as Dir
3324import System.FilePath ((</>), (<.>))
3425
35−import qualified AST.Canonical as Can
3626import qualified AST.Source as Src
3727import qualified AST.Optimized as Opt
38−import qualified BackgroundWriter as BW
3928import qualified Compile
4029import qualified Deps.Registry as Registry
4130import qualified Deps.Solver as Solver
4231import qualified Deps.Website as Website
4332import qualified Elm.Constraint as Con
44−import qualified Elm.Docs as Docs
4533import qualified Elm.Interface as I
46−import qualified Elm.Kernel as Kernel
4734import qualified Elm.ModuleName as ModuleName
4835import qualified Elm.Outline as Outline
4936import qualified Elm.Package as Pkg
@@ -51,10 +38,7 @@ import qualified Elm.Version as V
5138import qualified File
5239import qualified Http
5340import qualified Json.Decode as D
54−import qualified Json.Encode as E
5541import qualified Parse.Module as Parse
56−import qualified Reporting
57−import qualified Reporting.Annotation as A
5842import qualified Reporting.Exit as Exit
5943import qualified Reporting.Task as Task
6044import qualified Stuff
@@ -68,42 +52,21 @@ data Details =
6852 Details
6953 { _outlineTime :: File.Time
7054 , _outline :: ValidOutline
71− , _buildID :: BuildID
7255 , _locals :: Map.Map ModuleName.Raw Local
7356 , _foreigns :: Map.Map ModuleName.Raw Foreign
74− , _extras :: Extras
7557 }
7658
7759
78−type BuildID = Word64
60+data ValidOutline
61+ = ValidApp Outline.AppOutline
62+ | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)
7963
8064
81−data ValidOutline
82− = ValidApp (NE.List Outline.SrcDir)
83− | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
84−
85−
86−-- NOTE: we need two ways to detect if a file must be recompiled:
87−--
88−-- (1) _time is the modification time from the last time we compiled the file.
89−-- By checking EQUALITY with the current modification time, we can detect file
90−-- saves and `git checkout` of previous versions. Both need a recompile.
91−--
92−-- (2) _lastChange is the BuildID from the last time a new interface file was
93−-- generated, and _lastCompile is the BuildID from the last time the file was
94−-- compiled. These may be different if a file is recompiled but the interface
95−-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
96−-- imports, we need to recompile. This can happen when a project has multiple
97−-- entrypoints and some modules are compiled less often than their imports.
98−--
9965data Local =
10066 Local
10167 { _path :: FilePath
10268 , _time :: File.Time
10369 , _deps :: [ModuleName.Raw]
104− , _main :: Bool
105− , _lastChange :: BuildID
106− , _lastCompile :: BuildID
10770 }
10871
10972
@@ -111,150 +74,117 @@ data Foreign =
11174 Foreign Pkg.Name [Pkg.Name]
11275
11376
114−data Extras
115− = ArtifactsCached
116− | ArtifactsFresh Interfaces Opt.GlobalGraph
117−
118−
119−type Interfaces =
120− Map.Map ModuleName.Canonical I.DependencyInterface
121−
122−
123−
124−-- LOAD ARTIFACTS
125−
126−
127−loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
128−loadObjects root (Details _ _ _ _ _ extras) =
129− case extras of
130− ArtifactsFresh _ o -> newMVar (Just o)
131− ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
132−
133−
134−loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
135−loadInterfaces root (Details _ _ _ _ _ extras) =
136− case extras of
137− ArtifactsFresh i _ -> newMVar (Just i)
138− ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
139−
140−
14177
142−-- VERIFY INSTALL -- used by Install
78+-- VERIFY
14379
14480
145−verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
146−verifyInstall scope root (Solver.Env cache manager connection registry) outline =
147− do time <- File.getTime (root </> "elm.json")
148− let key = Reporting.ignorer
149− let env = Env key scope root cache manager connection registry
150− case outline of
151− Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
152− Outline.App app -> Task.run (verifyApp env time app >> return ())
153−
154−
155−
156−-- LOAD -- used by Make, Repl, Reactor
157−
158−
159−load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
160−load style scope root =
161− do newTime <- File.getTime (root </> "elm.json")
162− maybeDetails <- File.readBinary (Stuff.details root)
81+verify :: FilePath -> Task.Task Details
82+verify root =
83+ do newTime <- Task.io $ File.getTime (root </> "elm.json")
84+ maybeDetails <- Task.io $ File.readBinary (root </> Stuff.details)
16385 case maybeDetails of
16486 Nothing ->
165− generate style scope root newTime
87+ rebuild root newTime
16688
167− Just details@(Details oldTime _ buildID _ _ _) ->
89+ Just details@(Details oldTime _ _ _) ->
16890 if oldTime == newTime
169− then return (Right details { _buildID = buildID + 1 })
170− else generate style scope root newTime
171−
91+ then return details
92+ else rebuild root newTime
17293
17394
174−-- GENERATE
17595
96+-- REBUILD
17697
177−generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
178−generate style scope root time =
179− Reporting.trackDetails style $ \key ->
180− do result <- initEnv key scope root
181− case result of
182− Left exit ->
183− return (Left exit)
184−
185− Right (env, outline) ->
186− case outline of
187− Outline.Pkg pkg -> Task.run (verifyPkg env time pkg)
188− Outline.App app -> Task.run (verifyApp env time app)
18998
99+rebuild :: FilePath -> File.Time -> Task.Task Details
100+rebuild root time =
101+ do (outline, info) <- rebuildHelp root
102+ case outline of
103+ Outline.Pkg pkg -> solvePkg info time pkg
104+ Outline.App app -> solveApp info time app
190105
191106
192−-- ENV
107+data Info =
108+ Info Stuff.PackageCache Http.Manager Connection Registry.Registry
193109
194110
195−data Env =
196− Env
197− { _key :: Reporting.DKey
198− , _scope :: BW.Scope
199− , _root :: FilePath
200− , _cache :: Stuff.PackageCache
201− , _manager :: Http.Manager
202− , _connection :: Solver.Connection
203− , _registry :: Registry.Registry
204− }
111+data Connection
112+ = Online
113+ | Offline
205114
206115
207−initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
208−initEnv key scope root =
209− do mvar <- fork Solver.initEnv
116+rebuildHelp :: FilePath -> Task.Task (Outline.Outline, Info)
117+rebuildHelp root =
118+ Task.eio id $
119+ do cacheMVar <- fork Stuff.getPackageCache
120+ managerMVar <- fork Http.getManager
121+ registryMVar <- fork (Registry.read =<< readMVar cacheMVar)
210122 eitherOutline <- Outline.read root
123+ cache <- readMVar cacheMVar
124+ manager <- readMVar managerMVar
125+ maybeRegistry <- readMVar registryMVar
211126 case eitherOutline of
212127 Left problem ->
213128 return $ Left $ Exit.DetailsBadOutline problem
214129
215130 Right outline ->
216− do maybeEnv <- readMVar mvar
217− case maybeEnv of
218− Left problem ->
219− return $ Left $ Exit.DetailsCannotGetRegistry problem
131+ case maybeRegistry of
132+ Nothing ->
133+ do eitherRegistry <- Registry.fetch manager cache
134+ case eitherRegistry of
135+ Right latestRegistry ->
136+ return $ Right (outline, Info cache manager Online latestRegistry)
220137
221− Right (Solver.Env cache manager connection registry) ->
222− return $ Right (Env key scope root cache manager connection registry, outline)
138+ Left problem ->
139+ return $ Left $ Exit.DetailsCannotGetRegistry problem
223140
141+ Just cachedRegistry ->
142+ do eitherRegistry <- Registry.update manager cache cachedRegistry
143+ case eitherRegistry of
144+ Right latestRegistry ->
145+ return $ Right (outline, Info cache manager Online latestRegistry)
224146
147+ Left _ ->
148+ return $ Right (outline, Info cache manager Offline cachedRegistry)
225149
226−-- VERIFY PROJECT
227150
228151
229−type Task a = Task.Task Exit.Details a
152+-- SOLVE PKG
230153
231154
232−verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
233−verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
155+solvePkg :: Info -> File.Time -> Outline.PkgOutline -> Task.Task Details
156+solvePkg info time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
234157 if Con.goodElm elm
235158 then
236− do solution <- verifyConstraints env =<< union noDups direct testDirect
237− let exposedList = Outline.flattenExposed exposed
238− let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
239− verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
159+ do solution <- solve info =<< union noDups direct testDirect
160+ foreigns <- verifyDependencies info solution direct
161+ let vsns = Map.map (\(Solver.Details v _) -> v) solution
162+ return $ Details time (ValidPkg outline vsns) Map.empty foreigns
240163 else
241164 Task.throw $ Exit.DetailsBadElmInPkg elm
242165
243166
244−verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
245−verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
167+
168+-- SOLVE APP
169+
170+
171+solveApp :: Info -> File.Time -> Outline.AppOutline -> Task.Task Details
172+solveApp info time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
246173 if elmVersion == V.compiler
247174 then
248175 do stated <- checkAppDeps outline
249− actual <- verifyConstraints env (Map.map Con.exactly stated)
176+ actual <- solve info (Map.map Con.exactly stated)
250177 if Map.size stated == Map.size actual
251− then verifyDependencies env time (ValidApp srcDirs) actual direct
252− else Task.throw $ Exit.DetailsHandEditedDependencies
178+ then
179+ do foreigns <- verifyDependencies info actual direct
180+ return $ Details time (ValidApp outline) Map.empty foreigns
181+ else
182+ Task.throw $ error "TODO solveApp"
253183 else
254− Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
184+ Task.throw $ Exit.DetailsBadElmInApp elmVersion
255185
256186
257−checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
187+checkAppDeps :: Outline.AppOutline -> Task.Task (Map.Map Pkg.Name V.Version)
258188checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
259189 do x <- union allowEqualDups indirect testDirect
260190 y <- union noDups direct testIndirect
@@ -262,34 +192,32 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
262192
263193
264194
265−-- VERIFY CONSTRAINTS
195+-- SOLVE
266196
267197
268−verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
269−verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
270− do result <- Task.io $ Solver.verify cache connection registry constraints
271− case result of
272− Solver.Ok details -> return details
273− Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution
274− Solver.NoOfflineSolution -> Task.throw $ Exit.DetailsNoOfflineSolution
275− Solver.Err exit -> Task.throw $ Exit.DetailsSolverProblem exit
198+solve :: Info -> Map.Map Pkg.Name Con.Constraint -> Task.Task (Map.Map Pkg.Name Solver.Details)
199+solve (Info cache manager connection registry) constraints =
200+ Task.eio (error "TODO solve problem") $
201+ case connection of
202+ Online -> Solver.online cache manager registry constraints
203+ Offline -> Solver.offline cache registry constraints
276204
277205
278206
279207-- UNION
280208
281209
282−union :: (Ord k) => (k -> v -> v -> Task v) -> Map.Map k v -> Map.Map k v -> Task (Map.Map k v)
210+union :: (Ord k) => (k -> v -> v -> Task.Task v) -> Map.Map k v -> Map.Map k v -> Task.Task (Map.Map k v)
283211union tieBreaker deps1 deps2 =
284212 Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
285213
286214
287−noDups :: k -> v -> v -> Task v
215+noDups :: k -> v -> v -> Task.Task v
288216noDups _ _ _ =
289217 Task.throw Exit.DetailsHandEditedDependencies
290218
291219
292−allowEqualDups :: (Eq v) => k -> v -> v -> Task v
220+allowEqualDups :: (Eq v) => k -> v -> v -> Task.Task v
293221allowEqualDups _ v1 v2 =
294222 if v1 == v2
295223 then return v1
@@ -311,42 +239,36 @@ fork work =
311239-- VERIFY DEPENDENCIES
312240
313241
314−verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
315−verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
316− Task.eio id $
317− do Reporting.report key (Reporting.DStart (Map.size solution))
318− mvar <- newEmptyMVar
319− mvars <- Stuff.withRegistryLock cache $
320− Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
242+verifyDependencies :: Info -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task.Task (Map.Map ModuleName.Raw Foreign)
243+verifyDependencies info solution directDeps =
244+ Task.eio (error "TODO verifyDependencies") $
245+ do mvar <- newEmptyMVar
246+ mvars <- Map.traverseWithKey (\k v -> fork (verifyDep info mvar solution k v)) solution
321247 putMVar mvar mvars
322− deps <- traverse readMVar mvars
323− case sequence deps of
248+ results <- traverse readMVar mvars
249+ case sequence results of
324250 Left _ ->
325− do home <- Stuff.getElmHome
326− return $ Left $ Exit.DetailsBadDeps home $
327− Maybe.catMaybes $ Either.lefts $ Map.elems deps
251+ return (Left (error "TODO one of the dependencies did not build"))
328252
329253 Right artifacts ->
330254 let
331− objs = Map.foldr addObjects Opt.empty artifacts
332− ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
333− foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps
334− details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
255+ objs = Map.foldr gatherObjects Opt.empty artifacts
256+ ifaces = Map.foldrWithKey (gatherInterfaces directDeps) Map.empty artifacts
257+ foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
335258 in
336− do BW.writeBinary scope (Stuff.objects root) objs
337− BW.writeBinary scope (Stuff.interfaces root) ifaces
338− BW.writeBinary scope (Stuff.details root) details
339− return (Right details)
259+ do File.writeBinary Stuff.objects objs
260+ File.writeBinary Stuff.interfaces ifaces
261+ return (Right foreigns)
340262
341263
342−addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph
343−addObjects (Artifacts _ objs) graph =
344− Opt.addGlobalGraph objs graph
264+gatherObjects :: Artifacts -> Opt.Graph -> Opt.Graph
265+gatherObjects (Artifacts _ objs) graph =
266+ Opt.union objs graph
345267
346268
347−addInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces
348−addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
349− Map.union dependencyInterfaces $ Map.mapKeysMonotonic (ModuleName.Canonical pkg) $
269+gatherInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Canonical I.DependencyInterface
270+gatherInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
271+ Map.union dependencyInterfaces $ Map.mapKeys (ModuleName.Canonical pkg) $
350272 if Map.member pkg directDeps
351273 then ifaces
352274 else Map.map I.privatize ifaces
@@ -357,8 +279,8 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns =
357279 let
358280 isPublic di =
359281 case di of
360− I.Public _ -> Just (OneOrMore.one pkg)
361− I.Private _ _ _ -> Nothing
282+ I.Public _ -> Just (OneOrMore.one pkg)
283+ I.Private _ _ -> Nothing
362284 in
363285 Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
364286
@@ -370,41 +292,42 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns =
370292data Artifacts =
371293 Artifacts
372294 { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
373− , _objects :: Opt.GlobalGraph
295+ , _objects :: Opt.Graph
374296 }
375297
376298
377−type Dep =
378− Either (Maybe Exit.DetailsBadDep) Artifacts
299+type Result =
300+ Either Problem Artifacts
301+
302+
303+data Problem
304+ = BadDownload Exit.PackageProblem
305+ | BadBuild
306+ | BadDependency
379307
380308
381−verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
382−verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
383− do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
384− exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
309+verifyDep :: Info -> MVar (Map.Map Pkg.Name (MVar Result)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Result
310+verifyDep (Info cache manager _ _) resultsMVar solution name details@(Solver.Details version directDeps) =
311+ let
312+ fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
313+ in
314+ do exists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
385315 if exists
386316 then
387− do Reporting.report key Reporting.DCached
388− maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
317+ do maybeCache <- File.readBinary (Stuff.package cache name version </> "artifacts.dat")
389318 case maybeCache of
390319 Nothing ->
391− build key cache depsMVar pkg details fingerprint Set.empty
320+ build cache resultsMVar name details (Set.singleton fingerprint)
392321
393322 Just (ArtifactCache fingerprints artifacts) ->
394323 if Set.member fingerprint fingerprints
395− then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
396− else build key cache depsMVar pkg details fingerprint fingerprints
324+ then return (Right artifacts)
325+ else build cache resultsMVar name details (Set.insert fingerprint fingerprints)
397326 else
398− do Reporting.report key Reporting.DRequested
399− result <- downloadPackage cache manager pkg vsn
327+ do result <- downloadPackage cache manager name version
400328 case result of
401− Left problem ->
402− do Reporting.report key (Reporting.DFailed pkg vsn)
403− return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
404−
405− Right () ->
406− do Reporting.report key (Reporting.DReceived pkg vsn)
407− build key cache depsMVar pkg details fingerprint Set.empty
329+ Left p -> return (Left (BadDownload p))
330+ Right () -> build cache resultsMVar name details (Set.singleton fingerprint)
408331
409332
410333
@@ -426,104 +349,65 @@ type Fingerprint =
426349-- BUILD
427350
428351
429−build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
430−build key cache depsMVar pkg (Solver.Details vsn _) f fs =
431− do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
352+build :: Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Result)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Result
353+build cache resultsMVar name (Solver.Details version _) fingerprints =
354+ do eitherOutline <- Outline.read (Stuff.package cache name version </> "elm.json")
432355 case eitherOutline of
433356 Left _ ->
434− do Reporting.report key Reporting.DBroken
435− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
357+ return (Left BadBuild)
436358
437359 Right (Outline.App _) ->
438− do Reporting.report key Reporting.DBroken
439− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
360+ return (Left BadBuild)
440361
441362 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
442− do allDeps <- readMVar depsMVar
443− directDeps <- traverse readMVar (Map.intersection allDeps deps)
444− case sequence directDeps of
363+ do allResults <- readMVar resultsMVar
364+ directResults <- traverse readMVar (Map.intersection allResults deps)
365+ case sequence directResults of
445366 Left _ ->
446− do Reporting.report key Reporting.DBroken
447− return $ Left $ Nothing
367+ return (Left BadDependency)
448368
449369 Right directArtifacts ->
450− do let src = Stuff.package cache pkg vsn </> "src"
370+ do mvar <- newMVar Map.empty
371+ let src = Stuff.package cache name version </> "src"
451372 let foreignDeps = gatherForeignInterfaces directArtifacts
452− let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
453− docsStatus <- getDocsStatus cache pkg vsn
454− mvar <- newEmptyMVar
455− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
456− putMVar mvar mvars
457− mapM_ readMVar mvars
458− maybeStatuses <- traverse readMVar =<< readMVar mvar
459− case sequence maybeStatuses of
373+ let exposedDict = Map.fromList $ map (\n -> (n,())) (Outline.flattenExposed exposed)
374+ traverse_ readMVar =<<
375+ Map.traverseWithKey (const . fork . buildModule foreignDeps mvar name src) exposedDict
376+ result <- traverse readMVar =<< readMVar mvar
377+ case Map.traverseMaybeWithKey checkStatus result of
460378 Nothing ->
461− do Reporting.report key Reporting.DBroken
462− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
463−
464− Just statuses ->
465− do rmvar <- newEmptyMVar
466− rmvars <- traverse (fork . compile pkg rmvar) statuses
467− putMVar rmvar rmvars
468− maybeResults <- traverse readMVar rmvars
469− case sequence maybeResults of
470− Nothing ->
471− do Reporting.report key Reporting.DBroken
472− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
473−
474− Just results ->
475− let
476− path = Stuff.package cache pkg vsn </> "artifacts.dat"
477− ifaces = gatherInterfaces exposedDict results
478− objects = gatherObjects results
479− artifacts = Artifacts ifaces objects
480− fingerprints = Set.insert f fs
481− in
482− do writeDocs cache pkg vsn docsStatus results
483− File.writeBinary path (ArtifactCache fingerprints artifacts)
484− Reporting.report key Reporting.DBuilt
485− return (Right artifacts)
486−
379+ return (Left BadBuild)
487380
381+ Just artifactsDict ->
382+ let
383+ path = Stuff.package cache name version </> "artifacts.dat"
384+ ifaces = gatherPackageInterfaces exposedDict artifactsDict
385+ objects = Map.foldr (Opt.union . snd) Opt.empty artifactsDict
386+ artifacts = Artifacts ifaces objects
387+ in
388+ do File.writeBinary path (ArtifactCache fingerprints artifacts)
389+ return (Right artifacts)
488390
489−-- GATHER
490391
491−
492−gatherObjects :: Map.Map ModuleName.Raw Result -> Opt.GlobalGraph
493−gatherObjects results =
494− Map.foldrWithKey addLocalGraph Opt.empty results
495−
496−
497−addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
498−addLocalGraph name status graph =
392+checkStatus :: ModuleName.Raw -> Status -> Maybe (Maybe (I.Interface, Opt.Graph))
393+checkStatus _ status =
499394 case status of
500− RLocal _ objs _ -> Opt.addLocalGraph objs graph
501− RForeign _ -> graph
502− RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
503− RKernelForeign -> graph
504−
505−
506−gatherInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw Result -> Map.Map ModuleName.Raw I.DependencyInterface
507−gatherInterfaces exposed artifacts =
508− let
509− onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherInterfaces")
510− onRight = Map.mapMaybeMissing (\_ iface -> toLocalInterface I.private iface)
511− onBoth = Map.zipWithMaybeMatched (\_ () iface -> toLocalInterface I.public iface)
512− in
513− Map.merge onLeft onRight onBoth exposed artifacts
395+ SFailure -> Nothing
396+ SLocal i g -> Just (Just (i,g))
397+ SForeign _ -> Just Nothing
514398
515399
516−toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
517−toLocalInterface func result =
518− case result of
519− RLocal iface _ _ -> Just (func iface)
520− RForeign _ -> Nothing
521− RKernelLocal _ -> Nothing
522− RKernelForeign -> Nothing
400+gatherPackageInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw (I.Interface, Opt.Graph) -> Map.Map ModuleName.Raw I.DependencyInterface
401+gatherPackageInterfaces exposed artifacts =
402+ Map.merge onLeft onRight onBoth exposed artifacts
403+ where
404+ onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherPackageInterfaces")
405+ onRight = Map.mapMissing (\_ (i,_) -> I.private i)
406+ onBoth = Map.zipWithMatched (\_ () (i,_) -> I.public i)
523407
524408
525409
526−-- GATHER FOREIGN INTERFACES
410+-- FOREIGN INTERFACES
527411
528412
529413data ForeignInterface
@@ -549,196 +433,72 @@ gatherForeignInterfaces directArtifacts =
549433 isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
550434 isPublic di =
551435 case di of
552− I.Public iface -> Just (OneOrMore.one iface)
553− I.Private _ _ _ -> Nothing
436+ I.Public iface -> Just (OneOrMore.one iface)
437+ I.Private _ _ -> Nothing
554438
555439
556440
557−-- CRAWL
441+-- BUILD MODULE
558442
559443
560444type StatusDict =
561− Map.Map ModuleName.Raw (MVar (Maybe Status))
445+ Map.Map ModuleName.Raw (MVar Status)
562446
563447
564448data Status
565− = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
449+ = SLocal !I.Interface !Opt.Graph
566450 | SForeign I.Interface
567− | SKernelLocal [Kernel.Chunk]
568− | SKernelForeign
451+ | SFailure
569452
570453
571−crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status)
572−crawlModule foreignDeps mvar pkg src docsStatus name =
454+buildModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO Status
455+buildModule foreignDeps mvar pkg src name =
573456 do let path = src </> ModuleName.toFilePath name <.> "elm"
574457 exists <- File.exists path
575458 case Map.lookup name foreignDeps of
576459 Just ForeignAmbiguous ->
577− return Nothing
460+ return SFailure
578461
579462 Just (ForeignSpecific iface) ->
580463 if exists
581− then return Nothing
582− else return (Just (SForeign iface))
464+ then return SFailure
465+ else return (SForeign iface)
583466
584467 Nothing ->
585− if exists then
586− crawlFile foreignDeps mvar pkg src docsStatus name path
587−
588− else if Pkg.isKernel pkg && Name.isKernel name then
589− crawlKernel foreignDeps mvar pkg src name
590−
468+ if not exists
469+ then return SFailure
591470 else
592− return Nothing
593−
594−
595−crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
596−crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
597− do bytes <- File.readUtf8 path
598− case Parse.fromByteString (Parse.Package pkg) bytes of
599− Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
600− do deps <- crawlImports foreignDeps mvar pkg src imports
601− return (Just (SLocal docsStatus deps modul))
602−
603− _ ->
604− return Nothing
605−
606−
607−crawlImports :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> [Src.Import] -> IO (Map.Map ModuleName.Raw ())
608−crawlImports foreignDeps mvar pkg src imports =
609− do statusDict <- takeMVar mvar
610− let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
611− let news = Map.difference deps statusDict
612− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news
613− putMVar mvar (Map.union mvars statusDict)
614− mapM_ readMVar mvars
615− return deps
616−
617−
618−crawlKernel :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)
619−crawlKernel foreignDeps mvar pkg src name =
620− do let path = src </> ModuleName.toFilePath name <.> "js"
621− exists <- File.exists path
622− if exists
623− then
624− do bytes <- File.readUtf8 path
625− case Kernel.fromByteString pkg (Map.mapMaybe getDepHome foreignDeps) bytes of
626− Nothing ->
627− return Nothing
628−
629− Just (Kernel.Content imports chunks) ->
630− do _ <- crawlImports foreignDeps mvar pkg src imports
631− return (Just (SKernelLocal chunks))
632− else
633− return (Just SKernelForeign)
634−
635−
636−getDepHome :: ForeignInterface -> Maybe Pkg.Name
637−getDepHome fi =
638− case fi of
639− ForeignSpecific (I.Interface pkg _ _ _ _) -> Just pkg
640− ForeignAmbiguous -> Nothing
641−
642−
643−
644−-- COMPILE
645−
646−
647−data Result
648− = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)
649− | RForeign I.Interface
650− | RKernelLocal [Kernel.Chunk]
651− | RKernelForeign
652−
653−
654−compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
655−compile pkg mvar status =
471+ do result <- Parse.fromFile pkg path
472+ case result of
473+ Right modul@(Src.Module (Just actualName) _ deps _ _ _ _ _) | name == actualName ->
474+ do statusDict <- takeMVar mvar
475+ let depsDict = Map.fromList $ map (\i -> (Src.getImport i, ())) deps
476+ let newsDict = Map.difference depsDict statusDict
477+ statusMVars <- Map.traverseWithKey (const . fork . buildModule foreignDeps mvar pkg src) newsDict
478+ putMVar mvar (Map.union statusMVars statusDict)
479+ statuses <- traverse readMVar statusMVars
480+ case traverse getInterface statuses of
481+ Nothing ->
482+ return SFailure
483+
484+ Just imports ->
485+ case Compile.compile pkg imports modul of
486+ (_, Right (Compile.Artifacts canonical annotations objects)) ->
487+ return (SLocal (I.fromModule pkg canonical annotations) objects)
488+
489+ (_, Left _) ->
490+ return SFailure
491+
492+ _ ->
493+ return SFailure
494+
495+
496+getInterface :: Status -> Maybe I.Interface
497+getInterface status =
656498 case status of
657− SLocal docsStatus deps modul ->
658− do resultsDict <- readMVar mvar
659− maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
660− case sequence maybeResults of
661− Nothing ->
662− return Nothing
663−
664− Just results ->
665− case Compile.compile pkg (Map.mapMaybe getInterface results) modul of
666− Left _ ->
667− return Nothing
668−
669− Right (Compile.Artifacts canonical annotations objects) ->
670− let
671− ifaces = I.fromModule pkg canonical annotations
672− docs = makeDocs docsStatus canonical
673− in
674− return (Just (RLocal ifaces objects docs))
675−
676− SForeign iface ->
677− return (Just (RForeign iface))
678−
679− SKernelLocal chunks ->
680− return (Just (RKernelLocal chunks))
681−
682− SKernelForeign ->
683− return (Just RKernelForeign)
684−
685−
686−getInterface :: Result -> Maybe I.Interface
687−getInterface result =
688− case result of
689− RLocal iface _ _ -> Just iface
690− RForeign iface -> Just iface
691− RKernelLocal _ -> Nothing
692− RKernelForeign -> Nothing
693−
694−
695−
696−-- MAKE DOCS
697−
698−
699−data DocsStatus
700− = DocsNeeded
701− | DocsNotNeeded
702−
703−
704−getDocsStatus :: Stuff.PackageCache -> Pkg.Name -> V.Version -> IO DocsStatus
705−getDocsStatus cache pkg vsn =
706− do exists <- File.exists (Stuff.package cache pkg vsn </> "docs.json")
707− if exists
708− then return DocsNotNeeded
709− else return DocsNeeded
710−
711−
712−makeDocs :: DocsStatus -> Can.Module -> Maybe Docs.Module
713−makeDocs status modul =
714− case status of
715− DocsNeeded ->
716− case Docs.fromModule modul of
717− Right docs -> Just docs
718− Left _ -> Nothing
719−
720− DocsNotNeeded ->
721− Nothing
722−
723−
724−writeDocs :: Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO ()
725−writeDocs cache pkg vsn status results =
726− case status of
727− DocsNeeded ->
728− E.writeUgly (Stuff.package cache pkg vsn </> "docs.json") $
729− Docs.encode $ Map.mapMaybe toDocs results
730−
731− DocsNotNeeded ->
732− return ()
733−
734−
735−toDocs :: Result -> Maybe Docs.Module
736−toDocs result =
737− case result of
738− RLocal _ _ docs -> docs
739− RForeign _ -> Nothing
740− RKernelLocal _ -> Nothing
741− RKernelForeign -> Nothing
499+ SLocal iface _ -> Just iface
500+ SForeign iface -> Just iface
501+ SFailure -> Nothing
742502
743503
744504
@@ -746,28 +506,25 @@ toDocs result =
746506
747507
748508downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
749−downloadPackage cache manager pkg vsn =
750− let
751− url = Website.metadata pkg vsn "endpoint.json"
752− in
509+downloadPackage cache manager name version =
753510 do eitherByteString <-
754− Http.get manager url [] id (return . Right)
511+ Http.post manager (Website.metadata name version "endpoint.json") [] id (return . Right)
755512
756513 case eitherByteString of
757514 Left err ->
758− return $ Left $ Exit.PP_BadEndpointRequest err
515+ return (Left (Exit.PP_BadEndpointRequest err))
759516
760517 Right byteString ->
761518 case D.fromByteString endpointDecoder byteString of
762519 Left _ ->
763− return $ Left $ Exit.PP_BadEndpointContent url
520+ return (Left Exit.PP_BadEndpointContent)
764521
765522 Right (endpoint, expectedHash) ->
766− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
523+ Http.fetchArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
767524 \(sha, archive) ->
768525 if expectedHash == Http.shaToChars sha
769− then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
770− else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
526+ then Right <$> File.writeArchive (Stuff.package cache name version) archive
527+ else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
771528
772529
773530endpointDecoder :: D.Decoder e (String, String)
@@ -782,40 +539,27 @@ endpointDecoder =
782539
783540
784541instance Binary Details where
785− put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
786− get =
787− do a <- get
788− b <- get
789− c <- get
790− d <- get
791− e <- get
792− return (Details a b c d e ArtifactsCached)
542+ get = liftM4 Details get get get get
543+ put (Details a b c d) = put a >> put b >> put c >> put d
793544
794545
795546instance Binary ValidOutline where
796547 put outline =
797548 case outline of
798− ValidApp a -> putWord8 0 >> put a
799− ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
549+ ValidApp a -> putWord8 0 >> put a
550+ ValidPkg a b -> putWord8 1 >> put a >> put b
800551
801552 get =
802553 do n <- getWord8
803554 case n of
804555 0 -> liftM ValidApp get
805− 1 -> liftM3 ValidPkg get get get
806− _ -> fail "binary encoding of ValidOutline was corrupted"
556+ 1 -> liftM2 ValidPkg get get
557+ _ -> error "binary encoding of ValidOutline was corrupted"
807558
808559
809560instance Binary Local where
810− put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
811− get =
812− do a <- get
813− b <- get
814− c <- get
815− d <- get
816− e <- get
817− f <- get
818− return (Local a b c d e f)
561+ get = liftM3 Local get get get
562+ put (Local a b c) = put a >> put b >> put c
819563
820564
821565instance Binary Foreign where
builder/src/Elm/Diff.hsnew file+284
@@ -0,0 +1,284 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Diff
4+ ( Args(..)
5+ , diff
6+ )
7+ where
8+
9+
10+import Control.Monad.Except (liftIO)
11+import qualified Data.List as List
12+import qualified Data.Map as Map
13+import qualified Data.Maybe as Maybe
14+import qualified Data.Name as Name
15+
16+import qualified Deps.Cache as Cache
17+import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
18+import qualified Deps.Diff as Diff
19+import qualified Elm.Compiler.Type as Type
20+import qualified Elm.Docs as Docs
21+import qualified Elm.ModuleName as ModuleName
22+import qualified Elm.Package as Pkg
23+import qualified Elm.Project as Project
24+import qualified Elm.Project.Json as Project
25+import qualified Elm.Project.Summary as Summary
26+import qualified Elm.Version as V
27+import Reporting.Doc ((<>), (<+>))
28+import qualified Reporting.Doc as D
29+import qualified Reporting.Exit as Exit
30+import qualified Reporting.Exit.Diff as E
31+import qualified Reporting.Exit.Help as Help
32+import qualified Reporting.Render.Type.Localizer as L
33+import qualified Reporting.Task as Task
34+
35+
36+
37+-- DIFF
38+
39+
40+data Args
41+ = CodeVsLatest
42+ | CodeVsExactly V.Version
43+ | LocalInquiry V.Version V.Version
44+ | GlobalInquiry Pkg.Name V.Version V.Version
45+
46+
47+diff :: Args -> Task.Task ()
48+diff args =
49+ case args of
50+ GlobalInquiry name v1 v2 ->
51+ do registry <- Cache.mandatoryUpdate
52+ case Cache.getVersions name registry of
53+ Left suggestions ->
54+ throw $ E.UnknownPackage name suggestions
55+
56+ Right vsns ->
57+ do oldDocs <- getDocs name vsns (min v1 v2)
58+ newDocs <- getDocs name vsns (max v1 v2)
59+ writeDiff oldDocs newDocs
60+
61+ LocalInquiry v1 v2 ->
62+ do (_, name, vsns) <- getPackageInfo
63+ oldDocs <- getDocs name vsns (min v1 v2)
64+ newDocs <- getDocs name vsns (max v1 v2)
65+ writeDiff oldDocs newDocs
66+
67+ CodeVsLatest ->
68+ do (summary, name, vsns) <- getPackageInfo
69+ oldDocs <- getDocs name vsns (maximum vsns)
70+ newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
71+ writeDiff oldDocs newDocs
72+
73+ CodeVsExactly version ->
74+ do (summary, name, vsns) <- getPackageInfo
75+ oldDocs <- getDocs name vsns version
76+ newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
77+ writeDiff oldDocs newDocs
78+
79+
80+throw :: E.Exit -> Task.Task a
81+throw exit =
82+ Task.throw $ Exit.Diff exit
83+
84+
85+
86+-- DIFF HELPERS
87+
88+
89+getDocs :: Pkg.Name -> [V.Version] -> V.Version -> Task.Task Docs.Documentation
90+getDocs name allVersions version =
91+ if elem version allVersions then
92+ Cache.getDocs name version
93+ else
94+ throw $ E.UnknownVersion name version allVersions
95+
96+
97+getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [V.Version])
98+getPackageInfo =
99+ do summary <- Project.getRoot
100+ case Summary._project summary of
101+ Project.App _ ->
102+ throw $ E.Application
103+
104+ Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
105+ do registry <- Cache.mandatoryUpdate
106+ case Cache.getVersions name registry of
107+ Right vsns ->
108+ return ( summary, name, vsns )
109+
110+ Left _ ->
111+ throw E.Unpublished
112+
113+
114+
115+-- WRITE DOC
116+
117+
118+writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()
119+writeDiff oldDocs newDocs =
120+ let
121+ changes = Diff.diff oldDocs newDocs
122+ localizer = L.fromNames (Map.union oldDocs newDocs)
123+ in
124+ liftIO $ Help.toStdout (toDoc localizer changes <> "\n")
125+
126+
127+
128+-- TO DOC
129+
130+
131+toDoc :: L.Localizer -> PackageChanges -> D.Doc
132+toDoc localizer changes@(PackageChanges added changed removed) =
133+ if null added && Map.null changed && null removed then
134+ "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
135+ else
136+ let
137+ magDoc =
138+ D.fromChars (Diff.magnitudeToString (Diff.toMagnitude changes))
139+
140+ header =
141+ "This is a" <+> D.green magDoc <+> "change."
142+
143+ addedChunk =
144+ if null added then [] else
145+ [ Chunk "ADDED MODULES" MINOR $
146+ D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) added
147+ ]
148+
149+ removedChunk =
150+ if null removed then [] else
151+ [ Chunk "REMOVED MODULES" MAJOR $
152+ D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) removed
153+ ]
154+
155+ chunks =
156+ addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
157+ in
158+ D.vcat (header : "" : map chunkToDoc chunks)
159+
160+
161+data Chunk =
162+ Chunk
163+ { _title :: String
164+ , _magnitude :: Magnitude
165+ , _details :: D.Doc
166+ }
167+
168+
169+chunkToDoc :: Chunk -> D.Doc
170+chunkToDoc (Chunk title magnitude details) =
171+ let
172+ magDoc =
173+ Diff.magnitudeToString magnitude
174+
175+ header =
176+ "----" <+> D.fromChars title <+> "-" <+> D.fromChars magDoc <+> "----"
177+ in
178+ D.vcat
179+ [ D.dullcyan header
180+ , ""
181+ , D.indent 4 details
182+ , ""
183+ , ""
184+ ]
185+
186+
187+changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
188+changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
189+ let
190+ magnitude =
191+ Diff.moduleChangeMagnitude changes
192+
193+ (unionAdd, unionChange, unionRemove) =
194+ changesToDocTriple (unionToDoc localizer) unions
195+
196+ (aliasAdd, aliasChange, aliasRemove) =
197+ changesToDocTriple (aliasToDoc localizer) aliases
198+
199+ (valueAdd, valueChange, valueRemove) =
200+ changesToDocTriple (valueToDoc localizer) values
201+
202+ (binopAdd, binopChange, binopRemove) =
203+ changesToDocTriple (binopToDoc localizer) binops
204+ in
205+ Chunk (Name.toChars name) magnitude $
206+ D.vcat $ List.intersperse "" $ Maybe.catMaybes $
207+ [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
208+ , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
209+ , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
210+ ]
211+
212+
213+changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
214+changesToDocTriple entryToDoc (Changes added changed removed) =
215+ let
216+ indented (name, value) =
217+ D.indent 4 (entryToDoc name value)
218+
219+ diffed (name, (oldValue, newValue)) =
220+ D.vcat
221+ [ " - " <> entryToDoc name oldValue
222+ , " + " <> entryToDoc name newValue
223+ , ""
224+ ]
225+ in
226+ ( map indented (Map.toList added)
227+ , map diffed (Map.toList changed)
228+ , map indented (Map.toList removed)
229+ )
230+
231+
232+changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
233+changesToDoc categoryName unions aliases values binops =
234+ if null unions && null aliases && null values && null binops then
235+ Nothing
236+
237+ else
238+ Just $ D.vcat $
239+ D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
240+
241+
242+unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
243+unionToDoc localizer name (Docs.Union _ tvars ctors) =
244+ let
245+ setup =
246+ "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
247+
248+ ctorDoc (ctor, tipes) =
249+ typeDoc localizer (Type.Type ctor tipes)
250+ in
251+ D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
252+
253+
254+aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
255+aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
256+ let
257+ declaration =
258+ "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
259+ in
260+ D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
261+
262+
263+valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
264+valueToDoc localizer name (Docs.Value _ tipe) =
265+ D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
266+
267+
268+binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
269+binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
270+ "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
271+ where
272+ details =
273+ " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
274+
275+ assoc =
276+ case associativity of
277+ Docs.Left -> "left"
278+ Docs.Non -> "non"
279+ Docs.Right -> "right"
280+
281+
282+typeDoc :: L.Localizer -> Type.Type -> D.Doc
283+typeDoc localizer tipe =
284+ Type.toDoc localizer Type.None tipe
builder/src/Elm/Install.hsnew file+448
@@ -0,0 +1,448 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Install
3+ ( install
4+ )
5+ where
6+
7+
8+import Control.Monad (filterM, foldM, forM, msum, void)
9+import Control.Monad.Except (catchError, lift, liftIO)
10+import Data.Map ((!))
11+import qualified Data.Map as Map
12+import qualified Data.Map.Merge.Lazy as Map
13+
14+import qualified Elm.Package as Pkg
15+
16+import qualified Deps.Cache as Cache
17+import Deps.Explorer (Explorer)
18+import qualified Deps.Explorer as Explorer
19+import qualified Deps.Verify as Verify
20+import qualified Deps.Solver as Solver
21+import qualified Elm.Constraint as C
22+import qualified Elm.Project.Json as Project
23+import qualified Elm.Project.Root as Root
24+import qualified Elm.Version as V
25+import Reporting.Doc ((<>), (<+>))
26+import qualified Reporting.Doc as D
27+import qualified Reporting.Exit as Exit
28+import qualified Reporting.Exit.Install as E
29+import qualified Reporting.Task as Task
30+
31+
32+
33+-- INSTALL
34+
35+
36+install :: Pkg.Name -> Task.Task ()
37+install pkg =
38+ do (root, oldProject) <- Root.unsafeGet
39+ registry <- Cache.optionalUpdate
40+
41+ case oldProject of
42+ Project.App info ->
43+ do changes <- makeAppPlan registry pkg info
44+ attemptElmJsonChange root oldProject V.toChars changes
45+
46+ Project.Pkg info ->
47+ do changes <- makePkgPlan registry pkg info
48+ attemptElmJsonChange root oldProject C.toChars changes
49+
50+
51+attemptElmJsonChange :: FilePath -> Project.Project -> (a -> String) -> Changes a -> Task.Task ()
52+attemptElmJsonChange root oldProject toChars changes =
53+ let
54+ attempt newProject question =
55+ do approved <- Task.getApproval question
56+ if approved
57+ then upgrade newProject `catchError` revert
58+ else liftIO $ putStrLn "Okay, I did not change anything!"
59+
60+ upgrade newProject =
61+ do liftIO $ Project.write root newProject
62+ void $ Verify.verify root newProject
63+
64+ revert err =
65+ do liftIO $ Project.write root oldProject
66+ Task.throw err
67+ in
68+ case changes of
69+ AlreadyInstalled ->
70+ do liftIO $ putStrLn "It is already installed!"
71+
72+ PromoteTrans newProject ->
73+ attempt newProject $
74+ D.vcat
75+ [ D.fillSep
76+ ["I","found","it","in","your","elm.json","file,"
77+ ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."
78+ ]
79+ , D.fillSep
80+ ["Should","I","move","it","into",D.green "\"direct\""
81+ ,"dependencies","for","more","general","use?","[Y/n]: "
82+ ]
83+ ]
84+
85+ PromoteTest newProject ->
86+ attempt newProject $
87+ D.vcat
88+ [ D.fillSep
89+ ["I","found","it","in","your","elm.json","file,"
90+ ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."
91+ ]
92+ , D.fillSep
93+ ["Should","I","move","it","into",D.green "\"dependencies\""
94+ ,"for","more","general","use?","[Y/n]: "
95+ ]
96+ ]
97+
98+ Changes changeDict newProject ->
99+ let
100+ widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
101+ changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict
102+ in
103+ attempt newProject $ D.vcat $
104+ [ "Here is my plan:"
105+ , viewChangeDocs changeDocs
106+ , ""
107+ , "Would you like me to update your elm.json accordingly? [Y/n]: "
108+ ]
109+
110+
111+
112+-- MAKE PLANS
113+
114+
115+data Changes vsn
116+ = AlreadyInstalled
117+ | PromoteTest Project.Project
118+ | PromoteTrans Project.Project
119+ | Changes (Map.Map Pkg.Name (Change vsn)) Project.Project
120+
121+
122+makeAppPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Changes V.Version)
123+makeAppPlan registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
124+ if Map.member pkg depsDirect then
125+ return AlreadyInstalled
126+ else
127+ do (AppAnswer old new newInfo) <- toAppAnswer registry pkg info
128+
129+ return $
130+ if Map.member pkg depsTrans then
131+ PromoteTrans (Project.App newInfo)
132+
133+ else if Map.member pkg testDirect || Map.member pkg testTrans then
134+ PromoteTest (Project.App newInfo)
135+
136+ else
137+ Changes (detectChanges old new) (Project.App newInfo)
138+
139+
140+makePkgPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Changes C.Constraint)
141+makePkgPlan registry pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) =
142+ if Map.member pkg deps then
143+ return AlreadyInstalled
144+ else
145+ case Map.lookup pkg test of
146+ Just con ->
147+ return $ PromoteTest $ Project.Pkg $
148+ info
149+ { Project._pkg_deps = Map.insert pkg con deps
150+ , Project._pkg_test_deps = Map.delete pkg test
151+ }
152+
153+ Nothing ->
154+ do changes <- addToPkg registry pkg info
155+ let news = Map.mapMaybe keepNew changes
156+ return $ Changes changes $ Project.Pkg $
157+ info
158+ { Project._pkg_deps = addNews (Just pkg) news deps
159+ , Project._pkg_test_deps = addNews Nothing news test
160+ }
161+
162+
163+addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a
164+addNews pkg new old =
165+ Map.merge
166+ Map.preserveMissing
167+ (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))
168+ (Map.zipWithMatched (\_ _ n -> n))
169+ old
170+ new
171+
172+
173+
174+-- CHANGES
175+
176+
177+data Change a
178+ = Insert a
179+ | Change a a
180+ | Remove a
181+
182+
183+detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
184+detectChanges old new =
185+ Map.merge
186+ (Map.mapMissing (\_ v -> Remove v))
187+ (Map.mapMissing (\_ v -> Insert v))
188+ (Map.zipWithMaybeMatched keepChange)
189+ old
190+ new
191+
192+
193+keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
194+keepChange _ old new =
195+ if old == new then
196+ Nothing
197+ else
198+ Just (Change old new)
199+
200+
201+keepNew :: Change a -> Maybe a
202+keepNew change =
203+ case change of
204+ Insert a ->
205+ Just a
206+
207+ Change _ a ->
208+ Just a
209+
210+ Remove _ ->
211+ Nothing
212+
213+
214+
215+-- ADD TO APP
216+
217+
218+data AppAnswer =
219+ AppAnswer
220+ { _old :: Map.Map Pkg.Name V.Version
221+ , _new :: Map.Map Pkg.Name V.Version
222+ , _info :: Project.AppInfo
223+ }
224+
225+
226+toAppAnswer :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task AppAnswer
227+toAppAnswer registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
228+ Explorer.run registry $
229+ do Explorer.exists pkg
230+ result <- Solver.run (toAppAnswerHelp pkg info)
231+ case result of
232+ Just answer ->
233+ return answer
234+
235+ Nothing ->
236+ do badNames <-
237+ filterM isBadElm $
238+ pkg : Map.keys depsDirect
239+ ++ Map.keys depsTrans
240+ ++ Map.keys testDirect
241+ ++ Map.keys testTrans
242+ lift $ Task.throw (Exit.Install (E.NoSolution badNames))
243+
244+
245+toAppAnswerHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver AppAnswer
246+toAppAnswerHelp pkg (Project.AppInfo elm srcDirs depsDirect depsTrans testDirect testTrans) =
247+ let
248+ directs =
249+ Map.union depsDirect testDirect
250+
251+ directAndTrans =
252+ Map.union directs (Map.union depsTrans testTrans)
253+
254+ try toConstraint deps =
255+ do solution <- Solver.solve $ Map.insert pkg C.anything (Map.map toConstraint deps)
256+ let newDepsDirect = Map.intersection solution (Map.insert pkg V.one depsDirect)
257+ newDeps <- lift $ foldM (collectTransitive solution) Map.empty (Map.keys newDepsDirect)
258+ return $
259+ AppAnswer
260+ { _old = directAndTrans
261+ , _new = solution
262+ , _info =
263+ Project.AppInfo
264+ elm
265+ srcDirs
266+ newDepsDirect
267+ (Map.difference newDeps newDepsDirect)
268+ (Map.intersection solution testDirect)
269+ (Map.difference (Map.difference solution newDeps) testDirect)
270+ }
271+ in
272+ msum
273+ [ try C.exactly directAndTrans
274+ , try C.exactly directs
275+ , try C.untilNextMinor directs
276+ , try C.untilNextMajor directs
277+ , try (\_ -> C.anything) directs
278+ ]
279+
280+
281+collectTransitive
282+ :: Map.Map Pkg.Name V.Version
283+ -> Map.Map Pkg.Name V.Version
284+ -> Pkg.Name
285+ -> Explorer (Map.Map Pkg.Name V.Version)
286+collectTransitive solution state name =
287+ do let version = solution ! name
288+ (Explorer.Info _ trans) <- Explorer.getConstraints name version
289+ foldM
290+ (collectTransitive solution)
291+ (Map.insert name version state)
292+ (Map.keys trans)
293+
294+
295+
296+
297+
298+-- ADD TO PKG
299+
300+
301+addToPkg :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Map.Map Pkg.Name (Change C.Constraint))
302+addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
303+ Explorer.run registry $
304+ do Explorer.exists pkg
305+ let old = Map.union deps tests
306+ result <- Solver.run (addToPkgHelp pkg info)
307+ case result of
308+ Just new ->
309+ return $ detectChanges old new
310+
311+ Nothing ->
312+ do let pkgs = Map.keys deps ++ Map.keys tests
313+ badNames <- filterM isBadElm (pkg : pkgs)
314+ lift $ Task.throw (Exit.Install (E.NoSolution badNames))
315+
316+
317+addToPkgHelp :: Pkg.Name -> Project.PkgInfo -> Solver.Solver (Map.Map Pkg.Name C.Constraint)
318+addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
319+ do let directs = Map.union deps tests
320+ let newCons = Map.insert pkg C.anything directs
321+ solution <- Solver.solve newCons
322+ let con = C.untilNextMajor (solution ! pkg)
323+ return $ Map.insert pkg con directs
324+
325+
326+
327+-- FAILURE HINTS
328+
329+
330+isBadElm :: Pkg.Name -> Explorer Bool
331+isBadElm name =
332+ do versions <- Explorer.getVersions name
333+
334+ elmVersions <- forM versions $ \vsn ->
335+ Explorer._elm <$> Explorer.getConstraints name vsn
336+
337+ return (not (any C.goodElm elmVersions))
338+
339+
340+
341+-- VIEW CHANGE DOCS
342+
343+
344+data ChangeDocs =
345+ Docs
346+ { _doc_inserts :: [D.Doc]
347+ , _doc_changes :: [D.Doc]
348+ , _doc_removes :: [D.Doc]
349+ }
350+
351+
352+viewChangeDocs :: ChangeDocs -> D.Doc
353+viewChangeDocs (Docs inserts changes removes) =
354+ D.indent 2 $ D.vcat $ concat $
355+ [ viewNonZero "Add:" inserts
356+ , viewNonZero "Change:" changes
357+ , viewNonZero "Remove:" removes
358+ ]
359+
360+
361+viewNonZero :: String -> [D.Doc] -> [D.Doc]
362+viewNonZero title entries =
363+ if null entries then
364+ []
365+ else
366+ [ ""
367+ , D.fromChars title
368+ , D.indent 2 (D.vcat entries)
369+ ]
370+
371+
372+
373+-- VIEW CHANGE
374+
375+
376+addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
377+addChange toChars widths name change (Docs inserts changes removes) =
378+ case change of
379+ Insert new ->
380+ Docs (viewInsert toChars widths name new : inserts) changes removes
381+
382+ Change old new ->
383+ Docs inserts (viewChange toChars widths name old new : changes) removes
384+
385+ Remove old ->
386+ Docs inserts changes (viewRemove toChars widths name old : removes)
387+
388+
389+viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
390+viewInsert toChars (Widths nameWidth leftWidth _) name new =
391+ viewName nameWidth name <+> pad leftWidth (toChars new)
392+
393+
394+viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
395+viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =
396+ D.hsep
397+ [ viewName nameWidth name
398+ , pad leftWidth (toChars old)
399+ , "=>"
400+ , pad rightWidth (toChars new)
401+ ]
402+
403+
404+viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
405+viewRemove toChars (Widths nameWidth leftWidth _) name old =
406+ viewName nameWidth name <+> pad leftWidth (toChars old)
407+
408+
409+viewName :: Int -> Pkg.Name -> D.Doc
410+viewName width name =
411+ D.fill (width + 3) (D.fromUtf8 (Pkg.toString name))
412+
413+
414+pad :: Int -> String -> D.Doc
415+pad width string =
416+ D.fromChars (replicate (width - length string) ' ') <> D.fromChars string
417+
418+
419+
420+-- WIDTHS
421+
422+
423+data Widths =
424+ Widths
425+ { _name :: !Int
426+ , _left :: !Int
427+ , _right :: !Int
428+ }
429+
430+
431+widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
432+widen toChars pkg change (Widths name left right) =
433+ let
434+ toLength a =
435+ length (toChars a)
436+
437+ newName =
438+ max name (length (Pkg.toChars pkg))
439+ in
440+ case change of
441+ Insert new ->
442+ Widths newName (max left (toLength new)) right
443+
444+ Change old new ->
445+ Widths newName (max left (toLength old)) (max right (toLength new))
446+
447+ Remove old ->
448+ Widths newName (max left (toLength old)) right
builder/src/Elm/Outline.hs+147−157
@@ -1,16 +1,17 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
33module Elm.Outline
44 ( Outline(..)
55 , AppOutline(..)
66 , PkgOutline(..)
77 , Exposed(..)
8− , SrcDir(..)
98 , read
109 , write
1110 , encode
1211 , decoder
1312 , defaultSummary
13+ , isPlatformPackage
14+ , getName
1415 , flattenExposed
1516 )
1617 where
@@ -19,12 +20,10 @@ module Elm.Outline
1920import Prelude hiding (read)
2021import Control.Monad (filterM, liftM)
2122import Data.Binary (Binary, get, put, getWord8, putWord8)
23+import Data.Foldable (traverse_)
2224import qualified Data.Map as Map
23−import qualified Data.NonEmptyList as NE
24−import qualified Data.OneOrMore as OneOrMore
25−import Foreign.Ptr (minusPtr)
25+import qualified Data.Utf8 as Utf8
2626import qualified System.Directory as Dir
27−import qualified System.FilePath as FP
2827import System.FilePath ((</>))
2928
3029import qualified Elm.Constraint as Con
@@ -32,13 +31,10 @@ import qualified Elm.Licenses as Licenses
3231import qualified Elm.ModuleName as ModuleName
3332import qualified Elm.Package as Pkg
3433import qualified Elm.Version as V
35−import qualified File
3634import qualified Json.Decode as D
3735import qualified Json.Encode as E
38−import Json.Encode ((==>))
39−import qualified Json.String as Json
40−import qualified Parse.Primitives as P
4136import qualified Reporting.Exit as Exit
37+import qualified Reporting.Exit.Assets as E
4238
4339
4440
@@ -53,7 +49,7 @@ data Outline
5349data AppOutline =
5450 AppOutline
5551 { _app_elm_version :: V.Version
56− , _app_source_dirs :: NE.List SrcDir
52+ , _app_source_dirs :: [FilePath]
5753 , _app_deps_direct :: Map.Map Pkg.Name V.Version
5854 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
5955 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -64,7 +60,7 @@ data AppOutline =
6460data PkgOutline =
6561 PkgOutline
6662 { _pkg_name :: Pkg.Name
67− , _pkg_summary :: Json.String
63+ , _pkg_summary :: Utf8.String
6864 , _pkg_license :: Licenses.License
6965 , _pkg_version :: V.Version
7066 , _pkg_exposed :: Exposed
@@ -76,25 +72,41 @@ data PkgOutline =
7672
7773data Exposed
7874 = ExposedList [ModuleName.Raw]
79− | ExposedDict [(Json.String, [ModuleName.Raw])]
80−
81−
82−data SrcDir
83− = AbsoluteSrcDir FilePath
84− | RelativeSrcDir FilePath
75+ | ExposedDict [(Utf8.String, [ModuleName.Raw])]
8576
8677
8778
8879-- DEFAULTS
8980
9081
91−defaultSummary :: Json.String
82+defaultSummary :: Utf8.String
9283defaultSummary =
93− Json.fromChars "helpful summary of your project, less than 80 characters"
84+ "helpful summary of your project, less than 80 characters"
85+
86+
87+
88+-- QUERIES
89+
90+
91+isPlatformPackage :: Outline -> Bool
92+isPlatformPackage outline =
93+ case outline of
94+ App _ ->
95+ False
96+
97+ Pkg pkgOutline ->
98+ let author = Pkg._author (_pkg_name pkgOutline) in
99+ author == "elm" || author == "elm-explorations"
94100
95101
102+getName :: Outline -> Pkg.Name
103+getName outline =
104+ case outline of
105+ App _ ->
106+ Pkg.dummyName
96107
97−-- HELPERS
108+ Pkg (PkgOutline name _ _ _ _ _ _ _) ->
109+ name
98110
99111
100112flattenExposed :: Exposed -> [ModuleName.Raw]
@@ -125,8 +137,8 @@ encode outline =
125137 case outline of
126138 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
127139 E.object
128− [ "type" ==> E.chars "application"
129− , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
140+ [ "type" ==> E.string "application"
141+ , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs
130142 , "elm-version" ==> V.encode elm
131143 , "dependencies" ==>
132144 E.object
@@ -142,7 +154,7 @@ encode outline =
142154
143155 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
144156 E.object
145− [ "type" ==> E.string (Json.fromChars "package")
157+ [ "type" ==> E.string "package"
146158 , "name" ==> Pkg.encode name
147159 , "summary" ==> E.string summary
148160 , "license" ==> Licenses.encode license
@@ -154,6 +166,11 @@ encode outline =
154166 ]
155167
156168
169+(==>) :: a -> b -> (a, b)
170+(==>) a b =
171+ (a, b)
172+
173+
157174encodeExposed :: Exposed -> E.Value
158175encodeExposed exposed =
159176 case exposed of
@@ -171,95 +188,35 @@ encodeModule name =
171188
172189encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
173190encodeDeps encodeValue deps =
174− E.dict Pkg.toJsonString encodeValue deps
175−
176−
177−encodeSrcDir :: SrcDir -> E.Value
178−encodeSrcDir srcDir =
179− case srcDir of
180− AbsoluteSrcDir dir -> E.chars dir
181− RelativeSrcDir dir -> E.chars dir
191+ E.dict Pkg.toString encodeValue deps
182192
183193
184194
185195-- PARSE AND VERIFY
186196
187197
188−read :: FilePath -> IO (Either Exit.Outline Outline)
198+read :: FilePath -> IO (Either Exit.OutlineProblem Outline)
189199read root =
190− do bytes <- File.readUtf8 (root </> "elm.json")
191− case D.fromByteString decoder bytes of
200+ do result <- D.fromFile decoder (root </> "elm.json")
201+ case result of
192202 Left err ->
193− return $ Left (Exit.OutlineHasBadStructure err)
203+ return $ Left (Exit.BadOutlineStructure err)
194204
195205 Right outline ->
196206 case outline of
197− Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
198− return $
199− if Map.notMember Pkg.core deps && pkg /= Pkg.core
200− then Left Exit.OutlineNoPkgCore
201− else Right outline
202−
203− App (AppOutline _ srcDirs direct indirect _ _)
204− | Map.notMember Pkg.core direct ->
205− return $ Left Exit.OutlineNoAppCore
206−
207− | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
208− return $ Left Exit.OutlineNoAppJson
209−
210− | otherwise ->
211− do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
212− case map toGiven badDirs of
213− d:ds ->
214− return $ Left (Exit.OutlineHasMissingSrcDirs d ds)
215−
216− [] ->
217− do maybeDups <- detectDuplicates root (NE.toList srcDirs)
218− case maybeDups of
219− Nothing ->
220− return $ Right outline
221−
222− Just (canonicalDir, (dir1,dir2)) ->
223− return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)
224−
225−
226−isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
227−isSrcDirMissing root srcDir =
228− not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
229−
230−
231−toGiven :: SrcDir -> FilePath
232−toGiven srcDir =
233− case srcDir of
234− AbsoluteSrcDir dir -> dir
235− RelativeSrcDir dir -> dir
236−
207+ Pkg _ ->
208+ return $ Right outline
237209
238−toAbsolute :: FilePath -> SrcDir -> FilePath
239−toAbsolute root srcDir =
240− case srcDir of
241− AbsoluteSrcDir dir -> dir
242− RelativeSrcDir dir -> root </> dir
210+ App (AppOutline _ srcDirs _ _ _ _) ->
211+ do badDirs <- filterM (isBadSrcDir root) srcDirs
212+ case badDirs of
213+ [] -> return $ Right outline
214+ d:ds -> return $ Left (Exit.BadOutlineSrcDirs d ds)
243215
244216
245−detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
246−detectDuplicates root srcDirs =
247− do pairs <- traverse (toPair root) srcDirs
248− return $ Map.lookupMin $ Map.mapMaybe isDup $
249− Map.fromListWith OneOrMore.more pairs
250−
251−
252−toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
253−toPair root srcDir =
254− do key <- Dir.canonicalizePath (toAbsolute root srcDir)
255− return (key, OneOrMore.one (toGiven srcDir))
256−
257−
258−isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
259−isDup paths =
260− case paths of
261− OneOrMore.One _ -> Nothing
262− OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
217+isBadSrcDir :: FilePath -> FilePath -> IO Bool
218+isBadSrcDir root dir =
219+ not <$> Dir.doesDirectoryExist (root </> dir)
263220
264221
265222
@@ -267,26 +224,28 @@ isDup paths =
267224
268225
269226type Decoder a =
270− D.Decoder Exit.OutlineProblem a
227+ D.Decoder E.BadElmJsonContent a
271228
272229
273230decoder :: Decoder Outline
274231decoder =
275− let
276− application = Json.fromChars "application"
277− package = Json.fromChars "package"
278− in
279232 do tipe <- D.field "type" D.string
280− if | tipe == application -> App <$> appDecoder
281− | tipe == package -> Pkg <$> pkgDecoder
282− | otherwise -> D.failure Exit.OP_BadType
233+ case tipe of
234+ "application" ->
235+ App <$> appDecoder
236+
237+ "package" ->
238+ Pkg <$> pkgDecoder
239+
240+ other ->
241+ D.failure (E.BadType other)
283242
284243
285244appDecoder :: Decoder AppOutline
286245appDecoder =
287246 AppOutline
288247 <$> D.field "elm-version" versionDecoder
289− <*> D.field "source-directories" dirsDecoder
248+ <*> D.field "source-directories" (D.list dirDecoder)
290249 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
291250 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
292251 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
@@ -296,9 +255,9 @@ appDecoder =
296255pkgDecoder :: Decoder PkgOutline
297256pkgDecoder =
298257 PkgOutline
299− <$> D.field "name" nameDecoder
258+ <$> D.field "name" (D.mapError E.BadPkgName Pkg.decoder)
300259 <*> D.field "summary" summaryDecoder
301− <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
260+ <*> D.field "license" (Licenses.decoder E.BadLicense)
302261 <*> D.field "version" versionDecoder
303262 <*> D.field "exposed-modules" exposedDecoder
304263 <*> D.field "dependencies" (depsDecoder constraintDecoder)
@@ -310,43 +269,44 @@ pkgDecoder =
310269-- JSON DECODE HELPERS
311270
312271
313−nameDecoder :: Decoder Pkg.Name
314−nameDecoder =
315− D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316−
317−
318−summaryDecoder :: Decoder Json.String
272+summaryDecoder :: Decoder Utf8.String
319273summaryDecoder =
320− D.customString
321− (boundParser 80 Exit.OP_BadSummaryTooLong)
322− (\_ _ -> Exit.OP_BadSummaryTooLong)
274+ do summary <- D.string
275+ if Utf8.size summary < 80
276+ then return summary
277+ else D.failure E.BadSummaryTooLong
323278
324279
325280versionDecoder :: Decoder V.Version
326281versionDecoder =
327− D.mapError (uncurry Exit.OP_BadVersion) V.decoder
282+ D.mapError E.BadVersion V.decoder
328283
329284
330285constraintDecoder :: Decoder Con.Constraint
331286constraintDecoder =
332− D.mapError Exit.OP_BadConstraint Con.decoder
287+ D.mapError E.BadConstraint Con.decoder
333288
334289
335290depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
336291depsDecoder valueDecoder =
337− D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
292+ Map.fromList <$> (
293+ traverse validateKey =<< D.pairs valueDecoder
294+ )
338295
339296
340−dirsDecoder :: Decoder (NE.List SrcDir)
341−dirsDecoder =
342− fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
297+validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
298+validateKey (key, value) =
299+ case Pkg.fromString key of
300+ Right name ->
301+ return (name, value)
343302
303+ Left _ ->
304+ D.failure (E.BadDependencyName key)
344305
345−toSrcDir :: FilePath -> SrcDir
346−toSrcDir path =
347− if FP.isRelative path
348− then RelativeSrcDir path
349− else AbsoluteSrcDir path
306+
307+dirDecoder :: Decoder FilePath
308+dirDecoder =
309+ Utf8.toChars <$> D.string
350310
351311
352312
@@ -357,51 +317,81 @@ exposedDecoder :: Decoder Exposed
357317exposedDecoder =
358318 D.oneOf
359319 [ ExposedList <$> D.list moduleDecoder
360− , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
320+ , do pairs <- D.pairs (D.list moduleDecoder)
321+ traverse_ (checkHeader . fst) pairs
322+ return (ExposedDict pairs)
361323 ]
362324
363325
364326moduleDecoder :: Decoder ModuleName.Raw
365327moduleDecoder =
366− D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
328+ D.mapError E.BadModuleName ModuleName.decoder
367329
368330
369−headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
370−headerKeyDecoder =
371− D.KeyDecoder
372− (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
373− (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
331+checkHeader :: Utf8.String -> Decoder ()
332+checkHeader header =
333+ if Utf8.size header < 20
334+ then return ()
335+ else D.failure (E.BadModuleHeaderTooLong header)
374336
375337
376338
377−-- BOUND PARSER
339+-- BINARY
378340
379341
380−boundParser :: Int -> x -> P.Parser x Json.String
381−boundParser bound tooLong =
382− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
383− let
384− len = minusPtr end pos
385− newCol = col + fromIntegral len
386− in
387− if len < bound
388− then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
389− else cerr row newCol (\_ _ -> tooLong)
342+instance Binary Outline where
343+ put outline =
344+ case outline of
345+ App a -> putWord8 0 >> put a
346+ Pkg a -> putWord8 1 >> put a
390347
348+ get =
349+ do n <- getWord8
350+ case n of
351+ 0 -> liftM App get
352+ 1 -> liftM Pkg get
353+ _ -> error "binary encoding of Outline was corrupted"
391354
392355
393−-- BINARY
356+instance Binary AppOutline where
357+ put (AppOutline a b c d e f) =
358+ put a >> put b >> put c >> put d >> put e >> put f
394359
360+ get =
361+ do a <- get
362+ b <- get
363+ c <- get
364+ d <- get
365+ e <- get
366+ f <- get
367+ return (AppOutline a b c d e f)
395368
396−instance Binary SrcDir where
397− put outline =
398− case outline of
399− AbsoluteSrcDir a -> putWord8 0 >> put a
400− RelativeSrcDir a -> putWord8 1 >> put a
369+
370+instance Binary PkgOutline where
371+ put (PkgOutline a b c d e f g h) =
372+ put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
373+
374+ get =
375+ do a <- get
376+ b <- get
377+ c <- get
378+ d <- get
379+ e <- get
380+ f <- get
381+ g <- get
382+ h <- get
383+ return (PkgOutline a b c d e f g h)
384+
385+
386+instance Binary Exposed where
387+ put exposed =
388+ case exposed of
389+ ExposedList a -> putWord8 0 >> put a
390+ ExposedDict a -> putWord8 1 >> put a
401391
402392 get =
403393 do n <- getWord8
404394 case n of
405− 0 -> liftM AbsoluteSrcDir get
406− 1 -> liftM RelativeSrcDir get
407− _ -> fail "binary encoding of SrcDir was corrupted"
395+ 0 -> liftM ExposedList get
396+ 1 -> liftM ExposedDict get
397+ _ -> error "binary encoding of ProjectDeps was corrupted"
builder/src/Elm/Publish.hsnew file+255
@@ -0,0 +1,255 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Elm.Publish (publish) where
3+
4+
5+import Control.Monad (when)
6+import Control.Monad.Except (catchError, runExceptT)
7+import Control.Monad.Trans (liftIO, lift)
8+import qualified Data.List as List
9+import qualified Data.Utf8 as Utf8
10+import qualified System.Directory as Dir
11+import qualified System.Exit as Exit
12+import System.FilePath ((</>))
13+import qualified System.IO as IO
14+import qualified System.Process as Process
15+
16+import qualified Deps.Cache as Cache
17+import qualified Deps.Diff as Diff
18+import qualified Deps.Website as Website
19+import qualified Elm.Bump as Bump
20+import qualified Elm.Docs as Docs
21+import qualified Elm.Package as Pkg
22+import qualified Elm.Project.Json as Project
23+import qualified Elm.Project.Summary as Summary
24+import qualified Elm.Version as V
25+import qualified Reporting.Exit as Exit
26+import qualified Reporting.Exit.Publish as E
27+import qualified Reporting.Progress as Progress
28+import qualified Reporting.Task as Task
29+import qualified Stuff.Paths as Path
30+
31+
32+
33+-- PUBLISH
34+
35+
36+publish :: Summary.Summary -> Task.Task ()
37+publish summary@(Summary.Summary root project _ _ _) =
38+ case project of
39+ Project.App _ ->
40+ throw E.Application
41+
42+ Project.Pkg (Project.PkgInfo name smry _ version exposed _ _ _) ->
43+ do
44+ registry <- Cache.mandatoryUpdate
45+ let maybePublishedVersions = either (const Nothing) Just (Cache.getVersions name registry)
46+
47+ Task.report (Progress.PublishStart name version maybePublishedVersions)
48+
49+ when (noExposed exposed) $ throw E.NoExposed
50+ when (badSummary smry) $ throw E.NoSummary
51+
52+ verifyReadme root
53+ verifyLicense root
54+ docs <- Task.silently (error "TODO Project.generateDocs summary" summary)
55+ verifyVersion name version docs maybePublishedVersions
56+ commitHash <- verifyTag name version
57+ verifyNoChanges commitHash version
58+ zipHash <- verifyZip name version
59+
60+ Website.register name version commitHash zipHash
61+
62+ Task.report Progress.PublishEnd
63+
64+
65+throw :: E.Exit -> Task.Task a
66+throw exit =
67+ Task.throw (Exit.Publish exit)
68+
69+
70+
71+-- VERIFY SUMMARY
72+
73+
74+badSummary :: Utf8.String -> Bool
75+badSummary summary =
76+ Utf8.isEmpty summary || Project.defaultSummary == summary
77+
78+
79+noExposed :: Project.Exposed -> Bool
80+noExposed exposed =
81+ case exposed of
82+ Project.ExposedList modules ->
83+ null modules
84+
85+ Project.ExposedDict chunks ->
86+ all (null . snd) chunks
87+
88+
89+
90+-- VERIFY README
91+
92+
93+verifyReadme :: FilePath -> Task.Task ()
94+verifyReadme root =
95+ phase Progress.CheckReadme $
96+ do let readmePath = root </> "README.md"
97+ exists <- liftIO $ Dir.doesFileExist readmePath
98+ case exists of
99+ False ->
100+ throw E.NoReadme
101+
102+ True ->
103+ do size <- liftIO $ IO.withFile readmePath IO.ReadMode IO.hFileSize
104+ if size < 300
105+ then throw E.ShortReadme
106+ else return ()
107+
108+
109+
110+-- VERIFY LICENSE
111+
112+
113+verifyLicense :: FilePath -> Task.Task ()
114+verifyLicense root =
115+ phase Progress.CheckLicense $
116+ do let licensePath = root </> "LICENSE"
117+ exists <- liftIO $ Dir.doesFileExist licensePath
118+ if exists
119+ then return ()
120+ else throw E.NoLicense
121+
122+
123+
124+-- VERIFY GITHUB TAG
125+
126+
127+verifyTag :: Pkg.Name -> V.Version -> Task.Task String
128+verifyTag name version =
129+ phase (Progress.CheckTag version) $
130+ Website.githubCommit name version `catchError` \_ ->
131+ throw (E.MissingTag version)
132+
133+
134+
135+-- VERIFY NO LOCAL CHANGES SINCE TAG
136+
137+
138+verifyNoChanges :: String -> V.Version -> Task.Task ()
139+verifyNoChanges commitHash version =
140+ phase Progress.CheckChanges $
141+ do maybeGit <- liftIO $ Dir.findExecutable "git"
142+ case maybeGit of
143+ Nothing ->
144+ throw E.NoGit
145+
146+ Just git ->
147+ do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
148+ exitCode <- liftIO $
149+ Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]
150+
151+ case exitCode of
152+ Exit.ExitSuccess ->
153+ return ()
154+
155+ Exit.ExitFailure _ ->
156+ throw (E.LocalChanges version)
157+
158+
159+
160+-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
161+
162+
163+verifyZip :: Pkg.Name -> V.Version -> Task.Task Website.Sha
164+verifyZip name version =
165+ withTempDir $ \dir ->
166+ do hash <- phase Progress.CheckDownload $
167+ Website.githubDownload name version dir
168+
169+ phase Progress.CheckBuild $
170+ do runner <- Task.getSilentRunner
171+ result <- liftIO $ Dir.withCurrentDirectory dir $ runner $
172+ Task.silently $ error "TODO Project.generateDocs =<< Project.getRoot"
173+ either Task.throw (\_ -> return ()) result
174+
175+ return hash
176+
177+
178+withTempDir :: (FilePath -> Task.Task a) -> Task.Task a
179+withTempDir callback =
180+ do liftIO $ Dir.createDirectoryIfMissing True Path.prepublishDir
181+ result <- lift $ runExceptT $ callback Path.prepublishDir
182+ liftIO $ Dir.removeDirectoryRecursive Path.prepublishDir
183+ either Task.throw return result
184+
185+
186+
187+-- PHASE REPORTING
188+
189+
190+phase :: Progress.PublishPhase -> Task.Task a -> Task.Task a
191+phase publishPhase task =
192+ do Task.report $ Progress.PublishProgress publishPhase Nothing
193+
194+ result <- task `catchError` \exit ->
195+ do Task.report $ Progress.PublishProgress publishPhase (Just Progress.Bad)
196+ Task.throw exit
197+
198+ Task.report $ Progress.PublishProgress publishPhase (Just Progress.Good)
199+
200+ return result
201+
202+
203+
204+-- VERIFY VERSION
205+
206+
207+verifyVersion :: Pkg.Name -> V.Version -> Docs.Documentation -> Maybe [V.Version] -> Task.Task ()
208+verifyVersion name version docs maybePublishedVersions =
209+ let
210+ reportBumpPhase bumpPhase =
211+ Task.report $ Progress.PublishCheckBump version bumpPhase
212+ in
213+ do reportBumpPhase Progress.StatedVersion
214+ case maybePublishedVersions of
215+ Nothing ->
216+ if version == V.one then
217+ reportBumpPhase Progress.GoodStart
218+ else
219+ throw (E.NotInitialVersion version)
220+
221+ Just publishedVersions ->
222+ if elem version publishedVersions then
223+ throw $ E.AlreadyPublished version
224+ else
225+ do (old, magnitude) <- verifyBump name version docs publishedVersions
226+ reportBumpPhase (Progress.GoodBump old magnitude)
227+
228+ `catchError` \exit ->
229+ do reportBumpPhase Progress.BadBump
230+ Task.throw exit
231+
232+
233+verifyBump :: Pkg.Name -> V.Version -> Docs.Documentation -> [V.Version] -> Task.Task (V.Version, Diff.Magnitude)
234+verifyBump name statedVersion newDocs publishedVersions =
235+ let
236+ possibleBumps =
237+ Bump.toPossibleBumps publishedVersions
238+
239+ isTheBump (_ ,new, _) =
240+ statedVersion == new
241+ in
242+ case List.find isTheBump possibleBumps of
243+ Nothing ->
244+ throw $ E.InvalidBump statedVersion (last publishedVersions)
245+
246+ Just (old, new, magnitude) ->
247+ do oldDocs <- Cache.getDocs name old
248+ let changes = Diff.diff oldDocs newDocs
249+ let realNew = Diff.bump changes old
250+ if new == realNew
251+ then
252+ return (old, magnitude)
253+ else
254+ throw $ E.BadBump old new magnitude realNew $
255+ Diff.toMagnitude changes
builder/src/File.hs+5−28
@@ -1,7 +1,6 @@
11module File
22 ( Time
33 , getTime
4− , zeroTime
54 , writeBinary
65 , readBinary
76 , writeUtf8
@@ -24,7 +23,6 @@ import qualified Data.ByteString.Builder as B
2423import qualified Data.ByteString.Lazy as LBS
2524import qualified Data.Fixed as Fixed
2625import qualified Data.List as List
27−import qualified Data.Time.Clock as Time
2826import qualified Data.Time.Clock.POSIX as Time
2927import qualified Foreign.ForeignPtr as FPtr
3028import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
@@ -46,15 +44,11 @@ newtype Time = Time Fixed.Pico
4644getTime :: FilePath -> IO Time
4745getTime path =
4846 fmap
49− (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
47+ (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
48+-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
5049 (Dir.getModificationTime path)
5150
5251
53−zeroTime :: Time
54−zeroTime =
55− Time 0
56−
57−
5852instance Binary.Binary Time where
5953 put (Time time) = Binary.put time
6054 get = Time <$> Binary.get
@@ -78,21 +72,8 @@ readBinary path =
7872 then
7973 do result <- Binary.decodeFileOrFail path
8074 case result of
81− Right a ->
82− return (Just a)
83−
84− Left (offset, message) ->
85− do IO.hPutStrLn IO.stderr $ unlines $
86− [ "+-------------------------------------------------------------------------------"
87− , "| Corrupt File: " ++ path
88− , "| Byte Offset: " ++ show offset
89− , "| Message: " ++ message
90− , "|"
91− , "| Please report this to https://github.com/elm/compiler/issues"
92− , "| Trying to continue anyway."
93− , "+-------------------------------------------------------------------------------"
94− ]
95− return Nothing
75+ Right a -> return (Just a)
76+ Left e -> return Nothing
9677 else
9778 return Nothing
9879
@@ -190,11 +171,7 @@ writeEntry destination root entry =
190171 let
191172 path = drop root (Zip.eRelativePath entry)
192173 in
193− if List.isPrefixOf "src/" path
194− || path == "LICENSE"
195− || path == "README.md"
196− || path == "elm.json"
197− then
174+ if List.isPrefixOf "src/" path then
198175 if not (null path) && last path == '/'
199176 then Dir.createDirectoryIfMissing True (destination </> path)
200177 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
builder/src/Generate.hsdeleted−211
@@ -1,211 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module Generate
3− ( debug
4− , dev
5− , prod
6− , repl
7− )
8− where
9−
10−
11−import Prelude hiding (cycle, print)
12−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13−import Control.Monad (liftM2)
14−import qualified Data.ByteString.Builder as B
15−import Data.Map ((!))
16−import qualified Data.Map as Map
17−import qualified Data.Maybe as Maybe
18−import qualified Data.Name as N
19−import qualified Data.NonEmptyList as NE
20−
21−import qualified AST.Optimized as Opt
22−import qualified Build
23−import qualified Elm.Compiler.Type.Extract as Extract
24−import qualified Elm.Details as Details
25−import qualified Elm.Interface as I
26−import qualified Elm.ModuleName as ModuleName
27−import qualified Elm.Package as Pkg
28−import qualified File
29−import qualified Generate.JavaScript as JS
30−import qualified Generate.Mode as Mode
31−import qualified Nitpick.Debug as Nitpick
32−import qualified Reporting.Exit as Exit
33−import qualified Reporting.Task as Task
34−import qualified Stuff
35−
36−
37−-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38−-- desireable to have Repl and Reactor to keep foreign objects in memory
39−-- to make things a bit faster?
40−
41−
42−
43−-- GENERATORS
44−
45−
46−type Task a =
47− Task.Task Exit.Generate a
48−
49−
50−debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51−debug root details (Build.Artifacts pkg ifaces roots modules) =
52− do loading <- loadObjects root details modules
53− types <- loadTypes root ifaces modules
54− objects <- finalizeObjects loading
55− let mode = Mode.Dev (Just types)
56− let graph = objectsToGlobalGraph objects
57− let mains = gatherMains pkg objects roots
58− return $ JS.generate mode graph mains
59−
60−
61−dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62−dev root details (Build.Artifacts pkg _ roots modules) =
63− do objects <- finalizeObjects =<< loadObjects root details modules
64− let mode = Mode.Dev Nothing
65− let graph = objectsToGlobalGraph objects
66− let mains = gatherMains pkg objects roots
67− return $ JS.generate mode graph mains
68−
69−
70−prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71−prod root details (Build.Artifacts pkg _ roots modules) =
72− do objects <- finalizeObjects =<< loadObjects root details modules
73− checkForDebugUses objects
74− let graph = objectsToGlobalGraph objects
75− let mode = Mode.Prod (Mode.shortenFieldNames graph)
76− let mains = gatherMains pkg objects roots
77− return $ JS.generate mode graph mains
78−
79−
80−repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81−repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82− do objects <- finalizeObjects =<< loadObjects root details modules
83− let graph = objectsToGlobalGraph objects
84− return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85−
86−
87−
88−-- CHECK FOR DEBUG
89−
90−
91−checkForDebugUses :: Objects -> Task ()
92−checkForDebugUses (Objects _ locals) =
93− case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94− [] -> return ()
95− m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96−
97−
98−
99−-- GATHER MAINS
100−
101−
102−gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103−gatherMains pkg (Objects _ locals) roots =
104− Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105−
106−
107−lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108−lookupMain pkg locals root =
109− let
110− toPair name (Opt.LocalGraph maybeMain _ _) =
111− (,) (ModuleName.Canonical pkg name) <$> maybeMain
112− in
113− case root of
114− Build.Inside name -> toPair name =<< Map.lookup name locals
115− Build.Outside name _ g -> toPair name g
116−
117−
118−
119−-- LOADING OBJECTS
120−
121−
122−data LoadingObjects =
123− LoadingObjects
124− { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125− , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126− }
127−
128−
129−loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130−loadObjects root details modules =
131− Task.io $
132− do mvar <- Details.loadObjects root details
133− mvars <- traverse (loadObject root) modules
134− return $ LoadingObjects mvar (Map.fromList mvars)
135−
136−
137−loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138−loadObject root modul =
139− case modul of
140− Build.Fresh name _ graph ->
141− do mvar <- newMVar (Just graph)
142− return (name, mvar)
143−
144− Build.Cached name _ _ ->
145− do mvar <- newEmptyMVar
146− _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147− return (name, mvar)
148−
149−
150−
151−-- FINALIZE OBJECTS
152−
153−
154−data Objects =
155− Objects
156− { _foreign :: Opt.GlobalGraph
157− , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158− }
159−
160−
161−finalizeObjects :: LoadingObjects -> Task Objects
162−finalizeObjects (LoadingObjects mvar mvars) =
163− Task.eio id $
164− do result <- readMVar mvar
165− results <- traverse readMVar mvars
166− case liftM2 Objects result (sequence results) of
167− Just loaded -> return (Right loaded)
168− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169−
170−
171−objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172−objectsToGlobalGraph (Objects globals locals) =
173− foldr Opt.addLocalGraph globals locals
174−
175−
176−
177−-- LOAD TYPES
178−
179−
180−loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181−loadTypes root ifaces modules =
182− Task.eio id $
183− do mvars <- traverse (loadTypesHelp root) modules
184− let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185− results <- traverse readMVar mvars
186− case sequence results of
187− Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189−
190−
191−loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192−loadTypesHelp root modul =
193− case modul of
194− Build.Fresh name iface _ ->
195− newMVar (Just (Extract.fromInterface name iface))
196−
197− Build.Cached name _ ciMVar ->
198− do cachedInterface <- readMVar ciMVar
199− case cachedInterface of
200− Build.Unneeded ->
201− do mvar <- newEmptyMVar
202− _ <- forkIO $
203− do maybeIface <- File.readBinary (Stuff.elmi root name)
204− putMVar mvar (Extract.fromInterface name <$> maybeIface)
205− return mvar
206−
207− Build.Loaded iface ->
208− newMVar (Just (Extract.fromInterface name iface))
209−
210− Build.Corrupted ->
211− newMVar Nothing
builder/src/Http.hs+1−14
@@ -16,7 +16,6 @@ module Http
1616 -- upload
1717 , upload
1818 , filePart
19− , jsonPart
2019 , stringPart
2120 )
2221 where
@@ -27,7 +26,6 @@ import qualified Codec.Archive.Zip as Zip
2726import Control.Exception (SomeException, handle)
2827import qualified Data.Binary as Binary
2928import qualified Data.Binary.Get as Binary
30−import qualified Data.ByteString.Builder as B
3129import qualified Data.ByteString.Char8 as BS
3230import qualified Data.Digest.Pure.SHA as SHA
3331import qualified Data.String as String
@@ -36,10 +34,8 @@ import Network.HTTP.Client
3634import Network.HTTP.Client.TLS (tlsManagerSettings)
3735import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
3836import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
4037import qualified Network.HTTP.Client.MultipartFormData as Multi
4138
42−import qualified Json.Encode as Encode
4339import qualified Elm.Version as V
4440
4541
@@ -230,15 +226,6 @@ filePart name filePath =
230226 Multi.partFileSource (String.fromString name) filePath
231227
232228
233−jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
234−jsonPart name filePath value =
235− let
236− body =
237− Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
238− in
239− Multi.partFileRequestBody (String.fromString name) filePath body
240−
241−
242229stringPart :: String -> String -> Multi.Part
243230stringPart name string =
244− Multi.partBS (String.fromString name) (BS.pack string)
231+ Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hs+27−122
@@ -1,17 +1,14 @@
11{-# LANGUAGE BangPatterns, OverloadedStrings #-}
22module Reporting
33 ( Style
4− , silent
54 , json
65 , terminal
76 --
87 , attempt
9− , attemptWithStyle
8+ , exit
109 --
1110 , Key
1211 , report
13− , ignorer
14− , ask
1512 --
1613 , DKey
1714 , DMsg(..)
@@ -27,13 +24,12 @@ module Reporting
2724
2825
2926import Control.Concurrent
30−import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
3127import Control.Monad (when)
3228import qualified Data.ByteString.Builder as B
3329import qualified Data.NonEmptyList as NE
3430import qualified System.Exit as Exit
3531import qualified System.Info as Info
36−import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
32+import System.IO (hFlush, hPutStr, stderr, stdout)
3733
3834import qualified Elm.ModuleName as ModuleName
3935import qualified Elm.Package as Pkg
@@ -50,16 +46,10 @@ import qualified Reporting.Exit.Help as Help
5046
5147
5248data Style
53− = Silent
54− | Json
49+ = Json
5550 | Terminal (MVar ())
5651
5752
58−silent :: Style
59−silent =
60− Silent
61−
62−
6353json :: Style
6454json =
6555 Json
@@ -74,38 +64,25 @@ terminal =
7464-- ATTEMPT
7565
7666
77−attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
78−attempt toReport work =
79− do result <- work `catch` reportExceptionsNicely
80− case result of
81− Right a ->
82− return a
83−
84− Left x ->
85− do Exit.toStderr (toReport x)
86− Exit.exitFailure
87−
88−
89−attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
90−attemptWithStyle style toReport work =
91− do result <- work `catch` reportExceptionsNicely
67+attempt :: Style -> IO (Either Help.Report a) -> IO a
68+attempt style work =
69+ do result <- work
9270 case result of
93− Right a ->
94− return a
71+ Right a -> return a
72+ Left ex -> exit style ex
9573
96− Left x ->
97− case style of
98− Silent ->
99− do Exit.exitFailure
10074
101− Json ->
102− do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
103− Exit.exitFailure
75+exit :: Style -> Help.Report -> IO a
76+exit style rep =
77+ case style of
78+ Json ->
79+ do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson rep))
80+ Exit.exitFailure
10481
105− Terminal mvar ->
106− do readMVar mvar
107− Exit.toStderr (toReport x)
108− Exit.exitFailure
82+ Terminal mvar ->
83+ do readMVar mvar
84+ Exit.toStderr rep
85+ Exit.exitFailure
10986
11087
11188
@@ -122,6 +99,11 @@ badMark =
12299 D.red $ if isWindows then "X" else "✗"
123100
124101
102+_waitingMark :: D.Doc
103+_waitingMark =
104+ D.dullyellow $ if isWindows then "-" else "→"
105+
106+
125107isWindows :: Bool
126108isWindows =
127109 Info.os == "mingw32"
@@ -139,34 +121,6 @@ report (Key send) msg =
139121 send msg
140122
141123
142−ignorer :: Key msg
143−ignorer =
144− Key (\_ -> return ())
145−
146−
147−
148−-- ASK
149−
150−
151−ask :: D.Doc -> IO Bool
152−ask doc =
153− do Help.toStdout doc
154− askHelp
155−
156−
157−askHelp :: IO Bool
158−askHelp =
159− do hFlush stdout
160− input <- getLine
161− case input of
162− "" -> return True
163− "Y" -> return True
164− "y" -> return True
165− "n" -> return False
166− _ ->
167− do putStr "Must type 'y' for yes or 'n' for no: "
168− askHelp
169−
170124
171125-- DETAILS
172126
@@ -177,9 +131,6 @@ type DKey = Key DMsg
177131trackDetails :: Style -> (DKey -> IO a) -> IO a
178132trackDetails style callback =
179133 case style of
180− Silent ->
181− callback (Key (\_ -> return ()))
182−
183134 Json ->
184135 callback (Key (\_ -> return ()))
185136
@@ -264,8 +215,8 @@ putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
264215putDownload mark pkg vsn =
265216 Help.toStdout $ D.indent 2 $
266217 mark
267− <+> D.fromPackage pkg
268− <+> D.fromVersion vsn
218+ <+> D.fromUtf8 (Pkg.toString pkg)
219+ <+> D.fromUtf8 (V.toString vsn)
269220 <> "\n"
270221
271222
@@ -309,9 +260,6 @@ type BResult a = Either Exit.BuildProblem a
309260trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
310261trackBuild style callback =
311262 case style of
312− Silent ->
313− callback (Key (\_ -> return ()))
314−
315263 Json ->
316264 callback (Key (\_ -> return ()))
317265
@@ -364,10 +312,10 @@ toFinalMessage done result =
364312
365313 Left problem ->
366314 case problem of
367− Exit.BuildBadModules _ _ [] ->
315+ Exit.BuildModuleProblems _ [] ->
368316 "Detected problems in 1 module."
369317
370− Exit.BuildBadModules _ _ (_:ps) ->
318+ Exit.BuildModuleProblems _ (_:ps) ->
371319 "Detected problems in " ++ show (2 + length ps) ++ " modules."
372320
373321 Exit.BuildProjectProblem _ ->
@@ -381,9 +329,6 @@ toFinalMessage done result =
381329reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
382330reportGenerate style names output =
383331 case style of
384− Silent ->
385− return ()
386−
387332 Json ->
388333 return ()
389334
@@ -432,43 +377,3 @@ vbottom = if isWindows then '+' else '┘'
432377putStrFlush :: String -> IO ()
433378putStrFlush str =
434379 hPutStr stdout str >> hFlush stdout
435−
436−
437−
438−-- REPORT EXCEPTIONS NICELY
439−
440−
441−reportExceptionsNicely :: SomeException -> IO a
442−reportExceptionsNicely e =
443− case fromException e of
444− Just UserInterrupt -> throw e
445− _ -> putException e >> throw e
446−
447−
448−putException :: SomeException -> IO ()
449−putException e = do
450− hPutStrLn stderr ""
451− Help.toStderr $ D.stack $
452− [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
453− , D.reflow $
454− "I ran into something that bypassed the normal error reporting process!\
455− \ I extracted whatever information I could from the internal error:"
456− , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
457− , D.reflow $
458− "These errors are usually pretty confusing, so start by asking around on one of\
459− \ forums listed at https://elm-lang.org/community to see if anyone can get you\
460− \ unstuck quickly."
461− , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"
462− , D.reflow $
463− "If you are feeling up to it, please try to get your code down to the smallest\
464− \ version that still triggers this message. Ideally in a single Main.elm and\
465− \ elm.json file."
466− , D.reflow $
467− "From there open a NEW issue at https://github.com/elm/compiler/issues with\
468− \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
469− \ worry about if someone else saw something similar. More examples is better!"
470− , D.reflow $
471− "This kind of error is usually tied up in larger architectural choices that are\
472− \ hard to change, so even when we have a couple good examples, it can take some\
473− \ time to resolve in a solid way."
474− ]
builder/src/Reporting/Exit.hs+64−2015
@@ -1,27 +1,6 @@
11{-# LANGUAGE OverloadedStrings #-}
22module Reporting.Exit
3− ( Init(..), initToReport
4− , Diff(..), diffToReport
5− , Make(..), makeToReport
6− , Bump(..), bumpToReport
7− , Repl(..), replToReport
8− , Publish(..), publishToReport
9− , Install(..), installToReport
10− , Reactor(..), reactorToReport
11− , newPackageOverview
12− --
13− , Solver(..)
14− , Outline(..)
15− , OutlineProblem(..)
16− , Details(..)
17− , DetailsBadDep(..)
18− , PackageProblem(..)
19− , RegistryProblem(..)
20− , BuildProblem(..)
21− , BuildProjectProblem(..)
22− , DocsProblem(..)
23− , Generate(..)
24− --
3+ ( Exit(..)
254 , toString
265 , toStderr
276 , toJson
@@ -29,1579 +8,66 @@ module Reporting.Exit
298 where
309
3110
32−import qualified Data.ByteString as BS
33−import qualified Data.ByteString.UTF8 as BS_UTF8
34−import qualified Data.List as List
35−import qualified Data.Map as Map
36−import qualified Data.Name as N
37−import qualified Data.NonEmptyList as NE
38−import qualified Network.HTTP.Client as HTTP
39−import qualified Network.HTTP.Types.Header as HTTP
40−import qualified Network.HTTP.Types.Status as HTTP
41−import qualified System.FilePath as FP
42−import System.FilePath ((</>), (<.>))
43−
44−import qualified Elm.Constraint as C
45−import qualified Elm.Magnitude as M
4611import qualified Elm.ModuleName as ModuleName
47−import qualified Elm.Package as Pkg
48−import qualified Elm.Version as V
49−import qualified File
50−import qualified Http
51−import qualified Json.Decode as Decode
5212import qualified Json.Encode as Encode
53−import qualified Json.String as Json
54−import Parse.Primitives (Row, Col)
55−import qualified Reporting.Annotation as A
56−import Reporting.Doc ((<>))
5713import qualified Reporting.Doc as D
58−import qualified Reporting.Error.Import as Import
59−import qualified Reporting.Error.Json as Json
14+import qualified Reporting.Exit.Assets as Asset
15+import qualified Reporting.Exit.Bump as Bump
16+import qualified Reporting.Exit.Compile as Compile
17+import qualified Reporting.Exit.Crawl as Crawl
18+import qualified Reporting.Exit.Deps as Deps
19+import qualified Reporting.Exit.Diff as Diff
6020import qualified Reporting.Exit.Help as Help
61−import qualified Reporting.Error as Error
62−import qualified Reporting.Render.Code as Code
63−
64−
65−
66−-- RENDERERS
67−
68−
69−toString :: Help.Report -> String
70−toString report =
71− Help.toString (Help.reportToDoc report)
72−
73−
74−toStderr :: Help.Report -> IO ()
75−toStderr report =
76− Help.toStderr (Help.reportToDoc report)
77−
78−
79−toJson :: Help.Report -> Encode.Value
80−toJson report =
81− Help.reportToJson report
82−
83−
84−
85−-- INIT
86−
87−
88−data Init
89− = InitNoSolution [Pkg.Name]
90− | InitNoOfflineSolution [Pkg.Name]
91− | InitSolverProblem Solver
92− | InitAlreadyExists
93− | InitRegistryProblem RegistryProblem
94−
95−
96−initToReport :: Init -> Help.Report
97−initToReport exit =
98− case exit of
99− InitNoSolution pkgs ->
100− Help.report "NO SOLUTION" Nothing
101− "I tried to create an elm.json with the following direct dependencies:"
102− [ D.indent 4 $ D.vcat $
103− map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
104− , D.reflow $
105− "I could not find compatible versions though! This should not happen, so please\
106− \ ask around one of the community forums at https://elm-lang.org/community to learn\
107− \ what is going on!"
108− ]
109−
110− InitNoOfflineSolution pkgs ->
111− Help.report "NO OFFLINE SOLUTION" Nothing
112− "I tried to create an elm.json with the following direct dependencies:"
113− [ D.indent 4 $ D.vcat $
114− map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
115− , D.reflow $
116− "I could not find compatible versions though, but that may be because I could not\
117− \ connect to https://package.elm-lang.org to get the latest list of packages. Are\
118− \ you able to connect to the internet? Please ask around one of the community\
119− \ forums at https://elm-lang.org/community for help!"
120− ]
121−
122− InitSolverProblem solver ->
123− toSolverReport solver
124−
125− InitAlreadyExists ->
126− Help.report "EXISTING PROJECT" Nothing
127− "You already have an elm.json file, so there is nothing for me to initialize!"
128− [ D.fillSep
129− ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"
130− ,"you","figure","out","what","to","do","next?"
131− ]
132− ]
133−
134− InitRegistryProblem problem ->
135− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
136− "I need the list of published packages before I can start initializing projects"
137−
138−
139−
140−-- DIFF
141−
142−
143−data Diff
144− = DiffNoOutline
145− | DiffBadOutline Outline
146− | DiffApplication
147− | DiffNoExposed
148− | DiffUnpublished
149− | DiffUnknownPackage Pkg.Name [Pkg.Name]
150− | DiffUnknownVersion Pkg.Name V.Version [V.Version]
151− | DiffDocsProblem V.Version DocsProblem
152− | DiffMustHaveLatestRegistry RegistryProblem
153− | DiffBadDetails Details
154− | DiffBadBuild BuildProblem
155−
156−
157−diffToReport :: Diff -> Help.Report
158−diffToReport diff =
159− case diff of
160− DiffNoOutline ->
161− Help.report "DIFF WHAT?" Nothing
162− "I cannot find an elm.json so I am not sure what you want me to diff.\
163− \ Normally you run `elm diff` from within a project!"
164− [ D.reflow $ "If you are just curious to see a diff, try running this command:"
165− , D.indent 4 $ D.green $ "elm diff elm/http 1.0.0 2.0.0"
166− ]
167−
168− DiffBadOutline outline ->
169− toOutlineReport outline
170−
171− DiffApplication ->
172− Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
173− "Your elm.json says this project is an application, but `elm diff` only works\
174− \ with packages. That way there are previously published versions of the API to\
175− \ diff against!"
176− [ D.reflow $ "If you are just curious to see a diff, try running this command:"
177− , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"
178− ]
179−
180− DiffNoExposed ->
181− Help.report "NO EXPOSED MODULES" (Just "elm.json")
182− "Your elm.json has no \"exposed-modules\" which means there is no public API at\
183− \ all right now! What am I supposed to diff?"
184− [ D.reflow $
185− "Try adding some modules back to the \"exposed-modules\" field."
186− ]
187−
188− DiffUnpublished ->
189− Help.report "UNPUBLISHED" Nothing
190− "This package is not published yet. There is nothing to diff against!"
191− []
192−
193− DiffUnknownPackage pkg suggestions ->
194− Help.report "UNKNOWN PACKAGE" Nothing
195− ( "I cannot find a package called:"
196− )
197− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
198− , "Maybe you want one of these instead?"
199− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
200− , "But check <https://package.elm-lang.org> to see all possibilities!"
201− ]
202−
203− DiffUnknownVersion _pkg vsn realVersions ->
204− Help.docReport "UNKNOWN VERSION" Nothing
205− ( D.fillSep $
206− [ "Version", D.red (D.fromVersion vsn)
207− , "has", "never", "been", "published,", "so", "I"
208− , "cannot", "diff", "against", "it."
209− ]
210− )
211− [ "Here are all the versions that HAVE been published:"
212− , D.indent 4 $ D.dullyellow $ D.vcat $
213− let
214− sameMajor v1 v2 = V._major v1 == V._major v2
215− mkRow vsns = D.hsep $ map D.fromVersion vsns
216− in
217− map mkRow $ List.groupBy sameMajor (List.sort realVersions)
218− , "Want one of those instead?"
219− ]
220−
221− DiffDocsProblem version problem ->
222− toDocsProblemReport problem $
223− "I need the docs for " ++ V.toChars version ++ " to compute this diff"
224−
225− DiffMustHaveLatestRegistry problem ->
226− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
227− "I need the latest list of published packages before I do this diff"
228−
229− DiffBadDetails details ->
230− toDetailsReport details
231−
232− DiffBadBuild buildProblem ->
233− toBuildProblemReport buildProblem
234−
235−
236−
237−-- BUMP
238−
239−
240−data Bump
241− = BumpNoOutline
242− | BumpBadOutline Outline
243− | BumpApplication
244− | BumpUnexpectedVersion V.Version [V.Version]
245− | BumpMustHaveLatestRegistry RegistryProblem
246− | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
247− | BumpBadDetails Details
248− | BumpNoExposed
249− | BumpBadBuild BuildProblem
250−
251−
252−bumpToReport :: Bump -> Help.Report
253−bumpToReport bump =
254− case bump of
255− BumpNoOutline ->
256− Help.report "BUMP WHAT?" Nothing
257− "I cannot find an elm.json so I am not sure what you want me to bump."
258− [ D.reflow $
259− "Elm packages always have an elm.json that says current the version number. If\
260− \ you run this command from a directory with an elm.json file, I will try to bump\
261− \ the version in there based on the API changes."
262− ]
263−
264− BumpBadOutline outline ->
265− toOutlineReport outline
266−
267− BumpApplication ->
268− Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
269− "Your elm.json says this is an application. That means it cannot be published\
270− \ on <https://package.elm-lang.org> and therefore has no version to bump!"
271− []
272−
273− BumpUnexpectedVersion vsn versions ->
274− Help.docReport "CANNOT BUMP" (Just "elm.json")
275− ( D.fillSep
276− ["Your","elm.json","says","I","should","bump","relative","to","version"
277− ,D.red (D.fromVersion vsn) <> ","
278− ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
279− ,"That","means","there","is","no","API","for","me","to","diff","against","and"
280− ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
281− ]
282− )
283− [ D.fillSep $
284− ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
285− ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
286− , D.vcat $ map (D.green . D.fromVersion) versions
287− ]
288−
289− BumpMustHaveLatestRegistry problem ->
290− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
291− "I need the latest list of published packages before I can bump any versions"
292−
293− BumpCannotFindDocs _ version problem ->
294− toDocsProblemReport problem $
295− "I need the docs for " ++ V.toChars version ++ " to compute the next version number"
296−
297− BumpBadDetails details ->
298− toDetailsReport details
299−
300− BumpNoExposed ->
301− Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
302− ( D.fillSep $
303− [ "To", "bump", "a", "package,", "the"
304− , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
305− , "elm.json", "must", "list", "at", "least", "one", "module."
306− ]
307− )
308− [ D.reflow $
309− "Try adding some modules back to the \"exposed-modules\" field."
310− ]
311−
312− BumpBadBuild problem ->
313− toBuildProblemReport problem
314−
315−
316−
317−-- OVERVIEW OF VERSIONING
318−
319−
320−newPackageOverview :: String
321−newPackageOverview =
322− unlines
323− [ "This package has never been published before. Here's how things work:"
324− , ""
325− , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
326− , ""
327− , " - All packages start with initial version " ++ V.toChars V.one
328− , ""
329− , " - Versions are incremented based on how the API changes:"
330− , ""
331− , " PATCH = the API is the same, no risk of breaking code"
332− , " MINOR = values have been added, existing values are unchanged"
333− , " MAJOR = existing values have been changed or removed"
334− , ""
335− , " - I will bump versions for you, automatically enforcing these rules"
336− , ""
337− ]
338−
339−
340−
341−-- PUBLISH
342−
343−
344−data Publish
345− = PublishNoOutline
346− | PublishBadOutline Outline
347− | PublishBadDetails Details
348− | PublishMustHaveLatestRegistry RegistryProblem
349− | PublishApplication
350− | PublishNotInitialVersion V.Version
351− | PublishAlreadyPublished V.Version
352− | PublishInvalidBump V.Version V.Version
353− | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
354− | PublishNoSummary
355− | PublishNoExposed
356− | PublishNoReadme
357− | PublishShortReadme
358− | PublishNoLicense
359− | PublishBuildProblem BuildProblem
360− | PublishMissingTag V.Version
361− | PublishCannotGetTag V.Version Http.Error
362− | PublishCannotGetTagData V.Version String BS.ByteString
363− | PublishCannotGetZip Http.Error
364− | PublishCannotDecodeZip String
365− | PublishCannotGetDocs V.Version V.Version DocsProblem
366− | PublishCannotRegister Http.Error
367− | PublishNoGit
368− | PublishLocalChanges V.Version
369− --
370− | PublishZipBadDetails Details
371− | PublishZipApplication
372− | PublishZipNoExposed
373− | PublishZipBuildProblem BuildProblem
374−
375−
376−publishToReport :: Publish -> Help.Report
377−publishToReport publish =
378− case publish of
379− PublishNoOutline ->
380− Help.report "PUBLISH WHAT?" Nothing
381− "I cannot find an elm.json so I am not sure what you want me to publish."
382− [ D.reflow $
383− "Elm packages always have an elm.json that states the version number,\
384− \ dependencies, exposed modules, etc."
385− ]
386−
387− PublishBadOutline outline ->
388− toOutlineReport outline
389−
390− PublishBadDetails problem ->
391− toDetailsReport problem
392−
393− PublishMustHaveLatestRegistry problem ->
394− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
395− "I need the latest list of published packages to make sure this is safe to publish"
396−
397− PublishApplication ->
398− Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
399−
400− PublishNotInitialVersion vsn ->
401− Help.docReport "INVALID VERSION" Nothing
402− ( D.fillSep
403− ["I","cannot","publish"
404− ,D.red (D.fromVersion vsn)
405− ,"as","the","initial","version."
406− ]
407− )
408− [ D.fillSep
409− ["Change","it","to",D.green "1.0.0","which","is"
410− ,"the","initial","version","for","all","Elm","packages."
411− ]
412− ]
413−
414− PublishAlreadyPublished vsn ->
415− Help.docReport "ALREADY PUBLISHED" Nothing
416− ( D.vcat
417− [ D.fillSep
418− [ "Version", D.green (D.fromVersion vsn)
419− , "has", "already", "been", "published.", "You", "cannot"
420− , "publish", "it", "again!"
421− ]
422− , "Try using the `bump` command:"
423− ]
424− )
425− [ D.dullyellow $ D.indent 4 "elm bump"
426− , D.reflow $
427− "It computes the version number based on API changes, ensuring\
428− \ that no breaking changes end up in PATCH releases!"
429− ]
430−
431− PublishInvalidBump statedVersion latestVersion ->
432− Help.docReport "INVALID VERSION" (Just "elm.json")
433− ( D.fillSep $
434− ["Your","elm.json","says","the","next","version","should","be"
435− ,D.red (D.fromVersion statedVersion) <> ","
436− ,"but","that","is","not","valid","based","on","the","previously"
437− ,"published","versions."
438− ]
439− )
440− [ D.fillSep $
441− ["Change","the","version","back","to"
442− ,D.green (D.fromVersion latestVersion)
443− ,"which","is","the","most","recently","published","version."
444− ,"From","there,","have","Elm","bump","the","version","by","running:"
445− ]
446− , D.indent 4 $ D.green "elm bump"
447− , D.reflow $
448− "If you want more insight on the API changes Elm detects, you\
449− \ can run `elm diff` at this point as well."
450− ]
451−
452− PublishBadBump old new magnitude realNew realMagnitude ->
453− Help.docReport "INVALID VERSION" (Just "elm.json")
454− (
455− D.fillSep $
456− ["Your","elm.json","says","the","next","version","should","be"
457− ,D.red (D.fromVersion new) <> ","
458− ,"indicating","a",D.fromChars (M.toChars magnitude)
459− ,"change","to","the","public","API."
460− ,"This","does","not","match","the","API","diff","given","by:"
461− ]
462− )
463− [ D.indent 4 $ D.fromChars $
464− "elm diff " ++ V.toChars old
465−
466− , D.fillSep $
467− ["This","command","says","this","is","a"
468− ,D.fromChars (M.toChars realMagnitude)
469− ,"change,","so","the","next","version","should","be"
470− ,D.green (D.fromVersion realNew) <> "."
471− ,"Double","check","everything","to","make","sure","you"
472− ,"are","publishing","what","you","want!"
473− ]
474− , D.reflow $
475− "Also, next time use `elm bump` and I'll figure all this out for you!"
476− ]
477−
478− PublishNoSummary ->
479− Help.docReport "NO SUMMARY" (Just "elm.json")
480− ( D.fillSep $
481− [ "To", "publish", "a", "package,", "your", "elm.json", "must"
482− , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"
483− , "a", "consice", "overview", "of", "your", "project."
484− ]
485− )
486− [ D.reflow $
487− "The summary must be less than 80 characters. It should describe\
488− \ the concrete use of your package as clearly and as plainly as possible."
489− ]
490−
491− PublishNoExposed ->
492− Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
493− ( D.fillSep $
494− [ "To", "publish", "a", "package,", "the"
495− , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
496− , "elm.json", "must", "list", "at", "least", "one", "module."
497− ]
498− )
499− [ D.reflow $
500− "Which modules do you want users of the package to have access to? Add their\
501− \ names to the \"exposed-modules\" list."
502− ]
503−
504− PublishNoReadme ->
505− toBadReadmeReport "NO README" $
506− "Every published package must have a helpful README.md\
507− \ file, but I do not see one in your project."
508−
509− PublishShortReadme ->
510− toBadReadmeReport "SHORT README" $
511− "This README.md is too short. Having more details will help\
512− \ people assess your package quickly and fairly."
513−
514− PublishNoLicense ->
515− Help.report "NO LICENSE FILE" (Just "LICENSE")
516− "By publishing a package you are inviting the Elm community to build\
517− \ upon your work. But without knowing your license, we have no idea if\
518− \ that is legal!"
519− [ D.reflow $
520− "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\
521− \ you must share that choice in two places. First, the license\
522− \ identifier must appear in your elm.json file. Second, the full\
523− \ license text must appear in the root of your project in a file\
524− \ named LICENSE. Add that file and you will be all set!"
525− ]
526−
527− PublishBuildProblem buildProblem ->
528− toBuildProblemReport buildProblem
529−
530− PublishMissingTag version ->
531− let vsn = V.toChars version in
532− Help.docReport "NO TAG" Nothing
533− ( D.fillSep $
534− [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"
535− , "cannot", "find", "a", D.green (D.fromChars vsn), "tag."
536− ]
537− )
538− [ D.vcat
539− [ "These tags make it possible to find this specific version on GitHub."
540− , "To tag the most recent commit and push it to GitHub, run this:"
541− ]
542− , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $
543− [ "git tag -a " ++ vsn ++ " -m \"new release\""
544− , "git push origin " ++ vsn
545− ]
546− , "The -m flag is for a helpful message. Try to make it more informative!"
547− ]
548−
549− PublishCannotGetTag version httpError ->
550− case httpError of
551− Http.BadHttp _ (HTTP.StatusCodeException response _)
552− | HTTP.statusCode (HTTP.responseStatus response) == 404 ->
553− let vsn = V.toChars version in
554− Help.report "NO TAG ON GITHUB" Nothing
555− ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")
556− [ D.reflow
557− "Run the following command to make this tag available on GitHub:"
558− , D.indent 4 $ D.dullyellow $ D.fromChars $
559− "git push origin " ++ vsn
560− , D.reflow
561− "This will make it possible to find your code online based on the version number."
562− ]
563−
564− _ ->
565− toHttpErrorReport "PROBLEM VERIFYING TAG" httpError
566− "I need to check that the version tag is registered on GitHub"
567−
568− PublishCannotGetTagData version url body ->
569− Help.report "PROBLEM VERIFYING TAG" Nothing
570− ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")
571− [ D.indent 4 $ D.dullyellow $ D.fromChars url
572− , D.reflow $
573− "I got the data back, but it was not what I was expecting. The response\
574− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
575− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
576− , D.indent 4 $ D.dullyellow $ D.fromChars $
577− if BS.length body <= 76
578− then BS_UTF8.toString body
579− else take 73 (BS_UTF8.toString body) ++ "..."
580− , D.reflow $
581− "Does this error keep showing up? Maybe there is something weird with your\
582− \ internet connection. We have gotten reports that schools, businesses,\
583− \ airports, etc. sometimes intercept requests and add things to the body\
584− \ or change its contents entirely. Could that be the problem?"
585− ]
586−
587− PublishCannotGetZip httpError ->
588− toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $
589− "I need to check that folks can download and build the source code when they\
590− \ install this package"
21+import qualified Reporting.Exit.Http as Http
22+import qualified Reporting.Exit.Make as Make
23+import qualified Reporting.Exit.Init as Init
24+import qualified Reporting.Exit.Install as Install
25+import qualified Reporting.Exit.Publish as Publish
59126
592− PublishCannotDecodeZip url ->
593− Help.report "PROBLEM DOWNLOADING CODE" Nothing
594− "I need to check that folks can download and build the source code when they\
595− \ install this package, so I downloaded the code from:"
596− [ D.indent 4 $ D.dullyellow $ D.fromChars url
597− , D.reflow $
598− "I was unable to unzip the archive though. Maybe there is something weird with\
599− \ your internet connection. We have gotten reports that schools, businesses,\
600− \ airports, etc. sometimes intercept requests and add things to the body or\
601− \ change its contents entirely. Could that be the problem?"
602− ]
603−
604− PublishCannotGetDocs old new docsProblem ->
605− toDocsProblemReport docsProblem $
606− "I need the docs for " ++ V.toChars old ++ " to verify that "
607− ++ V.toChars new ++ " really does come next"
608−
609− PublishCannotRegister httpError ->
610− toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $
611− "I need to send information about your package to the package website"
612−
613− PublishNoGit ->
614− Help.report "NO GIT" Nothing
615− "I searched your PATH environment variable for `git` and could not\
616− \ find it. Is it available through your PATH?"
617− [ D.reflow $
618− "Who cares about this? Well, I currently use `git` to check if there\
619− \ are any local changes in your code. Local changes are a good sign\
620− \ that some important improvements have gotten mistagged, so this\
621− \ check can be extremely helpful for package authors!"
622− , D.toSimpleNote $
623− "We plan to do this without the `git` binary in a future release."
624− ]
62527
626− PublishLocalChanges version ->
627− let vsn = V.toChars version in
628− Help.docReport "LOCAL CHANGES" Nothing
629− ( D.fillSep $
630− [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"
631− , "git", "does", "not", "match", "the", "code", "in", "your"
632− , "working", "directory.", "This", "means", "you", "have"
633− , "commits", "or", "local", "changes", "that", "are", "not"
634− , "going", "to", "be", "published!"
635− ]
636− )
637− [ D.toSimpleNote $
638− "If you are sure everything is in order, you can run `git checkout "
639− ++ vsn ++ "` and publish your code from there."
640− ]
641−
642− PublishZipBadDetails _ ->
643− badZipReport
644−
645− PublishZipApplication ->
646− badZipReport
64728
648− PublishZipNoExposed ->
649− badZipReport
29+-- ALL POSSIBLE ERRORS
65030
651− PublishZipBuildProblem _ ->
652− badZipReport
653−
654−
655−toBadReadmeReport :: String -> String -> Help.Report
656−toBadReadmeReport title summary =
657− Help.report title (Just "README.md") summary
658− [ D.reflow $
659− "When people look at your README, they are wondering:"
660− , D.vcat
661− [ " - What does this package even do?"
662− , " - Will it help me solve MY problems?"
663− ]
664− , D.reflow $
665− "So I recommend starting your README with a small example of the\
666− \ most common usage scenario. Show people what they can expect if\
667− \ they learn more!"
668− , D.toSimpleNote $
669− "By publishing your package, you are inviting people to invest time in\
670− \ understanding your work. Spending an hour on your README to communicate your\
671− \ knowledge more clearly can save the community days or weeks of time in\
672− \ aggregate, and saving time in aggregate is the whole point of publishing\
673− \ packages! People really appreciate it, and it makes the whole ecosystem feel\
674− \ nicer!"
675− ]
67631
32+data Exit
33+ = NoElmJson
34+ | Assets Asset.Exit
35+ | Bump Bump.Exit
36+ | Compile Compile.Exit [Compile.Exit]
37+ | Crawl Crawl.Exit
38+ | Cycle [ModuleName.Raw] -- TODO write docs to help with this scenario
39+ | Deps Deps.Exit
40+ | Diff Diff.Exit
41+ | Make Make.Exit
42+ | Init Init.Exit
43+ | Install Install.Exit
44+ | Publish Publish.Exit
45+ | BadHttp String Http.Exit
67746
678−badZipReport :: Help.Report
679−badZipReport =
680− Help.report "PROBLEM VERIFYING PACKAGE" Nothing
681− "Before publishing packages, I download the code from GitHub and try to build it\
682− \ from scratch. That way I can be more confident that it will work for other\
683− \ people too. But I am not able to build it!"
684− [ D.reflow $
685− "I was just able to build your local copy though. Is there some way the version\
686− \ on GitHub could be different?"
687− ]
68847
68948
49+-- RENDERERS
69050
691−-- DOCS
692−
693−
694−data DocsProblem
695− = DP_Http Http.Error
696− | DP_Data String BS.ByteString
697− | DP_Cache
698−
699−
700−toDocsProblemReport :: DocsProblem -> String -> Help.Report
701−toDocsProblemReport problem context =
702− case problem of
703− DP_Http httpError ->
704− toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705−
706− DP_Data url body ->
707− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708− [ D.indent 4 $ D.dullyellow $ D.fromChars url
709− , D.reflow $
710− "I got the data back, but it was not what I was expecting. The response\
711− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713− , D.indent 4 $ D.dullyellow $ D.fromChars $
714− if BS.length body <= 76
715− then BS_UTF8.toString body
716− else take 73 (BS_UTF8.toString body) ++ "..."
717− , D.reflow $
718− "Does this error keep showing up? Maybe there is something weird with your\
719− \ internet connection. We have gotten reports that schools, businesses,\
720− \ airports, etc. sometimes intercept requests and add things to the body\
721− \ or change its contents entirely. Could that be the problem?"
722− ]
723−
724− DP_Cache ->
725− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726− [ D.reflow $
727− "I deleted the cached version, so the next run should download a fresh copy of\
728− \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729− \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730− \ for some reason."
731− ]
73251
52+toString :: Exit -> String
53+toString exit =
54+ Help.toString (Help.reportToDoc (toReport exit))
73355
73456
735−-- INSTALL
57+toStderr :: Exit -> IO ()
58+toStderr exit =
59+ Help.toStderr (Help.reportToDoc (toReport exit))
73660
73761
738−data Install
739− = InstallNoOutline
740− | InstallBadOutline Outline
741− | InstallBadRegistry RegistryProblem
742− | InstallNoArgs FilePath
743− | InstallNoOnlineAppSolution Pkg.Name
744− | InstallNoOfflineAppSolution Pkg.Name
745− | InstallNoOnlinePkgSolution Pkg.Name
746− | InstallNoOfflinePkgSolution Pkg.Name
747− | InstallHadSolverTrouble Solver
748− | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
749− | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
750− | InstallBadDetails Details
62+toJson :: Exit -> Encode.Value
63+toJson exit =
64+ Help.reportToJson (toReport exit)
75165
75266
753−installToReport :: Install -> Help.Report
754−installToReport exit =
67+toReport :: Exit -> Help.Report
68+toReport exit =
75569 case exit of
756− InstallNoOutline ->
757− Help.report "NEW PROJECT?" Nothing
758− "Are you trying to start a new project? Try this command instead:"
759− [ D.indent 4 $ D.green "elm init"
760− , D.reflow "It will help you get started!"
761− ]
762−
763− InstallBadOutline outline ->
764− toOutlineReport outline
765−
766− InstallBadRegistry problem ->
767− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
768− "I need the list of published packages to figure out how to install things"
769−
770− InstallNoArgs elmHome ->
771− Help.report "INSTALL WHAT?" Nothing
772− "I am expecting commands like:"
773− [ D.green $ D.indent 4 $ D.vcat $
774− [ "elm install elm/http"
775− , "elm install elm/json"
776− , "elm install elm/random"
777− ]
778− , D.toFancyHint
779− ["In","JavaScript","folks","run","`npm install`","to","start","projects."
780− ,"\"Gotta","download","everything!\"","But","why","download","packages"
781− ,"again","and","again?","Instead,","Elm","caches","packages","in"
782− ,D.dullyellow (D.fromChars elmHome)
783− ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
784− ,"Elm","projects","check","that","cache","before","trying","the","internet."
785− ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
786− ,"easier","to","work","offline.","As","a","result"
787− ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
788− ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
789− ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
790− ]
791− ]
792−
793− InstallNoOnlineAppSolution pkg ->
794− Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
795− (
796− "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
797− \ with your existing dependencies."
798− )
799− [ D.reflow $
800− "I checked all the published versions. When that failed, I tried to find any\
801− \ compatible combination of these packages, even if it meant changing all your\
802− \ existing dependencies! That did not work either!"
803− , D.reflow $
804− "This is most likely to happen when a package is not upgraded yet. Maybe a new\
805− \ version of Elm came out recently? Maybe a common package was changed recently?\
806− \ Maybe a better package came along, so there was no need to upgrade this one?\
807− \ Try asking around https://elm-lang.org/community to learn what might be going on\
808− \ with this package."
809− , D.toSimpleNote $
810− "Whatever the case, please be kind to the relevant package authors! Having\
811− \ friendly interactions with users is great motivation, and conversely, getting\
812− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
813− \ authors are humans with families, friends, jobs, vacations, responsibilities,\
814− \ goals, etc. They face obstacles outside of their technical work you will never\
815− \ know about, so please assume the best and try to be patient and supportive!"
816− ]
817−
818− InstallNoOfflineAppSolution pkg ->
819− Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
820− (
821− "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
822− \ with your existing dependencies."
823− )
824− [ D.reflow $
825− "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
826− \ able to look through packages that you have downloaded in the past."
827− , D.reflow $
828− "Try again later when you have internet!"
829− ]
830−
831− InstallNoOnlinePkgSolution pkg ->
832− Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
833− (
834− "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
835− \ with your existing constraints."
836− )
837− [ D.reflow $
838− "With applications, I try to broaden the constraints to see if anything works,\
839− \ but messing with package constraints is much more delicate business. E.g. making\
840− \ your constraints stricter may make it harder for applications to find compatible\
841− \ dependencies. So fixing something here may break it for a lot of other people!"
842− , D.reflow $
843− "So I recommend making an application with the same dependencies as your package.\
844− \ See if there is a solution at all. From there it may be easier to figure out\
845− \ how to proceed in a way that will disrupt your users as little as possible. And\
846− \ the solution may be to help other package authors to get their packages updated,\
847− \ or to drop a dependency entirely."
848− ]
849−
850− InstallNoOfflinePkgSolution pkg ->
851− Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
852− (
853− "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
854− \ with your existing constraints."
855− )
856− [ D.reflow $
857− "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
858− \ able to look through packages that you have downloaded in the past."
859− , D.reflow $
860− "Try again later when you have internet!"
861− ]
862−
863− InstallHadSolverTrouble solver ->
864− toSolverReport solver
865−
866− InstallUnknownPackageOnline pkg suggestions ->
867− Help.docReport "UNKNOWN PACKAGE" Nothing
868− (
869− D.fillSep
870− ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
871− )
872− [ D.reflow $
873− "I looked through https://package.elm-lang.org for packages with similar names\
874− \ and found these:"
875− , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
876− , D.reflow $ "Maybe you want one of these instead?"
877− ]
878−
879− InstallUnknownPackageOffline pkg suggestions ->
880− Help.docReport "UNKNOWN PACKAGE" Nothing
881− (
882− D.fillSep
883− ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
884− )
885− [ D.reflow $
886− "I could not connect to https://package.elm-lang.org though, so new packages may\
887− \ have been published since I last updated my local cache of package names."
888− , D.reflow $
889− "Looking through the locally cached names, the closest ones are:"
890− , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
891− , D.reflow $ "Maybe you want one of these instead?"
892− ]
893−
894− InstallBadDetails details ->
895− toDetailsReport details
896−
897−
898−
899−-- SOLVER
900−
901−
902−data Solver
903− = SolverBadCacheData Pkg.Name V.Version
904− | SolverBadHttpData Pkg.Name V.Version String
905− | SolverBadHttp Pkg.Name V.Version Http.Error
906−
907−
908−toSolverReport :: Solver -> Help.Report
909−toSolverReport problem =
910− case problem of
911− SolverBadCacheData pkg vsn ->
912− Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
913− (
914− "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
915− \ help me search for a set of compatible packages. I had it cached locally, but\
916− \ it looks like the file was corrupted!"
917− )
918− [ D.reflow $
919− "I deleted the cached version, so the next run should download a fresh copy.\
920− \ Hopefully that will get you unstuck, but it will not resolve the root\
921− \ problem if a 3rd party tool is modifing cached files for some reason."
922− ]
923−
924− SolverBadHttpData pkg vsn url ->
925− Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
926− (
927− "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
928− \ help me search for a set of compatible packages, but I ran into corrupted\
929− \ information from:"
930− )
931− [ D.indent 4 $ D.dullyellow $ D.fromChars url
932− , D.reflow $
933− "Is something weird with your internet connection. We have gotten reports that\
934− \ schools, businesses, airports, etc. sometimes intercept requests and add things\
935− \ to the body or change its contents entirely. Could that be the problem?"
936− ]
937−
938− SolverBadHttp pkg vsn httpError ->
939− toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
940− "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
941− ++ " to help me search for a set of compatible packages"
942−
943−
944−
945−-- OUTLINE
946−
947−
948−data Outline
949− = OutlineHasBadStructure (Decode.Error OutlineProblem)
950− | OutlineHasMissingSrcDirs FilePath [FilePath]
951− | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952− | OutlineNoPkgCore
953− | OutlineNoAppCore
954− | OutlineNoAppJson
955−
956−
957−data OutlineProblem
958− = OP_BadType
959− | OP_BadPkgName Row Col
960− | OP_BadVersion Row Col
961− | OP_BadConstraint C.Error
962− | OP_BadModuleName Row Col
963− | OP_BadModuleHeaderTooLong
964− | OP_BadDependencyName Row Col
965− | OP_BadLicense Json.String [Json.String]
966− | OP_BadSummaryTooLong
967− | OP_NoSrcDirs
968−
969−
970−toOutlineReport :: Outline -> Help.Report
971−toOutlineReport problem =
972− case problem of
973− OutlineHasBadStructure decodeError ->
974− Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
975− Json.ExplicitReason "I ran into a problem with your elm.json file."
976−
977− OutlineHasMissingSrcDirs dir dirs ->
978− case dirs of
979− [] ->
980− Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
981− "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
982− [ D.indent 4 $ D.red $ D.fromChars dir
983− , D.reflow $
984− "I cannot find it though. Is it missing? Is there a typo?"
985− ]
986−
987− _:_ ->
988− Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
989− "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
990− [ D.indent 4 $ D.vcat $
991− map (D.red . D.fromChars) (dir:dirs)
992− , D.reflow $
993− "I cannot find them though. Are they missing? Are there typos?"
994− ]
995−
996− OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
997− if dir1 == dir2 then
998− Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
999− "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
1000− [ D.indent 4 $ D.vcat $
1001− map (D.red . D.fromChars) [dir1,dir2]
1002− , D.reflow $
1003− "Remove one of the entries!"
1004− ]
1005− else
1006− Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
1007− "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
1008− [ D.indent 4 $ D.vcat $
1009− map (D.red . D.fromChars) [dir1,dir2]
1010− , D.reflow $
1011− "These are two different ways of refering to the same directory:"
1012− , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
1013− , D.reflow $
1014− "Remove one of the redundant entries from your \"source-directories\" field."
1015− ]
1016−
1017− OutlineNoPkgCore ->
1018− Help.report "MISSING DEPENDENCY" (Just "elm.json")
1019− "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1020− \ of `List` and `Maybe` do not work without it."
1021− [ D.reflow $
1022− "If you modified your elm.json by hand, try to change it back! And if you are\
1023− \ having trouble getting back to a working elm.json, it may be easier to find a\
1024− \ working package and start fresh with their elm.json file."
1025− ]
1026−
1027− OutlineNoAppCore ->
1028− Help.report "MISSING DEPENDENCY" (Just "elm.json")
1029− "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1030− \ of `List` and `Maybe` do not work without it."
1031− [ D.reflow $
1032− "If you modified your elm.json by hand, try to change it back! And if you are\
1033− \ having trouble getting back to a working elm.json, it may be easier to delete it\
1034− \ and use `elm init` to start fresh."
1035− ]
1036−
1037− OutlineNoAppJson ->
1038− Help.report "MISSING DEPENDENCY" (Just "elm.json")
1039− "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
1040− \ flags and ports."
1041− [ D.reflow $
1042− "If you modified your elm.json by hand, try to change it back! And if you are\
1043− \ having trouble getting back to a working elm.json, it may be easier to delete it\
1044− \ and use `elm init` to start fresh."
1045− ]
1046−
1047−
1048−toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
1049−toOutlineProblemReport path source _ region problem =
1050− let
1051− toHighlight row col =
1052− Just $ A.Region (A.Position row col) (A.Position row col)
1053−
1054− toSnippet title highlight pair =
1055− Help.jsonReport title (Just path) $
1056− Code.toSnippet source region highlight pair
1057− in
1058− case problem of
1059− OP_BadType ->
1060− toSnippet "UNEXPECTED TYPE" Nothing
1061− ( D.reflow $
1062− "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
1063− , D.fillSep
1064− ["Try","changing","the","\"type\"","to"
1065− ,D.green "\"application\"","or",D.green "\"package\"","instead."
1066− ]
1067− )
1068−
1069− OP_BadPkgName row col ->
1070− toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
1071− ( D.reflow $
1072− "I got stuck while reading your elm.json file. I ran into trouble with the package name:"
1073− , D.stack
1074− [ D.fillSep
1075− ["Package","names","are","always","written","as"
1076− ,D.green "\"author/project\""
1077− ,"so","I","am","expecting","to","see","something","like:"
1078− ]
1079− , D.dullyellow $ D.indent 4 $ D.vcat $
1080− [ "\"mdgriffith/elm-ui\""
1081− , "\"w0rm/elm-physics\""
1082− , "\"Microsoft/elm-json-tree-view\""
1083− , "\"FordLabs/elm-star-rating\""
1084− , "\"1602/json-schema\""
1085− ]
1086− , D.reflow
1087− "The author name should match your GitHub name exactly, and the project name\
1088− \ needs to follow these rules:"
1089− , D.indent 4 $ D.vcat $
1090− [ "+--------------------------------------+-----------+-----------+"
1091− , "| RULE | BAD | GOOD |"
1092− , "+--------------------------------------+-----------+-----------+"
1093− , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
1094− , "| no leading digits | 3D | elm-3d |"
1095− , "| no non-ASCII characters | elm-bjørn | elm-bear |"
1096− , "| no underscores | elm_ui | elm-ui |"
1097− , "| no double hyphens | elm--hash | elm-hash |"
1098− , "| no starting or ending hyphen | -elm-tar- | elm-tar |"
1099− , "+--------------------------------------+-----------+-----------+"
1100− ]
1101− , D.toSimpleNote $
1102− "These rules only apply to the project name, so you should never need\
1103− \ to change your GitHub name!"
1104− ]
1105− )
1106−
1107− OP_BadVersion row col ->
1108− toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
1109− ( D.reflow $
1110− "I got stuck while reading your elm.json file. I was expecting a version number here:"
1111− , D.fillSep
1112− ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
1113− ,"that","explicitly","states","all","three","numbers!"
1114− ]
1115− )
1116−
1117− OP_BadConstraint constraintError ->
1118− case constraintError of
1119− C.BadFormat row col ->
1120− toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
1121− ( D.reflow $
1122− "I got stuck while reading your elm.json file. I do not understand this version constraint:"
1123− , D.stack
1124− [ D.fillSep
1125− ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
1126− ,"that","explicitly","lists","the","lower","and","upper","bounds."
1127− ]
1128− , D.toSimpleNote $
1129− "The spaces in there are required! Taking them out will confuse me. Adding\
1130− \ extra spaces confuses me too. I recommend starting with a valid example\
1131− \ and just changing the version numbers."
1132− ]
1133− )
1134−
1135− C.InvalidRange before after ->
1136− if before == after then
1137− toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1138− ( D.reflow $
1139− "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1140− , D.fillSep
1141− ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
1142− ,"so","it","is","best","to","use","wide","constraints.","I","recommend"
1143− ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
1144− ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
1145− ,"happen","in","any","of","the","versions","in","that","range."
1146− ]
1147− )
1148−
1149− else
1150− toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1151− ( D.reflow $
1152− "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1153− , D.fillSep
1154− ["Maybe","you","want","something","like"
1155− ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
1156− ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
1157− ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
1158− ,"cannot","happen","in","any","of","the","versions","in","that","range."
1159− ]
1160− )
1161−
1162− OP_BadModuleName row col ->
1163− toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
1164− ( D.reflow $
1165− "I got stuck while reading your elm.json file. I was expecting a module name here:"
1166− , D.fillSep
1167− ["I","need","something","like",D.green "\"Html.Events\""
1168− ,"or",D.green "\"Browser.Navigation\""
1169− ,"where","each","segment","starts","with","a","capital"
1170− ,"letter","and","the","segments","are","separated","by","dots."
1171− ]
1172− )
1173−
1174− OP_BadModuleHeaderTooLong ->
1175− toSnippet "HEADER TOO LONG" Nothing
1176− ( D.reflow $
1177− "I got stuck while reading your elm.json file. This section header is too long:"
1178− , D.stack
1179− [ D.fillSep
1180− ["I","need","it","to","be"
1181− ,D.green "under",D.green "20",D.green "bytes"
1182− ,"so","it","renders","nicely","on","the","package","website!"
1183− ]
1184− , D.toSimpleNote
1185− "I count the length in bytes, so using non-ASCII characters costs extra.\
1186− \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1187− \ overly restrictive for your needs."
1188− ]
1189− )
1190−
1191− OP_BadDependencyName row col ->
1192− toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
1193− ( D.reflow $
1194− "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
1195− , D.stack
1196− [ D.fillSep
1197− ["Package","names","always","include","the","name","of","the","author,"
1198− ,"so","I","am","expecting","to","see","dependencies","like"
1199− ,D.dullyellow "\"mdgriffith/elm-ui\"","and"
1200− ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
1201− ]
1202− , D.fillSep $
1203− ["I","generally","recommend","finding","the","package","you","want","on"
1204− ,"the","package","website,","and","installing","it","with","the"
1205− ,D.green "elm install","command!"
1206− ]
1207− ]
1208− )
1209−
1210− OP_BadLicense _ suggestions ->
1211− toSnippet "UNKNOWN LICENSE" Nothing
1212− ( D.reflow $
1213− "I got stuck while reading your elm.json file. I do not know about this type of license:"
1214− ,
1215− D.stack
1216− [ D.fillSep
1217− ["Elm","packages","generally","use"
1218− ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
1219− ,"but","I","accept","any","OSI","approved","SPDX","license."
1220− ,"Here","some","that","seem","close","to","what","you","wrote:"
1221− ]
1222− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
1223− , D.reflow $
1224− "Check out https://spdx.org/licenses/ for the full list of options."
1225− ]
1226− )
1227−
1228− OP_BadSummaryTooLong ->
1229− toSnippet "SUMMARY TOO LONG" Nothing
1230− ( D.reflow $
1231− "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
1232− , D.stack
1233− [ D.fillSep
1234− ["I","need","it","to","be"
1235− ,D.green "under",D.green "80",D.green "bytes"
1236− ,"so","it","renders","nicely","on","the","package","website!"
1237− ]
1238− , D.toSimpleNote
1239− "I count the length in bytes, so using non-ASCII characters costs extra.\
1240− \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1241− \ overly restrictive for your needs."
1242− ]
1243− )
1244−
1245− OP_NoSrcDirs ->
1246− toSnippet "NO SOURCE DIRECTORIES" Nothing
1247− ( D.reflow $
1248− "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
1249− , D.fillSep
1250− ["I","need","something","like",D.green "[\"src\"]"
1251− ,"so","I","know","where","to","look","for","your","modules!"
1252− ]
1253− )
1254−
1255−
1256−
1257−-- DETAILS
1258−
1259−
1260−data Details
1261− = DetailsNoSolution
1262− | DetailsNoOfflineSolution
1263− | DetailsSolverProblem Solver
1264− | DetailsBadElmInPkg C.Constraint
1265− | DetailsBadElmInAppOutline V.Version
1266− | DetailsHandEditedDependencies
1267− | DetailsBadOutline Outline
1268− | DetailsCannotGetRegistry RegistryProblem
1269− | DetailsBadDeps FilePath [DetailsBadDep]
1270−
1271−
1272−data DetailsBadDep
1273− = BD_BadDownload Pkg.Name V.Version PackageProblem
1274− | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)
1275−
1276−
1277−toDetailsReport :: Details -> Help.Report
1278−toDetailsReport details =
1279− case details of
1280− DetailsNoSolution ->
1281− Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json")
1282− "The dependencies in your elm.json are not compatible."
1283− [ D.fillSep
1284− ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
1285− ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1286− ]
1287− , D.reflow $
1288− "Please ask for help on the community forums if you try those paths and are still\
1289− \ having problems!"
1290− ]
1291−
1292− DetailsNoOfflineSolution ->
1293− Help.report "TROUBLE VERIFYING DEPENDENCIES" (Just "elm.json")
1294− "I could not connect to https://package.elm-lang.org to get the latest list of\
1295− \ packages, and I was unable to verify your dependencies with the information I\
1296− \ have cached locally."
1297− [ D.reflow $
1298− "Are you able to connect to the internet? These dependencies may work once you\
1299− \ get access to the registry!"
1300− , D.toFancyNote
1301− ["If","you","changed","your","dependencies","by","hand,","try","to","change","them","back!"
1302− ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1303− ]
1304− ]
1305−
1306− DetailsSolverProblem solver ->
1307− toSolverReport solver
1308−
1309− DetailsBadElmInPkg constraint ->
1310− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1311− "Your elm.json says this package needs a version of Elm in this range:"
1312− [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
1313− , D.fillSep
1314− [ "But", "you", "are", "using", "Elm"
1315− , D.red (D.fromVersion V.compiler)
1316− , "right", "now."
1317− ]
1318− ]
1319−
1320− DetailsBadElmInAppOutline version ->
1321− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1322− "Your elm.json says this application needs a different version of Elm."
1323− [ D.fillSep
1324− [ "It", "requires"
1325− , D.green (D.fromVersion version) <> ","
1326− , "but", "you", "are", "using"
1327− , D.red (D.fromVersion V.compiler)
1328− , "right", "now."
1329− ]
1330− ]
1331−
1332− DetailsHandEditedDependencies ->
1333− Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
1334− "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
1335− \ party tool) leaving them in an invalid state."
1336− [ D.fillSep
1337− ["Try","to","change","them","back","to","what","they","were","before!"
1338− ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1339− ]
1340− , D.reflow $
1341− "Please ask for help on the community forums if you try those paths and are still\
1342− \ having problems!"
1343− ]
1344−
1345− DetailsBadOutline outline ->
1346− toOutlineReport outline
1347−
1348− DetailsCannotGetRegistry problem ->
1349− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
1350− "I need the list of published packages to verify your dependencies"
1351−
1352− DetailsBadDeps cacheDir deps ->
1353− case List.sortOn toBadDepRank deps of
1354− [] ->
1355− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1356− "I am not sure what is going wrong though."
1357− [ D.reflow $
1358− "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
1359− \ trying to build again. That will work if some cached files got corrupted\
1360− \ somehow."
1361− , D.reflow $
1362− "If that does not work, go to https://elm-lang.org/community and ask for\
1363− \ help. This is a weird case!"
1364− ]
1365−
1366− d:_ ->
1367− case d of
1368− BD_BadDownload pkg vsn packageProblem ->
1369− toPackageProblemReport pkg vsn packageProblem
1370−
1371− BD_BadBuild pkg vsn fingerprint ->
1372− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1373− "I ran into a compilation error when trying to build the following package:"
1374− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
1375− , D.reflow $
1376− "This probably means it has package constraints that are too wide. It may be\
1377− \ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\
1378− \ over to https://elm-lang.org/community to get help figuring out how to take\
1379− \ this path!"
1380− , D.toSimpleNote $
1381− "To help with the root problem, please report this to the package author along\
1382− \ with the following information:"
1383− , D.indent 4 $ D.vcat $
1384− map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $
1385− Map.toList fingerprint
1386− , D.reflow $
1387− "If you want to help out even more, try building the package locally. That should\
1388− \ give you much more specific information about why this package is failing to\
1389− \ build, which will in turn make it easier for the package author to fix it!"
1390− ]
1391−
1392−
1393−toBadDepRank :: DetailsBadDep -> Int -- lower is better
1394−toBadDepRank badDep =
1395− case badDep of
1396− BD_BadDownload _ _ _ -> 0
1397− BD_BadBuild _ _ _ -> 1
1398−
1399−
1400−
1401−-- PACKAGE PROBLEM
1402−
1403−
1404−data PackageProblem
1405− = PP_BadEndpointRequest Http.Error
1406− | PP_BadEndpointContent String
1407− | PP_BadArchiveRequest Http.Error
1408− | PP_BadArchiveContent String
1409− | PP_BadArchiveHash String String String
1410−
1411−
1412−toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report
1413−toPackageProblemReport pkg vsn problem =
1414− let
1415− thePackage =
1416− Pkg.toChars pkg ++ " " ++ V.toChars vsn
1417− in
1418− case problem of
1419− PP_BadEndpointRequest httpError ->
1420− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1421− "I need to find the latest download link for " ++ thePackage
1422−
1423− PP_BadEndpointContent url ->
1424− Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1425− (
1426− "I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:"
1427− )
1428− [ D.indent 4 $ D.dullyellow $ D.fromChars url
1429− , D.reflow $
1430− "Is something weird with your internet connection. We have gotten reports that\
1431− \ schools, businesses, airports, etc. sometimes intercept requests and add things\
1432− \ to the body or change its contents entirely. Could that be the problem?"
1433− ]
1434−
1435− PP_BadArchiveRequest httpError ->
1436− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1437− "I was trying to download the source code for " ++ thePackage
1438−
1439− PP_BadArchiveContent url ->
1440− Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1441− (
1442− "I downloaded the source code for " ++ thePackage ++ " from:"
1443− )
1444− [ D.indent 4 $ D.dullyellow $ D.fromChars url
1445− , D.reflow $
1446− "But I was unable to unzip the data. Maybe there is something weird with\
1447− \ your internet connection. We have gotten reports that schools, businesses,\
1448− \ airports, etc. sometimes intercept requests and add things to the body or\
1449− \ change its contents entirely. Could that be the problem?"
1450− ]
1451−
1452− PP_BadArchiveHash url expectedHash actualHash ->
1453− Help.report "CORRUPT PACKAGE DATA" Nothing
1454− (
1455− "I downloaded the source code for " ++ thePackage ++ " from:"
1456− )
1457− [ D.indent 4 $ D.dullyellow $ D.fromChars url
1458− , D.reflow "But it looks like the hash of the archive has changed since publication:"
1459− , D.vcat $ map D.fromChars $
1460− [ " Expected: " ++ expectedHash
1461− , " Actual: " ++ actualHash
1462− ]
1463− , D.reflow $
1464− "This usually means that the package author moved the version\
1465− \ tag, so report it to them and see if that is the issue. Folks\
1466− \ on Elm slack can probably help as well."
1467− ]
1468−
1469−
1470−
1471−-- REGISTRY PROBLEM
1472−
1473−
1474−data RegistryProblem
1475− = RP_Http Http.Error
1476− | RP_Data String BS.ByteString
1477−
1478−
1479−toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report
1480−toRegistryProblemReport title problem context =
1481− case problem of
1482− RP_Http err ->
1483− toHttpErrorReport title err context
1484−
1485− RP_Data url body ->
1486− Help.report title Nothing (context ++ ", so I fetched:")
1487− [ D.indent 4 $ D.dullyellow $ D.fromChars url
1488− , D.reflow $
1489− "I got the data back, but it was not what I was expecting. The response\
1490− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
1491− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
1492− , D.indent 4 $ D.dullyellow $ D.fromChars $
1493− if BS.length body <= 76
1494− then BS_UTF8.toString body
1495− else take 73 (BS_UTF8.toString body) ++ "..."
1496− , D.reflow $
1497− "Does this error keep showing up? Maybe there is something weird with your\
1498− \ internet connection. We have gotten reports that schools, businesses,\
1499− \ airports, etc. sometimes intercept requests and add things to the body\
1500− \ or change its contents entirely. Could that be the problem?"
1501− ]
1502−
1503−
1504−toHttpErrorReport :: String -> Http.Error -> String -> Help.Report
1505−toHttpErrorReport title err context =
1506− let
1507− toHttpReport intro url details =
1508− Help.report title Nothing intro $
1509− D.indent 4 (D.dullyellow (D.fromChars url)) : details
1510− in
1511− case err of
1512− Http.BadUrl url reason ->
1513− toHttpReport (context ++ ", so I wanted to fetch:") url
1514− [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"
1515− , D.indent 4 $ D.fromChars reason
1516− , D.reflow $
1517− "This may indicate that there is some problem in the compiler, so please open an\
1518− \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\
1519− \ version, the command you ran, the terminal output, and any additional information\
1520− \ that might help others reproduce the error."
1521− ]
1522−
1523− Http.BadHttp url httpExceptionContent ->
1524− case httpExceptionContent of
1525− HTTP.StatusCodeException response body ->
1526− let
1527− (HTTP.Status code message) = HTTP.responseStatus response
1528− in
1529− toHttpReport (context ++ ", so I tried to fetch:") url
1530− [ D.fillSep $
1531− ["But","it","came","back","as",D.red (D.fromInt code)]
1532− ++ map D.fromChars (words (BS_UTF8.toString message))
1533− , D.indent 4 $ D.reflow $ BS_UTF8.toString body
1534− , D.reflow $
1535− "This may mean some online endpoint changed in an unexpected way, so if does not\
1536− \ seem like something on your side is causing this (e.g. firewall) please report\
1537− \ this to https://github.com/elm/compiler/issues with your operating system, Elm\
1538− \ version, the command you ran, the terminal output, and any additional information\
1539− \ that can help others reproduce the error!"
1540− ]
1541−
1542− HTTP.TooManyRedirects responses ->
1543− toHttpReport (context ++ ", so I tried to fetch:") url
1544− [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"
1545− , D.indent 4 $ D.vcat $ map toRedirectDoc responses
1546− , D.reflow $
1547− "Is it possible that your internet connection intercepts certain requests? That\
1548− \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1549− \ and certain countries. Try asking for help locally or in a community forum!"
1550− ]
1551−
1552− otherException ->
1553− toHttpReport (context ++ ", so I tried to fetch:") url
1554− [ D.reflow $ "But my HTTP library is giving me the following error message:"
1555− , D.indent 4 $ D.fromChars (show otherException)
1556− , D.reflow $
1557− "Are you somewhere with a slow internet connection? Or no internet?\
1558− \ Does the link I am trying to fetch work in your browser? Maybe the\
1559− \ site is down? Does your internet connection have a firewall that\
1560− \ blocks certain domains? It is usually something like that!"
1561− ]
1562−
1563− Http.BadMystery url someException ->
1564− toHttpReport (context ++ ", so I tried to fetch:") url
1565− [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"
1566− , D.indent 4 $ D.fromChars (show someException)
1567− , D.reflow $
1568− "Is it possible that your internet connection intercepts certain requests? That\
1569− \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1570− \ and certain countries. Try asking for help locally or in a community forum!"
1571− ]
1572−
1573−
1574−toRedirectDoc :: HTTP.Response body -> D.Doc
1575−toRedirectDoc response =
1576− let
1577− (HTTP.Status code message) = HTTP.responseStatus response
1578− in
1579− case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of
1580− Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)
1581− Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)
1582−
1583−
1584−
1585−-- MAKE
1586−
1587−
1588−data Make
1589− = MakeNoOutline
1590− | MakeCannotOptimizeAndDebug
1591− | MakeBadDetails Details
1592− | MakeAppNeedsFileNames
1593− | MakePkgNeedsExposing
1594− | MakeMultipleFilesIntoHtml
1595− | MakeNoMain
1596− | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1597− | MakeCannotBuild BuildProblem
1598− | MakeBadGenerate Generate
1599−
1600−
1601−makeToReport :: Make -> Help.Report
1602−makeToReport make =
1603− case make of
1604− MakeNoOutline ->
70+ NoElmJson ->
160571 Help.report "NO elm.json FILE" Nothing
160672 "It looks like you are starting a new Elm project. Very exciting! Try running:"
160773 [ D.indent 4 $ D.green $ "elm init"
@@ -1609,461 +75,44 @@ makeToReport make =
160975 "It will help you get set up. It is really simple!"
161076 ]
161177
1612− MakeCannotOptimizeAndDebug ->
1613− Help.docReport "CLASHING FLAGS" Nothing
1614− ( D.fillSep
1615− ["I","cannot","compile","with",D.red "--optimize","and"
1616− ,D.red "--debug","at","the","same","time."
1617− ]
1618− )
1619− [ D.reflow
1620− "I need to take away information to optimize things, and I need to\
1621− \ add information to add the debugger. It is impossible to do both\
1622− \ at once though! Pick just one of those flags and it should work!"
1623− ]
1624−
1625− MakeBadDetails detailsProblem ->
1626− toDetailsReport detailsProblem
1627−
1628− MakeAppNeedsFileNames ->
1629− Help.report "NO INPUT" Nothing
1630− "What should I make though? I need specific files like:"
1631− [ D.vcat
1632− [ D.indent 4 $ D.green "elm make src/Main.elm"
1633− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1634− ]
1635− , D.reflow $
1636− "I recommend reading through https://guide.elm-lang.org for guidance on what to\
1637− \ actually put in those files!"
1638− ]
1639−
1640− MakePkgNeedsExposing ->
1641− Help.report "NO INPUT" Nothing
1642− "What should I make though? I need specific files like:"
1643− [ D.vcat
1644− [ D.indent 4 $ D.green "elm make src/Main.elm"
1645− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1646− ]
1647− , D.reflow $
1648− "You can also entries to the \"exposed-modules\" list in your elm.json file, and\
1649− \ I will try to compile the relevant files."
1650− ]
1651−
1652− MakeMultipleFilesIntoHtml ->
1653− Help.report "TOO MANY FILES" Nothing
1654− (
1655− "When producing an HTML file, I can only handle one file."
1656− )
1657− [ D.fillSep
1658− ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"
1659− ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"
1660− ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."
1661− ]
1662− , D.fillSep
1663− ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"
1664− ,"`main`","values","available","in","a","single","JavaScript","file.","Then"
1665− ,"you","can","make","your","own","customized","HTML","file","that","embeds"
1666− ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"
1667− ,"dependencies","between","modules,","so","it","should","be","smaller","than"
1668− ,"compiling","each","module","separately."
1669− ]
1670− ]
1671−
1672− MakeNoMain ->
1673− Help.report "NO MAIN" Nothing
1674− (
1675− "When producing an HTML file, I require that the given file has a `main` value.\
1676− \ That way I have something to show on screen!"
1677− )
1678− [ D.reflow $
1679− "Try adding a `main` value to your file? Or if you just want to verify that this\
1680− \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1681− \ altogether."
1682− , D.toSimpleNote $
1683− "Adding a `main` value can be as brief as adding something like this:"
1684− , D.vcat
1685− [ D.fillSep [D.cyan "import","Html"]
1686− , ""
1687− , D.fillSep [D.green "main","="]
1688− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1689− ]
1690− , D.reflow $
1691− "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\
1692− \ looking through https://guide.elm-lang.org for more guidance on how to fill in\
1693− \ the `main` value."
1694− ]
1695−
1696− MakeNonMainFilesIntoJavaScript m ms ->
1697− case ms of
1698− [] ->
1699− Help.report "NO MAIN" Nothing
1700− (
1701− "When producing a JS file, I require that the given file has a `main` value. That\
1702− \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\
1703− \ resulting file!"
1704− )
1705− [ D.reflow $
1706− "Try adding a `main` value to your file? Or if you just want to verify that this\
1707− \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1708− \ altogether."
1709− , D.toSimpleNote $
1710− "Adding a `main` value can be as brief as adding something like this:"
1711− , D.vcat
1712− [ D.fillSep [D.cyan "import","Html"]
1713− , ""
1714− , D.fillSep [D.green "main","="]
1715− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1716− ]
1717− , D.reflow $
1718− "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1719− \ make a `main` with no user interface."
1720− ]
1721−
1722− _:_ ->
1723− Help.report "NO MAIN" Nothing
1724− (
1725− "When producing a JS file, I require that given files all have `main` values.\
1726− \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\
1727− \ definitely defined in the resulting file. I am missing `main` values in:"
1728− )
1729− [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)
1730− , D.reflow $
1731− "Try adding a `main` value to them? Or if you just want to verify that these\
1732− \ modules compile, switch to --output=/dev/null to skip the code gen phase\
1733− \ altogether."
1734− , D.toSimpleNote $
1735− "Adding a `main` value can be as brief as adding something like this:"
1736− , D.vcat
1737− [ D.fillSep [D.cyan "import","Html"]
1738− , ""
1739− , D.fillSep [D.green "main","="]
1740− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1741− ]
1742− , D.reflow $
1743− "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1744− \ make a `main` with no user interface."
1745− ]
1746−
1747− MakeCannotBuild buildProblem ->
1748− toBuildProblemReport buildProblem
1749−
1750− MakeBadGenerate generateProblem ->
1751− toGenerateReport generateProblem
1752−
1753−
1754−
1755−-- BUILD PROBLEM
1756−
1757−
1758−data BuildProblem
1759− = BuildBadModules FilePath Error.Module [Error.Module]
1760− | BuildProjectProblem BuildProjectProblem
1761−
1762−
1763−data BuildProjectProblem
1764− = BP_PathUnknown FilePath
1765− | BP_WithBadExtension FilePath
1766− | BP_WithAmbiguousSrcDir FilePath FilePath FilePath
1767− | BP_MainPathDuplicate FilePath FilePath
1768− | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath
1769− | BP_RootNameInvalid FilePath FilePath [String]
1770− | BP_CannotLoadDependencies
1771− | BP_Cycle ModuleName.Raw [ModuleName.Raw]
1772− | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
1773−
1774−
1775−toBuildProblemReport :: BuildProblem -> Help.Report
1776−toBuildProblemReport problem =
1777− case problem of
1778− BuildBadModules root e es ->
1779− Help.compilerReport root e es
1780−
1781− BuildProjectProblem projectProblem ->
1782− toProjectProblemReport projectProblem
1783−
1784−
1785−toProjectProblemReport :: BuildProjectProblem -> Help.Report
1786−toProjectProblemReport projectProblem =
1787− case projectProblem of
1788− BP_PathUnknown path ->
1789− Help.report "FILE NOT FOUND" Nothing
1790− "I cannot find this file:"
1791− [ D.indent 4 $ D.red $ D.fromChars path
1792− , D.reflow $ "Is there a typo?"
1793− , D.toSimpleNote $
1794− "If you are just getting started, try working through the examples in the\
1795− \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\
1796− \ that typically go in a src/Main.elm file."
1797− ]
1798−
1799− BP_WithBadExtension path ->
1800− Help.report "UNEXPECTED FILE EXTENSION" Nothing
1801− "I can only compile Elm files (with a .elm extension) but you want me to compile:"
1802− [ D.indent 4 $ D.red $ D.fromChars path
1803− , D.reflow $ "Is there a typo? Can the file extension be changed?"
1804− ]
1805−
1806− BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->
1807− Help.report "CONFUSING FILE" Nothing
1808− "I am getting confused when I try to compile this file:"
1809− [ D.indent 4 $ D.red $ D.fromChars path
1810− , D.reflow $
1811− "I always check if files appear in any of the \"source-directories\" listed in\
1812− \ your elm.json to see if there might be some cached information about them. That\
1813− \ can help me compile faster! But in this case, it looks like this file may be in\
1814− \ either of these directories:"
1815− , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]
1816− , D.reflow $
1817− "Try to make it so no source directory contains another source directory!"
1818− ]
78+ Assets assetExit ->
79+ Asset.toReport assetExit
181980
1820− BP_MainPathDuplicate path1 path2 ->
1821− Help.report "CONFUSING FILES" Nothing
1822− "You are telling me to compile these two files:"
1823− [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]
1824− , D.reflow $
1825− if path1 == path2 then
1826− "Why are you telling me twice? Is something weird going on with a script?\
1827− \ I figured I would let you know about it just in case something is wrong.\
1828− \ Only list it once and you should be all set!"
1829− else
1830− "But seem to be the same file though... It makes me think something tricky is\
1831− \ going on with symlinks in your project, so I figured I would let you know\
1832− \ about it just in case. Remove one of these files from your command to get\
1833− \ unstuck!"
1834− ]
1835−
1836− BP_RootNameDuplicate name outsidePath otherPath ->
1837− Help.report "MODULE NAME CLASH" Nothing
1838− "These two files are causing a module name clash:"
1839− [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]
1840− , D.reflow $
1841− "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\
1842− \ at the top, but they cannot have the same name!"
1843− , D.reflow $
1844− "Try changing to a different module name in one of them!"
1845− ]
81+ Bump bumpExit ->
82+ Bump.toReport bumpExit
184683
1847− BP_RootNameInvalid givenPath srcDir _ ->
1848− Help.report "UNEXPECTED FILE NAME" Nothing
1849− "I am having trouble with this file name:"
1850− [ D.indent 4 $ D.red $ D.fromChars givenPath
1851− , D.reflow $
1852− "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\
1853− \ which is good, but I expect all of the files in there to use the following\
1854− \ module naming convention:"
1855− , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]
1856− , D.reflow $
1857− "Notice that the names always start with capital letters! Can you make your file\
1858− \ use this naming convention?"
1859− , D.toSimpleNote $
1860− "Having a strict naming convention like this makes it a lot easier to find\
1861− \ things in large projects. If you see a module imported, you know where to look\
1862− \ for the corresponding file every time!"
1863− ]
84+ Compile e es ->
85+ Help.compilerReport e es
186486
1865− BP_CannotLoadDependencies ->
1866− corruptCacheReport
87+ Crawl crawlExit ->
88+ Crawl.toReport crawlExit
186789
1868− BP_Cycle name names ->
90+ Cycle names ->
186991 Help.report "IMPORT CYCLE" Nothing
187092 "Your module imports form a cycle:"
1871− [ D.cycle 4 name names
93+ [ D.cycle 4 names
187294 , D.reflow $
187395 "Learn more about why this is disallowed and how to break cycles here:"
187496 ++ D.makeLink "import-cycles"
187597 ]
187698
1877− BP_MissingExposed (NE.List (name, problem) _) ->
1878− case problem of
1879− Import.NotFound ->
1880− Help.report "MISSING MODULE" (Just "elm.json")
1881− "The \"exposed-modules\" of your elm.json lists the following module:"
1882− [ D.indent 4 $ D.red $ D.fromName name
1883− , D.reflow $
1884− "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1885− ]
1886−
1887− Import.Ambiguous _ _ pkg _ ->
1888− Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1889− "The \"exposed-modules\" of your elm.json lists the following module:"
1890− [ D.indent 4 $ D.red $ D.fromName name
1891− , D.reflow $
1892− "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\
1893− \ choosing a different name for your local file."
1894− ]
1895−
1896− Import.AmbiguousLocal path1 path2 paths ->
1897− Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1898− "The \"exposed-modules\" of your elm.json lists the following module:"
1899− [ D.indent 4 $ D.red $ D.fromName name
1900− , D.reflow $
1901− "But I found multiple files with that name:"
1902− , D.dullyellow $ D.indent 4 $ D.vcat $
1903− map D.fromChars (path1:path2:paths)
1904− , D.reflow $
1905− "Change the module names to be distinct!"
1906− ]
1907−
1908− Import.AmbiguousForeign _ _ _ ->
1909− Help.report "MISSING MODULE" (Just "elm.json")
1910− "The \"exposed-modules\" of your elm.json lists the following module:"
1911− [ D.indent 4 $ D.red $ D.fromName name
1912− , D.reflow $
1913− "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1914− , D.toSimpleNote $
1915− "It is not possible to \"re-export\" modules from other packages. You can only\
1916− \ expose modules that you define in your own code."
1917− ]
1918−
1919−
1920−toModuleNameConventionTable :: FilePath -> [String] -> D.Doc
1921−toModuleNameConventionTable srcDir names =
1922− let
1923− toPair name =
1924− ( name
1925− , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"
1926− )
1927−
1928− namePairs = map toPair names
1929− nameWidth = maximum (11 : map (length . fst) namePairs)
1930− pathWidth = maximum ( 9 : map (length . snd) namePairs)
1931−
1932− padded width str =
1933− str ++ replicate (width - length str) ' '
1934−
1935− toRow (name, path) =
1936− D.fromChars $
1937− "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"
1938−
1939− bar =
1940− D.fromChars $
1941− "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"
1942− in
1943− D.indent 4 $ D.vcat $
1944− [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]
1945−
1946−
1947−
1948−-- GENERATE
1949−
1950−
1951−data Generate
1952− = GenerateCannotLoadArtifacts
1953− | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
1954−
1955−
1956−toGenerateReport :: Generate -> Help.Report
1957−toGenerateReport problem =
1958− case problem of
1959− GenerateCannotLoadArtifacts ->
1960− corruptCacheReport
1961−
1962− GenerateCannotOptimizeDebugValues m ms ->
1963− Help.report "DEBUG REMNANTS" Nothing
1964− "There are uses of the `Debug` module in the following modules:"
1965− [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
1966− , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!"
1967− , D.toSimpleNote $
1968− "The issue is that --optimize strips out info needed by `Debug` functions.\
1969− \ Here are two examples:"
1970− , D.indent 4 $ D.reflow $
1971− "(1) It shortens record field names. This makes the generated JavaScript\
1972− \ smaller, but `Debug.toString` cannot know the real field names anymore."
1973− , D.indent 4 $ D.reflow $
1974− "(2) Values like `type Height = Height Float` are unboxed. This reduces\
1975− \ allocation, but it also means that `Debug.toString` cannot tell if it is\
1976− \ looking at a `Height` or `Float` value."
1977− , D.reflow $
1978− "There are a few other cases like that, and it will be much worse once we start\
1979− \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\
1980− \ resulting in unpredictable behavior. I hope that clarifies why this restriction\
1981− \ exists!"
1982− ]
1983−
1984−
1985−
1986−-- CORRUPT CACHE
1987−
1988−
1989−corruptCacheReport :: Help.Report
1990−corruptCacheReport =
1991− Help.report "CORRUPT CACHE" Nothing
1992− "It looks like some of the information cached in elm-stuff/ has been corrupted."
1993− [ D.reflow $
1994− "Try deleting your elm-stuff/ directory to get unstuck."
1995− , D.toSimpleNote $
1996− "This almost certainly means that a 3rd party tool (or editor plugin) is\
1997− \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\
1998− \ one by one until you figure out which it is!"
1999− ]
2000−
2001−
2002−
2003−-- REACTOR
2004−
2005−
2006−data Reactor
2007− = ReactorNoOutline
2008− | ReactorBadDetails Details
2009− | ReactorBadBuild BuildProblem
2010− | ReactorBadGenerate Generate
2011−
2012−
2013−reactorToReport :: Reactor -> Help.Report
2014−reactorToReport problem =
2015− case problem of
2016− ReactorNoOutline ->
2017− Help.report "NEW PROJECT?" Nothing
2018− "Are you trying to start a new project? Try this command in the terminal:"
2019− [ D.indent 4 $ D.green "elm init"
2020− , D.reflow "It will help you get started!"
2021− ]
2022−
2023− ReactorBadDetails details ->
2024− toDetailsReport details
2025−
2026− ReactorBadBuild buildProblem ->
2027− toBuildProblemReport buildProblem
2028−
2029− ReactorBadGenerate generate ->
2030− toGenerateReport generate
2031−
2032−
2033−
2034−-- REPL
2035−
2036−
2037−data Repl
2038− = ReplBadDetails Details
2039− | ReplBadInput BS.ByteString Error.Error
2040− | ReplBadLocalDeps FilePath Error.Module [Error.Module]
2041− | ReplProjectProblem BuildProjectProblem
2042− | ReplBadGenerate Generate
2043− | ReplBadCache
2044− | ReplBlocked
2045−
2046−
2047−replToReport :: Repl -> Help.Report
2048−replToReport problem =
2049− case problem of
2050− ReplBadDetails details ->
2051− toDetailsReport details
99+ Deps depsExit ->
100+ Deps.toReport depsExit
2052101
2053− ReplBadInput source err ->
2054− Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
102+ Diff commandsExit ->
103+ Diff.toReport commandsExit
2055104
2056− ReplBadLocalDeps root e es ->
2057− Help.compilerReport root e es
105+ Make makeExit ->
106+ Make.toReport makeExit
2058107
2059− ReplProjectProblem projectProblem ->
2060− toProjectProblemReport projectProblem
108+ Init initExit ->
109+ Init.toReport initExit
2061110
2062− ReplBadGenerate generate ->
2063− toGenerateReport generate
111+ Install installExit ->
112+ Install.toReport installExit
2064113
2065− ReplBadCache ->
2066− corruptCacheReport
114+ Publish publishExit ->
115+ Publish.toReport publishExit
2067116
2068− ReplBlocked ->
2069− corruptCacheReport
117+ BadHttp url httpExit ->
118+ Http.toReport url httpExit
builder/src/Reporting/Exit/Assets.hsnew file+227
@@ -0,0 +1,227 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Assets
3+ ( Exit(..)
4+ , ElmJsonProblem(..)
5+ , toReport
6+ , BadElmJsonContent(..)
7+ , badContentToDocs
8+ )
9+ where
10+
11+
12+import qualified Data.Text as Text
13+
14+import qualified Elm.Package as Pkg
15+import Reporting.Doc ((<>))
16+import qualified Reporting.Doc as D
17+import qualified Reporting.Exit.Help as Help
18+
19+
20+
21+-- EXITS
22+
23+
24+data Exit
25+ = BadElmJson ElmJsonProblem
26+ | CorruptElmJson Pkg.Name Pkg.Version
27+ | CorruptDocumentation Pkg.Name Pkg.Version
28+ | CorruptBinary FilePath FilePath
29+
30+
31+
32+-- ELM JSON PROBLEM
33+
34+
35+data ElmJsonProblem
36+ = BadJson D.Doc
37+ | BadSrcDir FilePath
38+ | NoPkgCore
39+ | NoAppCore
40+ | NoAppJson
41+
42+
43+
44+-- TO REPORT
45+
46+
47+toReport :: Exit -> Help.Report
48+toReport exit =
49+ case exit of
50+ CorruptElmJson pkg vsn ->
51+ corruptJsonToReport "elm.json" pkg vsn
52+
53+ CorruptDocumentation pkg vsn ->
54+ corruptJsonToReport "docs.json" pkg vsn
55+
56+ CorruptBinary elmHome path ->
57+ Help.report "CORRUPT BINARY" (Just path)
58+ ("The binary data at " ++ path ++ " is corrupt.")
59+ [ D.reflow "Elm caches build artifacts in the following directories:"
60+ , D.dullyellow $ D.indent 4 $ D.vcat $
61+ [ D.fromString elmHome
62+ , "elm-stuff/"
63+ ]
64+ , D.reflow
65+ "Maybe you recently installed a command line tool or editor plugin that messes\
66+ \ with them? They definitely should not be doing that, but you never know! So\
67+ \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
68+ \ help reveal the corrupting influence."
69+ ]
70+
71+ BadElmJson problem ->
72+ elmJsonProblemToReport problem
73+
74+
75+
76+-- CORRUPT JSON
77+
78+
79+corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
80+corruptJsonToReport path pkg vsn =
81+ Help.report "CORRUPT JSON" Nothing
82+ ( "The " ++ path ++ " for " ++ Pkg.toString pkg
83+ ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
84+ )
85+ [ D.reflow $
86+ "I removed it from my file cache, so if it was some transient\
87+ \ error it should be fixed if you try the same thing again.\
88+ \ Please report this if it seems like an Elm problem though!"
89+ ]
90+
91+
92+
93+-- BAD ELM JSON
94+
95+
96+elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
97+elmJsonProblemToReport problem =
98+ case problem of
99+ BadJson doc ->
100+ Help.jsonReport "BAD JSON" (Just "elm.json") doc
101+
102+ BadSrcDir dir ->
103+ Help.report "BAD JSON" (Just "elm.json")
104+ "The \"source-directories\" in your elm.json lists the following directory:"
105+ [ D.indent 4 (D.dullyellow (D.fromString dir))
106+ , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
107+ ]
108+
109+ NoPkgCore ->
110+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
111+ "A package must have \"elm/core\" as a dependency. Try running:"
112+ [ D.indent 4 $ D.green $ "elm install elm/core"
113+ , D.reflow "I need it for the default imports that make `List` and `Maybe` available."
114+ ]
115+
116+ NoAppCore ->
117+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
118+ "An application must have \"elm/core\" as a dependency. Try running:"
119+ [ D.indent 4 $ D.green $ "elm install elm/core"
120+ , D.reflow "It has some supporting code that is needed by every Elm application!"
121+ ]
122+
123+ NoAppJson ->
124+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
125+ "An application must have \"elm/json\" as a dependency. Try running:"
126+ [ D.indent 4 $ D.green $ "elm install elm/json"
127+ , D.reflow "It helps me handle flags and ports."
128+ ]
129+
130+
131+
132+-- PROBLEM TO DOCS
133+
134+
135+data BadElmJsonContent
136+ = BadType Text.Text
137+ | BadPkgName String
138+ | BadVersion Text.Text
139+ | BadConstraint String
140+ | BadModuleName Text.Text
141+ | BadModuleHeaderTooLong Text.Text
142+ | BadDependencyName Text.Text
143+ | BadLicense Text.Text [Text.Text]
144+ | BadDirectoryNotString
145+ | BadSummaryTooLong
146+
147+
148+badContentToDocs :: BadElmJsonContent -> [D.Doc]
149+badContentToDocs badContent =
150+ case badContent of
151+ BadType _ ->
152+ ["The","only","valid","types","of","elm.json","are"
153+ ,D.green "\"application\"","and",D.green "\"package\"" <> "."
154+ ]
155+
156+ BadPkgName problem ->
157+ map D.fromString (words problem)
158+
159+ BadVersion txt ->
160+ ["You","provided",D.red (D.fromString (show txt))
161+ ,"which","is","not","a","valid","version.","I","need","something","like"
162+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
163+ ]
164+
165+ BadConstraint problem ->
166+ map D.fromString (words ("It is not a valid constraint. " ++ problem))
167+
168+ BadModuleName name ->
169+ ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
170+ ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
171+ ]
172+
173+ BadModuleHeaderTooLong header ->
174+ ["The",D.fromString (show header),"header","is","too","long."
175+ ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
176+ ,"to","ensure","that","formatting","is","nice","on","the","package","website."
177+ ]
178+
179+ BadDependencyName name ->
180+ ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
181+ ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
182+ ,"the","package","website,","and","installing","it","with","the"
183+ ,D.green "`elm install`","command","instead."
184+ ]
185+
186+ BadLicense _given suggestions ->
187+ case suggestions of
188+ [] ->
189+ ["I","need","an","OSI","approved","SPDX","license,","like"
190+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
191+ ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
192+ ]
193+
194+ code:codes ->
195+ ["I","need","an","OSI","approved","SPDX","license."]
196+ ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
197+ ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
198+
199+ BadDirectoryNotString ->
200+ ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
201+ ]
202+
203+ BadSummaryTooLong ->
204+ ["Your","summary","is","too","long.","I","need","it","to"
205+ ,"be",D.green "under",D.green "80",D.green "characters."
206+ ]
207+
208+
209+oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
210+oneOf code codes =
211+ let
212+ toDoc spdx =
213+ D.green (D.fromString (show spdx))
214+ in
215+ case codes of
216+ [] ->
217+ [toDoc code]
218+
219+ [code2] ->
220+ [toDoc code,"or",toDoc code2]
221+
222+ _:_ ->
223+ let
224+ these = code : init codes
225+ final = last codes
226+ in
227+ map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Exit/Bump.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Bump
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Version as V
10+import Reporting.Doc ((<>))
11+import qualified Reporting.Doc as D
12+import qualified Reporting.Exit.Help as Help
13+
14+
15+
16+-- EXITS
17+
18+
19+data Exit
20+ = Application
21+ | Unbumpable V.Version [V.Version]
22+
23+
24+
25+-- TO REPORT
26+
27+
28+toReport :: Exit -> Help.Report
29+toReport exit =
30+ case exit of
31+ Application ->
32+ Help.report "UNBUMPABLE" (Just "elm.json")
33+ "Your elm.json says this is an application. That means it cannot be published\
34+ \ on <https://package.elm-lang.org> and therefore has no version to bump!"
35+ []
36+
37+ Unbumpable vsn versions ->
38+ Help.docReport "UNBUMPABLE" (Just "elm.json")
39+ ( D.fillSep
40+ ["Your","elm.json","says","I","should","bump","relative","to","version"
41+ ,D.red (D.fromUtf8 (V.toString vsn)) <> ","
42+ ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
43+ ,"That","means","there","is","no","API","for","me","to","diff","against","and"
44+ ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
45+ ]
46+ )
47+ [ D.fillSep $
48+ ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
49+ ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
50+ , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions
51+ ]
builder/src/Reporting/Exit/Compile.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reporting.Exit.Compile
4+ ( Exit(..)
5+ , toJson
6+ , toDoc
7+ )
8+ where
9+
10+
11+import qualified Data.List as List
12+import qualified Data.Time.Clock as Time
13+
14+import qualified Elm.Compiler as Compiler
15+import qualified Elm.ModuleName as ModuleName
16+import qualified Json.Encode as Encode
17+import qualified Reporting.Doc as D
18+
19+
20+
21+-- EXITS
22+
23+
24+data Exit =
25+ Exit
26+ { _name :: ModuleName.Raw
27+ , _path :: FilePath
28+ , _time :: Time.UTCTime
29+ , _source :: String
30+ , _errors :: [Compiler.Error]
31+ }
32+
33+
34+
35+-- TO JSON
36+
37+
38+toJson :: Exit -> Encode.Value
39+toJson (Exit name path _ source errors) =
40+ Compiler.errorsToJson name path source errors
41+
42+
43+
44+-- TO DOC
45+
46+
47+toDoc :: Exit -> [Exit] -> D.Doc
48+toDoc e es =
49+ let
50+ (exit, exits) = sortByTime e es
51+ in
52+ D.vcat (toDocHelp exit exits)
53+
54+
55+toDocHelp :: Exit -> [Exit] -> [D.Doc]
56+toDocHelp e1 exits =
57+ case exits of
58+ [] ->
59+ [exitToDoc e1]
60+
61+ e2 : otherErrors ->
62+ exitToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors
63+
64+
65+exitToDoc :: Exit -> D.Doc
66+exitToDoc (Exit _name path _time source errors) =
67+ Compiler.errorsToDoc path source errors
68+
69+
70+separator :: ModuleName.Raw -> ModuleName.Raw -> D.Doc
71+separator beforeName afterName =
72+ let
73+ before = ModuleName.nameToChars beforeName ++ " ↑ "
74+ after = " ↓ " ++ ModuleName.nameToChars afterName
75+ in
76+ D.dullred $ D.vcat $
77+ [ D.indent (80 - length before) (D.fromChars before)
78+ , "====o======================================================================o===="
79+ , D.fromChars after
80+ , D.empty
81+ , D.empty
82+ ]
83+
84+
85+
86+-- SORT BY TIME
87+
88+
89+sortByTime :: Exit -> [Exit] -> (Exit, [Exit])
90+sortByTime exit exits =
91+ case List.sortBy timeCompare exits of
92+ [] ->
93+ (exit, [])
94+
95+ e:es ->
96+ if _time exit < _time e then
97+ (exit, e:es)
98+ else
99+ (e, List.insertBy timeCompare exit es)
100+
101+
102+timeCompare :: Exit -> Exit -> Ordering
103+timeCompare e1 e2 =
104+ compare (_time e1) (_time e2)
builder/src/Reporting/Exit/Crawl.hsnew file+345
@@ -0,0 +1,345 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Crawl
3+ ( Exit(..)
4+ , Problem(..)
5+ , Origin(..)
6+ , SrcDirs(..)
7+ , toReport
8+ )
9+ where
10+
11+
12+import qualified Data.Char as Char
13+import qualified Data.Map as Map
14+import qualified Data.Time.Clock as Time
15+
16+import qualified Elm.Compiler as Compiler
17+import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Package as Pkg
19+import qualified Elm.Version as V
20+import Reporting.Doc ((<+>), (<>))
21+import qualified Reporting.Doc as D
22+import qualified Reporting.Exit.Compile as Compile
23+import qualified Reporting.Exit.Help as Help
24+
25+
26+
27+-- EXIT
28+
29+
30+data Exit
31+ = RootFileNotFound FilePath
32+ | RootModuleNameDuplicate ModuleName.Raw [FilePath]
33+ | RootNameless FilePath
34+ | DependencyProblems Problem [Problem]
35+ | BadKernelHeader FilePath
36+
37+
38+data Problem
39+ = ModuleNotFound Origin ModuleName.Raw SrcDirs
40+ | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]
41+ | BadHeader FilePath Time.UTCTime String Compiler.Error
42+ | ModuleNameReservedForKernel Origin ModuleName.Raw
43+ | ModuleNameMissing FilePath ModuleName.Raw
44+ | ModuleNameMismatch
45+ FilePath
46+ ModuleName.Raw -- expected
47+ ModuleName.Raw -- actual
48+ | PortsInPackage FilePath ModuleName.Raw
49+ | EffectsUnexpected FilePath ModuleName.Raw
50+
51+
52+data Origin
53+ = ElmJson
54+ | File FilePath
55+ | Module FilePath ModuleName.Raw
56+
57+
58+data SrcDirs
59+ = App [FilePath]
60+ | Pkg
61+
62+
63+
64+-- TO REPORT
65+
66+
67+toReport :: Exit -> Help.Report
68+toReport exit =
69+ case exit of
70+ RootFileNotFound path ->
71+ Help.report "FILE NOT FOUND" Nothing
72+ "You want me to compile this file:"
73+ [ D.indent 4 $ D.dullyellow $ D.fromChars path
74+ , "I cannot find it though! Is there a typo?"
75+ ]
76+
77+ RootModuleNameDuplicate name paths ->
78+ Help.report "DUPLICATE NAMES" Nothing
79+ "I am trying to compile multiple modules with the same name:"
80+ [ D.indent 4 $ D.dullyellow $ D.vcat $
81+ map D.fromChars paths
82+ , D.fillSep $
83+ [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
84+ , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."
85+ , "Change", "them", "to", "have", "unique", "names", "and", "you"
86+ , "should", "be", "all", "set!"
87+ ]
88+ ]
89+
90+ RootNameless path ->
91+ namelessToDoc path "Main"
92+
93+ DependencyProblems problem otherProblems ->
94+ case otherProblems of
95+ [] ->
96+ problemToReport problem
97+
98+ _ ->
99+ problemToReport problem
100+ -- error "TODO handle multiple dependency errors"
101+
102+ BadKernelHeader filePath ->
103+ Help.report "BAD KERNEL HEADER" Nothing
104+ "I ran into a bad header in this file:"
105+ [ D.indent 4 $ D.dullyellow $ D.fromChars filePath
106+ , D.reflow $
107+ "NOTE: Kernel code is only available to core Elm libraries to ensure\
108+ \ the portability and security of the Elm ecosystem. This restriction\
109+ \ also makes it possible to improve code gen (i.e. performance) without\
110+ \ disrupting the ecosystem."
111+ ]
112+
113+
114+
115+-- PROBLEM TO REPORT
116+
117+
118+problemToReport :: Problem -> Help.Report
119+problemToReport problem =
120+ case problem of
121+ ModuleNotFound origin name srcDirs ->
122+ notFoundToDoc origin name srcDirs
123+
124+ ModuleAmbiguous origin child paths pkgs ->
125+ ambiguousToDoc origin child paths pkgs
126+
127+ BadHeader path time source compilerError ->
128+ let
129+ compilerExit =
130+ Compile.Exit "???" path time source [compilerError]
131+ in
132+ Help.compilerReport compilerExit []
133+
134+ ModuleNameMissing path name ->
135+ namelessToDoc path name
136+
137+ ModuleNameMismatch path expected actual ->
138+ Help.report "MODULE NAME MISMATCH" (Just path)
139+ ( "The file at " ++ path ++ " has a typo in the module name. It says:"
140+ )
141+ [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"
142+ , "Looks like a typo or copy/paste error. Instead it needs to say:"
143+ , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"
144+ , "Make the change and you should be all set!"
145+ ]
146+
147+ ModuleNameReservedForKernel origin name ->
148+ kernelNameToDoc origin name
149+
150+ PortsInPackage path name ->
151+ badTagToDoc path name "port" "port-modules" $
152+ "Packages cannot have any `port` modules."
153+
154+ EffectsUnexpected path name ->
155+ badTagToDoc path name "effect" "effect-modules" $
156+ "Creating `effect` modules is relatively experimental. There are a\
157+ \ couple in @elm repos right now, but we have decided to be very\
158+ \ cautious in expanding its usage."
159+
160+
161+badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report
162+badTagToDoc path name tag hintName summary =
163+ Help.report
164+ ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
165+ (Just path)
166+ summary
167+ [ D.fillSep $
168+ [ "Get", "rid", "of", "all", "the"
169+ , D.red (D.fromChars tag)
170+ , "stuff", "in"
171+ , D.dullyellow (D.fromChars (ModuleName.nameToChars name))
172+ , "to", "proceed."
173+ ]
174+ , D.toSimpleNote $
175+ "You can learn the reasoning behind this design choice at "
176+ ++ D.makeLink hintName
177+ ]
178+
179+
180+
181+-- NAMELESS
182+
183+
184+namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report
185+namelessToDoc path name =
186+ Help.report "UNNAMED MODULE" (Just path)
187+ ( "The `" ++ ModuleName.nameToChars name
188+ ++ "` module must start with a line like this:"
189+ )
190+ [ D.indent 4 $ D.dullyellow $ D.fromChars $
191+ "module " ++ ModuleName.nameToChars name ++ " exposing (..)"
192+ , D.reflow $
193+ "Try adding that as the first line of your file!"
194+ , D.toSimpleNote $
195+ "It is best to replace (..) with an explicit list of types and\
196+ \ functions you want to expose. If you know a value is only used\
197+ \ WITHIN this module, it is extra easy to refactor. This kind of\
198+ \ information is great, especially as your project grows!"
199+ ]
200+
201+
202+
203+-- NOT FOUND
204+
205+
206+notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report
207+notFoundToDoc origin child srcDirs =
208+ case origin of
209+ ElmJson ->
210+ Help.report "MODULE NOT FOUND" (Just "elm.json")
211+ "Your elm.json says your project has the following module:"
212+ [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child
213+ , D.reflow $
214+ "When creating packages, all modules must live in the src/ directory."
215+ ]
216+
217+ File path ->
218+ Help.report "UNKNOWN IMPORT" (Just path)
219+ ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")
220+ (notFoundDetails child srcDirs)
221+
222+ Module path parent ->
223+ Help.report "UNKNOWN IMPORT" (Just path)
224+ ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")
225+ (notFoundDetails child srcDirs)
226+
227+
228+notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]
229+notFoundDetails child srcDirs =
230+ let
231+ simulatedCode =
232+ D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child
233+ in
234+ case Map.lookup child Pkg.suggestions of
235+ Just pkg ->
236+ [ simulatedCode
237+ , D.reflow $
238+ "Do you want the one from the " ++ Pkg.toChars pkg
239+ ++ " package? If so, run this command to add that dependency to your elm.json file:"
240+ , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg
241+ , case srcDirs of
242+ Pkg ->
243+ D.reflow $
244+ "If you want a local file, make sure the `"
245+ ++ ModuleName.nameToChars child
246+ ++ "` module is in your src/ directory."
247+
248+ App _ ->
249+ D.reflow $
250+ "If you want a local file, make sure the `"
251+ ++ ModuleName.nameToChars child
252+ ++ "` module is in one of the \"source-directories\" listed in your elm.json file."
253+ ]
254+
255+ Nothing ->
256+ [ simulatedCode
257+ , "I cannot find that module! Is there a typo in the module name?"
258+ , D.reflow $
259+ case srcDirs of
260+ Pkg ->
261+ "When creating a package, all modules must live in the src/ directory."
262+
263+ App [] ->
264+ "The \"source-directories\" field of your elm.json is empty, so I only\
265+ \ searched in packages. Maybe you need to add a \"src\" directory there?"
266+
267+ App [dir] ->
268+ "The \"source-directories\" field of your elm.json tells me to only look in the "
269+ ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
270+
271+ App (dir:_:_) ->
272+ "The \"source-directories\" field of your elm.json tells me to look in directories like "
273+ ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
274+ ]
275+
276+
277+ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report
278+ambiguousToDoc origin child paths pkgs =
279+ let
280+ pkgToString (Pkg.Canonical pkg vsn) =
281+ "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
282+
283+ makeReport maybePath summary yellowString =
284+ Help.report "AMBIGUOUS IMPORT" maybePath summary
285+ [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString
286+ , D.reflow $
287+ "I found multiple module with that name though:"
288+ , D.indent 4 $ D.dullyellow $ D.vcat $
289+ map D.fromChars $ paths ++ map pkgToString pkgs
290+ , D.reflow $
291+ if null paths then
292+ "It looks like the name clash is in your dependencies, which is\
293+ \ out of your control. Elm does not support this scenario right\
294+ \ now, but it may be worthwhile. Please open an issue describing\
295+ \ your scenario so we can gather more usage information!"
296+ else
297+ "Which is the right one? Try renaming your modules to have unique names."
298+ ]
299+ in
300+ case origin of
301+ ElmJson ->
302+ makeReport
303+ Nothing
304+ "Your elm.json wants the following module:"
305+ (ModuleName.nameToChars child)
306+
307+ File path ->
308+ makeReport
309+ (Just path)
310+ ("The file at " ++ path ++ " has an ambiguous import:")
311+ ("import " ++ ModuleName.nameToChars child)
312+
313+ Module path parent ->
314+ makeReport
315+ (Just path)
316+ ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")
317+ ("import " ++ ModuleName.nameToChars child)
318+
319+
320+kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report
321+kernelNameToDoc origin kernelName =
322+ let
323+ (maybePath, statement) =
324+ case origin of
325+ ElmJson ->
326+ ( Nothing
327+ , "Your elm.json says your project has the following module:"
328+ )
329+
330+ File path ->
331+ ( Just path
332+ , "This file is trying to import the following module:"
333+ )
334+
335+ Module path parent ->
336+ ( Just path
337+ , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"
338+ )
339+ in
340+ Help.report "BAD MODULE NAME" maybePath statement
341+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName
342+ , D.reflow $
343+ "But names like that are reserved for internal use.\
344+ \ Switch to a name outside of the Elm/Kernel/ namespace."
345+ ]
builder/src/Reporting/Exit/Deps.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Deps
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Constraint as Con
10+import qualified Elm.Package as Pkg
11+import qualified Elm.Version as V
12+import Reporting.Doc ((<>))
13+import qualified Reporting.Doc as D
14+import qualified Reporting.Exit.Help as Help
15+
16+
17+
18+-- EXITS
19+
20+
21+data Exit
22+ = CorruptVersionCache FilePath Pkg.Name
23+ | PackageNotFound Pkg.Name [Pkg.Name]
24+ -- verify
25+ | PkgBadElm Con.Constraint
26+ | AppBadElm V.Version
27+ | AppMissingTrans [(Pkg.Name, V.Version)]
28+ | BadDeps
29+ | BuildFailure FilePath Pkg.Name V.Version
30+
31+
32+
33+-- TO DOC
34+
35+
36+toReport :: Exit -> Help.Report
37+toReport exit =
38+ case exit of
39+ CorruptVersionCache elmHome pkg ->
40+ Help.report "CORRUPT CACHE" Nothing
41+ ( "I ran into an unknown package while exploring dependencies:"
42+ )
43+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg
44+ , D.reflow $
45+ "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
46+ \ Maybe some program is messing with it? It is just cached files,\
47+ \ so you can delete it and see if that fixes the issue."
48+ ]
49+
50+ PackageNotFound package suggestions ->
51+ Help.docReport "PACKAGE NOT FOUND" Nothing
52+ ( D.fillSep
53+ ["I","cannot","find","a"
54+ ,D.red (D.fromUtf8 (Pkg.toString package))
55+ ,"package","on","the","package","website."
56+ ]
57+ )
58+ [ "Maybe you want one of these instead?"
59+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
60+ , "But check <https://package.elm-lang.org> to see all possibilities!"
61+ ]
62+
63+ PkgBadElm constraint ->
64+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
65+ "Your elm.json says this package needs a version of Elm in this range:"
66+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint
67+ , D.fillSep
68+ [ "But", "you", "are", "using", "Elm"
69+ , D.red (D.fromUtf8 (V.toString V.compiler))
70+ , "right", "now."
71+ ]
72+ ]
73+
74+ AppBadElm version ->
75+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
76+ "Your elm.json says this application needs a different version of Elm."
77+ [ D.fillSep
78+ [ "It", "requires"
79+ , D.green (D.fromUtf8 (V.toString version)) <> ","
80+ , "but", "you", "are", "using"
81+ , D.red (D.fromUtf8 (V.toString V.compiler))
82+ , "right", "now."
83+ ]
84+ ]
85+
86+ AppMissingTrans missingDeps ->
87+ let
88+ toEntry (pkg, vsn) =
89+ "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""
90+ in
91+ Help.report "MISSING DEPENDENCIES" (Just "elm.json")
92+ "Your elm.json is missing some \"indirect\" dependencies:"
93+ [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps
94+ , D.fillSep
95+ ["This","usually","means","you","are","editing","elm.json","by","hand."
96+ ,"It","is","much","more","reliable","to","use","the"
97+ ,D.green "elm install","command","instead."
98+ ]
99+ ]
100+
101+ BadDeps ->
102+ Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")
103+ "The dependencies in your elm.json are not compatible."
104+ [ D.fillSep
105+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
106+ ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"
107+ ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."
108+ ]
109+ , D.reflow $
110+ "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
111+ \ you try those paths and still cannot figure it out!"
112+ ]
113+
114+ BuildFailure elmHome pkg vsn ->
115+ Help.report "CORRUPT DEPENDENCY" Nothing
116+ "I ran into a problem while building the following package:"
117+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
118+ , D.fillSep
119+ ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
120+ ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"
121+ ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
122+ ]
123+ ]
builder/src/Reporting/Exit/Diff.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Diff
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Data.List as List
10+
11+import qualified Elm.Package as Pkg
12+import qualified Elm.Version as V
13+import qualified Reporting.Doc as D
14+import qualified Reporting.Exit.Help as Help
15+
16+
17+
18+-- EXITS
19+
20+
21+data Exit
22+ = Application
23+ | Unpublished
24+ | UnknownPackage Pkg.Name [Pkg.Name]
25+ | UnknownVersion Pkg.Name V.Version [V.Version]
26+
27+
28+
29+-- TO DOC
30+
31+
32+toReport :: Exit -> Help.Report
33+toReport exit =
34+ case exit of
35+ Application ->
36+ Help.report "CANNOT DIFF APPLICATIONS" Nothing
37+ "I cannot perform diffs on applications, only packages! If you are\
38+ \ just curious to see a diff, try running this command:"
39+ [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"
40+ ]
41+
42+ Unpublished ->
43+ Help.report "UNPUBLISHED" Nothing
44+ "This package is not published yet. There is nothing to diff against!"
45+ []
46+
47+ UnknownPackage pkg suggestions ->
48+ Help.report "UNKNOWN PACKAGE" Nothing
49+ ( "I cannot find a package called:"
50+ )
51+ [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg
52+ , "Maybe you want one of these instead?"
53+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
54+ , "But check <https://package.elm-lang.org> to see all possibilities!"
55+ ]
56+
57+ UnknownVersion _pkg vsn realVersions ->
58+ Help.docReport "UNKNOWN VERSION" Nothing
59+ ( D.fillSep $
60+ [ "Version", D.red (D.fromUtf8 (V.toString vsn))
61+ , "has", "never", "been", "published,", "so", "I"
62+ , "cannot", "diff", "against", "it."
63+ ]
64+ )
65+ [ "Here are all the versions that HAVE been published:"
66+ , D.indent 4 $ D.dullyellow $ D.vcat $
67+ let
68+ sameMajor v1 v2 = V._major v1 == V._major v2
69+ mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns
70+ in
71+ map mkRow $ List.groupBy sameMajor (List.sort realVersions)
72+ , "Want one of those instead?"
73+ ]
builder/src/Reporting/Exit/Help.hs+12−11
@@ -14,6 +14,7 @@ module Reporting.Exit.Help
1414 where
1515
1616
17+import qualified Data.Utf8 as Utf8
1718import GHC.IO.Handle (hIsTerminalDevice)
1819import System.IO (Handle, hPutStr, stderr, stdout)
1920
@@ -21,7 +22,7 @@ import qualified Json.Encode as E
2122import Json.Encode ((==>))
2223import Reporting.Doc ((<+>))
2324import qualified Reporting.Doc as D
24−import qualified Reporting.Error as Error
25+import qualified Reporting.Exit.Compile as Compile
2526
2627
2728
@@ -29,7 +30,7 @@ import qualified Reporting.Error as Error
2930
3031
3132data Report
32− = CompilerReport FilePath Error.Module [Error.Module]
33+ = CompilerReport Compile.Exit [Compile.Exit]
3334 | Report
3435 { _title :: String
3536 , _path :: Maybe FilePath
@@ -52,7 +53,7 @@ jsonReport =
5253 Report
5354
5455
55−compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
56+compilerReport :: Compile.Exit -> [Compile.Exit] -> Report
5657compilerReport =
5758 CompilerReport
5859
@@ -64,8 +65,8 @@ compilerReport =
6465reportToDoc :: Report -> D.Doc
6566reportToDoc report_ =
6667 case report_ of
67− CompilerReport root e es ->
68− Error.toDoc root e es
68+ CompilerReport e es ->
69+ Compile.toDoc e es
6970
7071 Report title maybePath message ->
7172 let
@@ -94,17 +95,17 @@ reportToDoc report_ =
9495reportToJson :: Report -> E.Value
9596reportToJson report_ =
9697 case report_ of
97− CompilerReport _ e es ->
98+ CompilerReport e es ->
9899 E.object
99− [ "type" ==> E.chars "compile-errors"
100− , "errors" ==> E.list Error.toJson (e:es)
100+ [ "type" ==> E.string "compile-errors"
101+ , "errors" ==> E.list Compile.toJson (e:es)
101102 ]
102103
103104 Report title maybePath message ->
104105 E.object
105− [ "type" ==> E.chars "error"
106− , "path" ==> maybe E.null E.chars maybePath
107− , "title" ==> E.chars title
106+ [ "type" ==> E.string "error"
107+ , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath
108+ , "title" ==> E.string (Utf8.fromChars title)
108109 , "message" ==> D.encode message
109110 ]
110111
builder/src/Reporting/Exit/Http.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Http
3+ ( Exit(..)
4+ , toReport
5+ , BadJson(..)
6+ , badJsonToDocs
7+ )
8+ where
9+
10+
11+import qualified Data.Text as Text
12+
13+import Reporting.Doc ((<>))
14+import qualified Reporting.Doc as D
15+import qualified Reporting.Exit.Help as Help
16+
17+
18+
19+-- EXITS
20+
21+
22+data Exit
23+ = Unknown String
24+ | BadJson String D.Doc
25+ | BadZipData
26+ | BadZipSha String String
27+
28+
29+
30+-- TO REPORT
31+
32+
33+toReport :: String -> Exit -> Help.Report
34+toReport url exit =
35+ let
36+ urlDoc =
37+ D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"
38+ in
39+ case exit of
40+ Unknown message ->
41+ Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
42+ [ urlDoc
43+ , D.stack
44+ [ "Here is the error message I was able to extract:"
45+ , D.indent 4 $ D.reflow message
46+ ]
47+ ]
48+
49+ BadJson path doc ->
50+ Help.jsonReport "UNEXPECTED JSON" (Just path) doc
51+
52+ BadZipData ->
53+ Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
54+ [ urlDoc
55+ , D.reflow $
56+ "If it is a transient issue, it should be fixed if you try this\
57+ \ again. If it seems like an Elm problem, please report it though!"
58+ ]
59+
60+ BadZipSha expectedHash actualHash ->
61+ Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
62+ [ urlDoc
63+ , D.reflow "I check the hash the zip, and it seems off:"
64+ , D.vcat $ map D.fromString $
65+ [ " Expected: " ++ expectedHash
66+ , " Actual: " ++ actualHash
67+ ]
68+ , D.reflow $
69+ "This usually means that the package author moved the version\
70+ \ tag, so report it to them and see if that is the issue. Folks\
71+ \ on Elm slack can probably help as well."
72+ ]
73+
74+
75+
76+-- BAD JSON
77+
78+
79+data BadJson
80+ = BadNewPkg Text.Text
81+ | BadAllPkg Text.Text String
82+ | BadAllVsn Text.Text
83+
84+
85+badJsonToDocs :: BadJson -> [D.Doc]
86+badJsonToDocs badJson =
87+ case badJson of
88+ BadNewPkg txt ->
89+ ["I","ran","into",D.red (D.fromString (show txt)) <> ","
90+ ,"but","I","need","entries","like"
91+ ,D.green "\"elm/core@6.0.0\"" <> "."
92+ ]
93+
94+ BadAllPkg txt suggestion ->
95+ ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
96+ ]
97+ ++ map D.fromString (words suggestion)
98+
99+ BadAllVsn txt ->
100+ ["You","provided",D.red (D.fromString (show txt))
101+ ,"which","is","not","a","valid","version.","I","need","something","like"
102+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
103+ ]
104+
builder/src/Reporting/Exit/Init.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Init
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Package as Pkg
10+import qualified Reporting.Doc as D
11+import qualified Reporting.Exit.Help as Help
12+
13+
14+
15+-- EXITS
16+
17+
18+data Exit
19+ = NoSolution [Pkg.Name]
20+ | AlreadyStarted
21+
22+
23+
24+-- TO REPORT
25+
26+
27+toReport :: Exit -> Help.Report
28+toReport exit =
29+ case exit of
30+ NoSolution pkgs ->
31+ Help.report "NO SOLUTION" Nothing
32+ "I tried to create an elm.json with the following direct dependencies:"
33+ [ D.indent 4 $ D.vcat $
34+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
35+ , D.reflow $
36+ "I could not find compatible versions though! This should not happen, so please\
37+ \ ask around one of the community forums <http://elm-lang.org/community> to learn\
38+ \ what is going on!"
39+ ]
40+
41+ AlreadyStarted ->
42+ Help.report "EXISTING PROJECT" Nothing
43+ "You already have an elm.json file, so there is nothing for me to initialize!"
44+ [ D.fillSep
45+ ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"
46+ ,"you","figure","out","what","to","do","next?"
47+ ]
48+ ]
builder/src/Reporting/Exit/Install.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Install
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Package as Pkg
10+import qualified Elm.Version as V
11+import qualified Reporting.Doc as D
12+import qualified Reporting.Exit.Help as Help
13+
14+
15+
16+-- EXITS
17+
18+
19+data Exit
20+ = NoArgs FilePath
21+ | NoSolution [Pkg.Name]
22+
23+
24+
25+-- TO REPORT
26+
27+
28+toReport :: Exit -> Help.Report
29+toReport exit =
30+ case exit of
31+ NoArgs elmHome ->
32+ Help.report "INSTALL WHAT?" Nothing
33+ "I am expecting commands like:"
34+ [ D.green $ D.indent 4 $ D.vcat $
35+ [ "elm install elm/http"
36+ , "elm install elm/json"
37+ , "elm install elm/random"
38+ ]
39+ , D.toFancyHint
40+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."
41+ ,"\"Gotta","download","everything!\"","But","why","download","packages"
42+ ,"again","and","again?","Instead,","Elm","caches","packages","in"
43+ ,D.dullyellow (D.fromChars elmHome)
44+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
45+ ,"Elm","projects","check","that","cache","before","trying","the","internet."
46+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
47+ ,"easier","to","work","offline.","As","a","result"
48+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
49+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
50+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
51+ ]
52+ ]
53+
54+ NoSolution badPackages ->
55+ case badPackages of
56+ [] ->
57+ Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json")
58+ "This usually happens if you try to modify dependency constraints by\
59+ \ hand. I recommend deleting any dependency you added recently (or all\
60+ \ of them if things are bad) and then adding them again with:"
61+ [ D.indent 4 $ D.green "elm install"
62+ , D.reflow $
63+ "And do not be afaid to ask for help on Slack if you get stuck!"
64+ ]
65+
66+ _:_ ->
67+ Help.report "OLD DEPENDENCIES" (Just "elm.json")
68+ ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
69+ )
70+ [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
71+ , D.reflow $
72+ "This may be because it is not upgraded yet. It may be because a\
73+ \ better solution came along, so there was no need to upgrade it.\
74+ \ Etc. Try asking around on Slack to learn more about the topic."
75+ , D.toSimpleNote
76+ "Whatever the case, please be kind to the relevant package authors! Having\
77+ \ friendly interactions with users is great motivation, and conversely, getting\
78+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
79+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
80+ \ goals, etc. They face obstacles outside of their technical work you will never\
81+ \ know about, so please assume the best and try to be patient and supportive!"
82+ ]
builder/src/Reporting/Exit/Make.hsnew file+75
@@ -0,0 +1,75 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Make
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.ModuleName as ModuleName
10+import qualified Reporting.Doc as D
11+import qualified Reporting.Exit.Help as Help
12+
13+
14+
15+-- EXITS
16+
17+
18+data Exit
19+ = CannotMakeNothing
20+ | CannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
21+ | CannotOptimizeAndDebug
22+
23+
24+
25+-- TO REPORT
26+
27+
28+toReport :: Exit -> Help.Report
29+toReport exit =
30+ case exit of
31+ CannotMakeNothing ->
32+ Help.report "NO INPUT" Nothing
33+ "What should I make though? I need more information, like:"
34+ [ D.vcat
35+ [ D.indent 4 $ D.green "elm make src/Main.elm"
36+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
37+ ]
38+ , D.reflow
39+ "However many files you give, I will create one JS file out of them."
40+ ]
41+
42+ CannotOptimizeDebugValues m ms ->
43+ Help.report "DEBUG REMNANTS" Nothing
44+ "There are uses of the `Debug` module in the following modules:"
45+ [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.nameToChars) (m:ms)
46+ , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!"
47+ , D.toSimpleNote $
48+ "The issue is that --optimize strips out info needed by `Debug` functions.\
49+ \ Here are two examples:"
50+ , D.indent 4 $ D.reflow $
51+ "(1) It shortens record field names. This makes the generated JavaScript is\
52+ \ smaller, but `Debug.toString` cannot know the real field names anymore."
53+ , D.indent 4 $ D.reflow $
54+ "(2) Values like `type Height = Height Float` are unboxed. This reduces\
55+ \ allocation, but it also means that `Debug.toString` cannot tell if it is\
56+ \ looking at a `Height` or `Float` value."
57+ , D.reflow $
58+ "There are a few other cases like that, and it will be much worse once we start\
59+ \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\
60+ \ resulting in unpredictable behavior. I hope that clarifies why this restriction\
61+ \ exists!"
62+ ]
63+
64+ CannotOptimizeAndDebug ->
65+ Help.docReport "CLASHING FLAGS" Nothing
66+ ( D.fillSep
67+ ["I","cannot","compile","with",D.red "--optimize","and"
68+ ,D.red "--debug","at","the","same","time."
69+ ]
70+ )
71+ [ D.reflow
72+ "I need to take away information to optimize things, and I need to\
73+ \ add information to add the debugger. It is impossible to do both\
74+ \ at once, so pick just one of those flags."
75+ ]
builder/src/Reporting/Exit/Publish.hsnew file+241
@@ -0,0 +1,241 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Publish
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import Deps.Diff (Magnitude, magnitudeToString)
10+import qualified Elm.Version as V
11+import Reporting.Doc ((<>))
12+import qualified Reporting.Doc as D
13+import qualified Reporting.Exit.Help as Help
14+
15+
16+
17+-- EXITS
18+
19+
20+data Exit
21+ = Application
22+ | NotInitialVersion V.Version
23+ | AlreadyPublished V.Version
24+ | InvalidBump V.Version V.Version
25+ | BadBump V.Version V.Version Magnitude V.Version Magnitude
26+ | NoSummary
27+ | NoExposed
28+ | NoReadme
29+ | ShortReadme
30+ | NoLicense
31+ | MissingTag V.Version
32+ | NoGit
33+ | LocalChanges V.Version
34+
35+
36+
37+-- TO REPORT
38+
39+
40+toReport :: Exit -> Help.Report
41+toReport exit =
42+ case exit of
43+ Application ->
44+ Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
45+
46+ NotInitialVersion vsn ->
47+ Help.docReport "INVALID VERSION" Nothing
48+ ( D.fillSep
49+ ["I","cannot","publish"
50+ ,D.red (D.fromUtf8 (V.toString vsn))
51+ ,"as","the","initial","version."
52+ ]
53+ )
54+ [ D.fillSep
55+ ["Change","it","to",D.green "1.0.0","which","is"
56+ ,"the","initial","version","for","all","Elm","packages."
57+ ]
58+ ]
59+
60+ AlreadyPublished vsn ->
61+ Help.docReport "ALREADY PUBLISHED" Nothing
62+ ( D.vcat
63+ [ D.fillSep
64+ [ "Version", D.green (D.fromUtf8 (V.toString vsn))
65+ , "has", "already", "been", "published.", "You", "cannot"
66+ , "publish", "it", "again!"
67+ ]
68+ , "Try using the `bump` command:"
69+ ]
70+ )
71+ [ D.dullyellow $ D.indent 4 "elm bump"
72+ , D.reflow $
73+ "It computes the version number based on API changes, ensuring\
74+ \ that no breaking changes end up in PATCH releases!"
75+ ]
76+
77+ InvalidBump statedVersion latestVersion ->
78+ Help.docReport "INVALID VERSION" (Just "elm.json")
79+ ( D.fillSep $
80+ ["Your","elm.json","says","the","next","version","should","be"
81+ ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","
82+ ,"but","that","is","not","valid","based","on","the","previously"
83+ ,"published","versions."
84+ ]
85+ )
86+ [ D.fillSep $
87+ ["Change","the","version","back","to"
88+ ,D.green (D.fromUtf8 (V.toString latestVersion))
89+ ,"which","is","the","most","recently","published","version."
90+ ,"From","there,","have","Elm","bump","the","version","by","running:"
91+ ]
92+ , D.indent 4 $ D.green "elm bump"
93+ , D.reflow $
94+ "If you want more insight on the API changes Elm detects, you\
95+ \ can run `elm diff` at this point as well."
96+ ]
97+
98+ BadBump old new magnitude realNew realMagnitude ->
99+ Help.docReport "INVALID VERSION" (Just "elm.json")
100+ (
101+ D.fillSep $
102+ ["Your","elm.json","says","the","next","version","should","be"
103+ ,D.red (D.fromUtf8 (V.toString new)) <> ","
104+ ,"indicating","a",D.fromChars (magnitudeToString magnitude)
105+ ,"change","to","the","public","API."
106+ ,"This","does","not","match","the","API","diff","given","by:"
107+ ]
108+ )
109+ [ D.indent 4 $ D.fromChars $
110+ "elm diff " ++ V.toChars old
111+
112+ , D.fillSep $
113+ ["This","command","says","this","is","a"
114+ ,D.fromChars (magnitudeToString realMagnitude)
115+ ,"change,","so","the","next","version","should","be"
116+ ,D.green (D.fromUtf8 (V.toString realNew)) <> "."
117+ ,"Double","check","everything","to","make","sure","you"
118+ ,"are","publishing","what","you","want!"
119+ ]
120+ , D.reflow $
121+ "Also, next time use `elm bump` and I'll figure all this out for you!"
122+ ]
123+
124+ NoSummary ->
125+ Help.docReport "NO SUMMARY" (Just "elm.json")
126+ ( D.fillSep $
127+ [ "To", "publish", "a", "package,", "your", "elm.json", "must"
128+ , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"
129+ , "a", "consice", "overview", "of", "your", "project."
130+ ]
131+ )
132+ [ D.reflow $
133+ "The summary must be less than 80 characters. It should describe\
134+ \ the concrete use of your package as clearly and as plainly as possible."
135+ ]
136+
137+ NoExposed ->
138+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
139+ ( D.fillSep $
140+ [ "To", "publish", "a", "package,", "the"
141+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
142+ , "elm.json", "must", "list", "at", "least", "one", "module."
143+ ]
144+ )
145+ [ D.reflow $
146+ "What is the point of a package that has no modules?!"
147+ ]
148+
149+ NoReadme ->
150+ badReadmeReport "NO README" $
151+ "Every published package must have a helpful README.md\
152+ \ file, but I do not see one in your project."
153+
154+ ShortReadme ->
155+ badReadmeReport "SHORT README" $
156+ "This README.md is too short. Having more details will help\
157+ \ people assess your package quickly and fairly."
158+
159+ NoLicense ->
160+ Help.report "NO LICENSE FILE" (Just "LICENSE")
161+ "By publishing a package you are inviting the Elm community to build\
162+ \ upon your work. But without knowing your license, we have no idea if\
163+ \ that is legal!"
164+ [ D.reflow $
165+ "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\
166+ \ you must share that choice in two places. First, the license\
167+ \ identifier must appear in your elm.json file. Second, the full\
168+ \ license text must appear in the root of your project in a file\
169+ \ named LICENSE. Add that file and you will be all set!"
170+ ]
171+
172+ MissingTag version ->
173+ let vsn = V.toChars version in
174+ Help.docReport "NO TAG" Nothing
175+ ( D.fillSep $
176+ [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"
177+ , "cannot", "find", "a", D.green (D.fromChars vsn), "tag."
178+ ]
179+ )
180+ [ D.vcat
181+ [ "These tags make it possible to find this specific version on GitHub."
182+ , "To tag the most recent commit and push it to GitHub, run this:"
183+ ]
184+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $
185+ [ "git tag -a " ++ vsn ++ " -m \"new release\""
186+ , "git push origin " ++ vsn
187+ ]
188+ , "The -m flag is for a helpful message. Try to make it more informative!"
189+ ]
190+
191+ NoGit ->
192+ Help.report "NO GIT" Nothing
193+ "I searched your PATH environment variable for `git` and could not\
194+ \ find it. Is it available through your PATH?"
195+ [ D.reflow $
196+ "Who cares about this? Well, I currently use `git` to check if there\
197+ \ are any local changes in your code. Local changes are a good sign\
198+ \ that some important improvements have gotten mistagged, so this\
199+ \ check can be extremely helpful for package authors!"
200+ , D.toSimpleNote $
201+ "We plan to do this without the `git` binary in a future release."
202+ ]
203+
204+ LocalChanges version ->
205+ let vsn = V.toChars version in
206+ Help.docReport "LOCAL CHANGES" Nothing
207+ ( D.fillSep $
208+ [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"
209+ , "git", "does", "not", "match", "the", "code", "in", "your"
210+ , "working", "directory.", "This", "means", "you", "have"
211+ , "commits", "or", "local", "changes", "that", "are", "not"
212+ , "going", "to", "be", "published!"
213+ ]
214+ )
215+ [ D.toSimpleNote $
216+ "If you are sure everything is in order, you can run `git checkout "
217+ ++ vsn ++ "` and publish your code from there."
218+ ]
219+
220+
221+badReadmeReport :: String -> String -> Help.Report
222+badReadmeReport title summary =
223+ Help.report title (Just "README.md") summary
224+ [ D.reflow $
225+ "When people look at your README, they are wondering:"
226+ , D.vcat
227+ [ " - What does this package even do?"
228+ , " - Will it help me solve MY problems?"
229+ ]
230+ , D.reflow $
231+ "So I recommend starting your README with a small example of the\
232+ \ most common usage scenario. Show people what they can expect if\
233+ \ they learn more!"
234+ , D.toSimpleNote $
235+ "By publishing your package, you are inviting people to invest time\
236+ \ in understanding your work. Spending an hour to communicate your\
237+ \ knowledge more clearly can save the community days or weeks of time\
238+ \ in aggregate, and saving time in aggregate is the whole point of\
239+ \ publishing packages! People really appreciate it, and it makes the\
240+ \ whole ecosystem feel nicer!"
241+ ]
builder/src/Reporting/Task.hs−17
@@ -3,10 +3,8 @@ module Reporting.Task
33 ( Task
44 , run
55 , throw
6− , mapError
76 --
87 , io
9− , mio
108 , eio
119 )
1210 where
@@ -33,12 +31,6 @@ throw x =
3331 Task $ \_ err -> err x
3432
3533
36−mapError :: (x -> y) -> Task x a -> Task y a
37−mapError func (Task task) =
38− Task $ \ok err ->
39− task ok (err . func)
40−
41−
4234
4335-- IO
4436
@@ -49,15 +41,6 @@ io work =
4941 Task $ \ok _ -> work >>= ok
5042
5143
52−mio :: x -> IO (Maybe a) -> Task x a
53−mio x work =
54− Task $ \ok err ->
55− do result <- work
56− case result of
57− Just a -> ok a
58− Nothing -> err x
59−
60−
6144eio :: (x -> y) -> IO (Either x a) -> Task y a
6245eio func work =
6346 Task $ \ok err ->
builder/src/Stuff.hs+9−9
@@ -8,14 +8,13 @@ module Stuff
88 , elmo
99 , temp
1010 , findRoot
11− , withRootLock
12− , withRegistryLock
11+ , withProjectLock
12+ , withCacheLock
1313 , PackageCache
1414 , getPackageCache
1515 , registry
1616 , package
1717 , getReplCache
18− , getElmHome
1918 )
2019 where
2120
@@ -120,16 +119,17 @@ findRootHelp dirs =
120119-- LOCKS
121120
122121
123−withRootLock :: FilePath -> IO a -> IO a
124−withRootLock root work =
122+withProjectLock :: FilePath -> IO a -> IO a
123+withProjectLock root work =
125124 do let dir = stuff root
126125 Dir.createDirectoryIfMissing True dir
127− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
126+ Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)
128127
129128
130−withRegistryLock :: PackageCache -> IO a -> IO a
131−withRegistryLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
129+withCacheLock :: PackageCache -> IO a -> IO a
130+withCacheLock (PackageCache dir) work =
131+ Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)
132+
133133
134134
135135
cabal.configdeleted−2
@@ -1,2 +0,0 @@
1−profiling: False
2−library-profiling: True
compiler/src/AST/Canonical.hs+9−12
@@ -56,14 +56,12 @@ import Data.Binary
5656import qualified Data.List as List
5757import qualified Data.Map as Map
5858import Data.Name (Name)
59+import qualified Data.Utf8 as Utf8
5960
60−import qualified AST.Source as Src
6161import qualified AST.Utils.Binop as Binop
6262import qualified AST.Utils.Shader as Shader
6363import qualified Data.Index as Index
64−import qualified Elm.Float as EF
6564import qualified Elm.ModuleName as ModuleName
66−import qualified Elm.String as ES
6765import qualified Reporting.Annotation as A
6866
6967
@@ -84,10 +82,10 @@ data Expr_
8482 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
8583 | VarDebug ModuleName.Canonical Name Annotation
8684 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
87− | Chr ES.String
88− | Str ES.String
85+ | Chr Utf8.String
86+ | Str Utf8.String
8987 | Int Int
90− | Float EF.Float
88+ | Float (Utf8.Under256 Float)
9189 | List [Expr]
9290 | Negate Expr
9391 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
@@ -130,7 +128,7 @@ data Def
130128
131129data Decls
132130 = Declare Def Decls
133− | DeclareRec Def [Def] Decls
131+ | DeclareRec [Def] Decls
134132 | SaveTheEnvironment
135133
136134
@@ -152,8 +150,8 @@ data Pattern_
152150 | PList [Pattern]
153151 | PCons Pattern Pattern
154152 | PBool Union Bool
155− | PChr ES.String
156− | PStr ES.String
153+ | PChr Utf8.String
154+ | PStr Utf8.String
157155 | PInt Int
158156 | PCtor
159157 { _p_home :: ModuleName.Canonical
@@ -233,7 +231,6 @@ data Module =
233231 Module
234232 { _name :: ModuleName.Canonical
235233 , _exports :: Exports
236− , _docs :: Src.Docs
237234 , _decls :: Decls
238235 , _unions :: Map.Map Name Union
239236 , _aliases :: Map.Map Name Alias
@@ -342,7 +339,7 @@ instance Binary CtorOpts where
342339 0 -> return Normal
343340 1 -> return Enum
344341 2 -> return Unbox
345− _ -> fail "binary encoding of CtorOpts was corrupted"
342+ _ -> error "binary encoding of CtorOpts was corrupted"
346343
347344
348345instance Binary Annotation where
@@ -393,7 +390,7 @@ instance Binary AliasType where
393390 case n of
394391 0 -> liftM Holey get
395392 1 -> liftM Filled get
396− _ -> fail "binary encoding of AliasType was corrupted"
393+ _ -> error "binary encoding of AliasType was corrupted"
397394
398395
399396instance Binary FieldType where
compiler/src/AST/Optimized.hs+40−101
@@ -7,35 +7,30 @@ module AST.Optimized
77 , Destructor(..)
88 , Decider(..)
99 , Choice(..)
10− , GlobalGraph(..)
11− , LocalGraph(..)
10+ , Graph(..)
1211 , Main(..)
1312 , Node(..)
1413 , EffectsType(..)
1514 , empty
16− , addGlobalGraph
17− , addLocalGraph
18− , addKernel
19− , toKernelGlobal
15+ , union
16+ , unions
2017 )
2118 where
2219
2320
2421import Control.Monad (liftM, liftM2, liftM3, liftM4)
2522import Data.Binary (Binary, get, put, getWord8, putWord8)
23+import qualified Data.List as List
2624import qualified Data.Map as Map
27−import qualified Data.Name as Name
2825import Data.Name (Name)
2926import qualified Data.Set as Set
27+import qualified Data.Utf8 as Utf8
3028
3129import qualified AST.Canonical as Can
3230import qualified AST.Utils.Shader as Shader
3331import qualified Data.Index as Index
34−import qualified Elm.Float as EF
3532import qualified Elm.Kernel as K
3633import qualified Elm.ModuleName as ModuleName
37−import qualified Elm.Package as Pkg
38−import qualified Elm.String as ES
3934import qualified Optimize.DecisionTree as DT
4035import qualified Reporting.Annotation as A
4136
@@ -46,10 +41,10 @@ import qualified Reporting.Annotation as A
4641
4742data Expr
4843 = Bool Bool
49− | Chr ES.String
50− | Str ES.String
44+ | Chr Utf8.String
45+ | Str Utf8.String
5146 | Int Int
52− | Float EF.Float
47+ | Float (Utf8.Under256 Float)
5348 | VarLocal Name
5449 | VarGlobal Global
5550 | VarEnum Global Index.ZeroBased
@@ -75,6 +70,7 @@ data Expr
7570
7671
7772data Global = Global ModuleName.Canonical Name
73+ deriving (Eq, Ord)
7874
7975
8076
@@ -125,18 +121,11 @@ data Choice
125121-- OBJECT GRAPH
126122
127123
128−data GlobalGraph =
129− GlobalGraph
130− { _g_nodes :: Map.Map Global Node
131− , _g_fields :: Map.Map Name Int
132− }
133−
134−
135−data LocalGraph =
136− LocalGraph
137− { _l_main :: Maybe Main
138− , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
139− , _l_fields :: Map.Map Name Int
124+data Graph =
125+ Graph
126+ { _mains :: Map.Map ModuleName.Canonical Main
127+ , _nodes :: Map.Map Global Node
128+ , _fields :: Map.Map Name Int
140129 }
141130
142131
@@ -170,72 +159,27 @@ data EffectsType = Cmd | Sub | Fx
170159
171160
172161{-# NOINLINE empty #-}
173−empty :: GlobalGraph
162+empty :: Graph
174163empty =
175− GlobalGraph Map.empty Map.empty
176−
177−
178−addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph
179−addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) =
180− GlobalGraph
181− { _g_nodes = Map.union nodes1 nodes2
182− , _g_fields = Map.union fields1 fields2
183− }
184−
185−
186−addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph
187−addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) =
188− GlobalGraph
189− { _g_nodes = Map.union nodes1 nodes2
190− , _g_fields = Map.union fields1 fields2
191− }
192−
164+ Graph Map.empty Map.empty Map.empty
193165
194−addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph
195−addKernel shortName chunks (GlobalGraph nodes fields) =
196− let
197− global = toKernelGlobal shortName
198− node = Kernel chunks (foldr addKernelDep Set.empty chunks)
199− in
200− GlobalGraph
201− { _g_nodes = Map.insert global node nodes
202− , _g_fields = Map.union (K.countFields chunks) fields
203− }
204−
205−
206−addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global
207−addKernelDep chunk deps =
208− case chunk of
209− K.JS _ -> deps
210− K.ElmVar home name -> Set.insert (Global home name) deps
211− K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps
212− K.ElmField _ -> deps
213− K.JsField _ -> deps
214− K.JsEnum _ -> deps
215− K.Debug -> deps
216− K.Prod -> deps
217−
218−
219−toKernelGlobal :: Name.Name -> Global
220−toKernelGlobal shortName =
221− Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar
222166
167+union :: Graph -> Graph -> Graph
168+union (Graph mains1 graph1 fields1) (Graph mains2 graph2 fields2) =
169+ Graph
170+ (Map.union mains1 mains2)
171+ (Map.union graph1 graph2)
172+ (Map.union fields1 fields2)
223173
224174
225−-- INSTANCES
175+unions :: [Graph] -> Graph
176+unions graphs =
177+ case graphs of
178+ [] ->
179+ empty
226180
227−
228−instance Eq Global where
229− (==) (Global home1 name1) (Global home2 name2) =
230− name1 == name2 && home1 == home2
231−
232−
233−instance Ord Global where
234− compare (Global home1 name1) (Global home2 name2) =
235− case compare name1 name2 of
236− LT -> LT
237− EQ -> compare home1 home2
238− GT -> GT
181+ g:gs ->
182+ List.foldl' union g gs
239183
240184
241185
@@ -308,7 +252,7 @@ instance Binary Expr where
308252 24 -> pure Unit
309253 25 -> liftM3 Tuple get get get
310254 26 -> liftM3 Shader get get get
311− _ -> fail "problem getting Opt.Expr binary"
255+ _ -> error "problem getting Opt.Expr binary"
312256
313257
314258instance Binary Def where
@@ -322,7 +266,7 @@ instance Binary Def where
322266 case word of
323267 0 -> liftM2 Def get get
324268 1 -> liftM3 TailDef get get get
325− _ -> fail "problem getting Opt.Def binary"
269+ _ -> error "problem getting Opt.Def binary"
326270
327271
328272instance Binary Destructor where
@@ -345,7 +289,7 @@ instance Binary Path where
345289 1 -> liftM2 Field get get
346290 2 -> liftM Unbox get
347291 3 -> liftM Root get
348− _ -> fail "problem getting Opt.Path binary"
292+ _ -> error "problem getting Opt.Path binary"
349293
350294
351295instance (Binary a) => Binary (Decider a) where
@@ -361,7 +305,7 @@ instance (Binary a) => Binary (Decider a) where
361305 0 -> liftM Leaf get
362306 1 -> liftM3 Chain get get get
363307 2 -> liftM3 FanOut get get get
364− _ -> fail "problem getting Opt.Decider binary"
308+ _ -> error "problem getting Opt.Decider binary"
365309
366310
367311instance Binary Choice where
@@ -375,18 +319,13 @@ instance Binary Choice where
375319 case word of
376320 0 -> liftM Inline get
377321 1 -> liftM Jump get
378− _ -> fail "problem getting Opt.Choice binary"
379−
380−
322+ _ -> error "problem getting Opt.Choice binary"
381323
382−instance Binary GlobalGraph where
383− get = liftM2 GlobalGraph get get
384− put (GlobalGraph a b) = put a >> put b
385324
386325
387−instance Binary LocalGraph where
388− get = liftM3 LocalGraph get get get
389− put (LocalGraph a b c) = put a >> put b >> put c
326+instance Binary Graph where
327+ get = liftM3 Graph get get get
328+ put (Graph a b c) = put a >> put b >> put c
390329
391330
392331instance Binary Main where
@@ -400,7 +339,7 @@ instance Binary Main where
400339 case word of
401340 0 -> return Static
402341 1 -> liftM2 Dynamic get get
403− _ -> fail "problem getting Opt.Main binary"
342+ _ -> error "problem getting Opt.Main binary"
404343
405344
406345instance Binary Node where
@@ -432,7 +371,7 @@ instance Binary Node where
432371 8 -> liftM2 Kernel get get
433372 9 -> liftM2 PortIncoming get get
434373 10 -> liftM2 PortOutgoing get get
435− _ -> fail "problem getting Opt.Node binary"
374+ _ -> error "problem getting Opt.Node binary"
436375
437376
438377instance Binary EffectsType where
@@ -448,4 +387,4 @@ instance Binary EffectsType where
448387 0 -> return Cmd
449388 1 -> return Sub
450389 2 -> return Fx
451− _ -> fail "problem getting Opt.EffectsType binary"
390+ _ -> error "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hs+19−36
@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module AST.Source
34 ( Expr, Expr_(..), VarType(..)
45 , Def(..)
@@ -11,12 +12,10 @@ module AST.Source
1112 , Value(..)
1213 , Union(..)
1314 , Alias(..)
14− , Infix(..)
15+ , Binop(..)
1516 , Port(..)
1617 , Effects(..)
1718 , Manager(..)
18− , Docs(..)
19− , Comment(..)
2019 , Exposing(..)
2120 , Exposed(..)
2221 , Privacy(..)
@@ -25,13 +24,10 @@ module AST.Source
2524
2625
2726import Data.Name (Name)
28−import qualified Data.Name as Name
27+import qualified Data.Utf8 as Utf8
2928
3029import qualified AST.Utils.Binop as Binop
3130import qualified AST.Utils.Shader as Shader
32−import qualified Elm.Float as EF
33−import qualified Elm.String as ES
34−import qualified Parse.Primitives as P
3531import qualified Reporting.Annotation as A
3632
3733
@@ -43,10 +39,10 @@ type Expr = A.Located Expr_
4339
4440
4541data Expr_
46− = Chr ES.String
47− | Str ES.String
42+ = Chr Utf8.String
43+ | Str Utf8.String
4844 | Int Int
49− | Float EF.Float
45+ | Float (Utf8.Under256 Float)
5046 | Var VarType Name
5147 | VarQual VarType Name Name
5248 | List [Expr]
@@ -97,8 +93,8 @@ data Pattern_
9793 | PCtorQual A.Region Name Name [Pattern]
9894 | PList [Pattern]
9995 | PCons Pattern Pattern
100− | PChr ES.String
101− | PStr ES.String
96+ | PChr Utf8.String
97+ | PStr Utf8.String
10298 | PInt Int
10399
104100
@@ -126,26 +122,22 @@ data Type_
126122
127123data Module =
128124 Module
129− { _name :: Maybe (A.Located Name)
125+ { _name :: Maybe Name
130126 , _exports :: A.Located Exposing
131− , _docs :: Docs
132127 , _imports :: [Import]
133128 , _values :: [A.Located Value]
134129 , _unions :: [A.Located Union]
135130 , _aliases :: [A.Located Alias]
136− , _binops :: [A.Located Infix]
131+ , _binops :: [A.Located Binop]
137132 , _effects :: Effects
138133 }
139134
140135
141136getName :: Module -> Name
142−getName (Module maybeName _ _ _ _ _ _ _ _) =
137+getName (Module maybeName _ _ _ _ _ _ _) =
143138 case maybeName of
144− Just (A.At _ name) ->
145− name
146−
147− Nothing ->
148− Name._Main
139+ Just name -> name
140+ Nothing -> "Main"
149141
150142
151143getImportName :: Import -> Name
@@ -164,7 +156,7 @@ data Import =
164156data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
165157data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
166158data Alias = Alias (A.Located Name) [A.Located Name] Type
167−data Infix = Infix Name Binop.Associativity Binop.Precedence Name
159+data Binop = Binop Name Binop.Associativity Binop.Precedence Name
168160data Port = Port (A.Located Name) Type
169161
170162
@@ -180,30 +172,21 @@ data Manager
180172 | Fx (A.Located Name) (A.Located Name)
181173
182174
183−data Docs
184− = NoDocs A.Region
185− | YesDocs Comment [(Name, Comment)]
186−
187−
188−newtype Comment =
189− Comment P.Snippet
190−
191−
192175
193176-- EXPOSING
194177
195178
196179data Exposing
197180 = Open
198− | Explicit [Exposed]
181+ | Explicit [A.Located Exposed]
199182
200183
201184data Exposed
202− = Lower (A.Located Name)
203− | Upper (A.Located Name) Privacy
204− | Operator A.Region Name
185+ = Lower Name
186+ | Upper Name Privacy
187+ | Operator Name
205188
206189
207190data Privacy
208− = Public A.Region
191+ = Public
209192 | Private
compiler/src/AST/Utils/Binop.hs+6−5
@@ -41,11 +41,12 @@ instance Binary Precedence where
4141instance Binary Associativity where
4242 get =
4343 do n <- getWord8
44− case n of
45− 0 -> return Left
46− 1 -> return Non
47− 2 -> return Right
48− _ -> fail "Error reading valid associativity from serialized string"
44+ return $
45+ case n of
46+ 0 -> Left
47+ 1 -> Non
48+ 2 -> Right
49+ _ -> error "Error reading valid associativity from serialized string"
4950
5051 put assoc =
5152 putWord8 $
compiler/src/AST/Utils/Shader.hs+4−51
@@ -4,27 +4,22 @@ module AST.Utils.Shader
44 ( Source
55 , Types(..)
66 , Type(..)
7− , fromChars
8− , toJsStringBuilder
97 )
108 where
119
1210
13−import Control.Monad (liftM)
14−import Data.Binary (Binary, get, put)
15−import qualified Data.ByteString as BS
16−import qualified Data.ByteString.Builder as B
17−import qualified Data.ByteString.UTF8 as BS_UTF8
1811import qualified Data.Map as Map
1912import qualified Data.Name as Name
13+import qualified Data.Utf8 as Utf8
2014
2115
2216
2317-- SOURCE
2418
2519
26−newtype Source =
27− Source BS.ByteString
20+type Source = Utf8.VeryLong SOURCE
21+
22+data SOURCE
2823
2924
3025
@@ -47,45 +42,3 @@ data Type
4742 | V4
4843 | M4
4944 | Texture
50−
51−
52−
53−-- TO BUILDER
54−
55−
56−toJsStringBuilder :: Source -> B.Builder
57−toJsStringBuilder (Source src) =
58− B.byteString src
59−
60−
61−
62−-- FROM CHARS
63−
64−
65−fromChars :: [Char] -> Source
66−fromChars chars =
67− Source (BS_UTF8.fromString (escape chars))
68−
69−
70−escape :: [Char] -> [Char]
71−escape chars =
72− case chars of
73− [] ->
74− []
75−
76− c:cs
77− | c == '\r' -> escape cs
78− | c == '\n' -> '\\' : 'n' : escape cs
79− | c == '\"' -> '\\' : '"' : escape cs
80− | c == '\'' -> '\\' : '\'' : escape cs
81− | c == '\\' -> '\\' : '\\' : escape cs
82− | otherwise -> c : escape cs
83−
84−
85−
86−-- BINARY
87−
88−
89−instance Binary Source where
90− get = liftM Source get
91− put (Source a) = put a
compiler/src/AST/Utils/Type.hs+1
@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module AST.Utils.Type
34 ( delambda
45 , dealias
compiler/src/Canonicalize/Environment.hs+20−50
@@ -4,8 +4,6 @@ module Canonicalize.Environment
44 ( Env(..)
55 , Exposed
66 , Qualified
7− , Info(..)
8− , mergeInfo
97 , Var(..)
108 , Type(..)
119 , Ctor(..)
@@ -22,8 +20,8 @@ module Canonicalize.Environment
2220
2321import qualified Data.Map.Merge.Strict as Map
2422import qualified Data.Map.Strict as Map
23+import qualified Data.Map.Strict.Internal as I
2524import qualified Data.Name as Name
26−import qualified Data.OneOrMore as OneOrMore
2725
2826import qualified AST.Utils.Binop as Binop
2927import qualified AST.Canonical as Can
@@ -60,34 +58,11 @@ data Env =
6058
6159
6260type Exposed a =
63− Map.Map Name.Name (Info a)
61+ Map.Map Name.Name (Map.Map ModuleName.Canonical a)
6462
6563
6664type Qualified a =
67− Map.Map Name.Name (Map.Map Name.Name (Info a))
68−
69−
70−
71−-- INFO
72−
73−
74−data Info a
75− = Specific ModuleName.Canonical a
76− | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77−
78−
79−mergeInfo :: Info a -> Info a -> Info a
80−mergeInfo info1 info2 =
81− case info1 of
82− Specific h1 _ ->
83− case info2 of
84− Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)
85− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86−
87− Ambiguous h1 hs1 ->
88− case info2 of
89− Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
65+ Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))
9166
9267
9368
@@ -97,8 +72,7 @@ mergeInfo info1 info2 =
9772data Var
9873 = Local A.Region
9974 | TopLevel A.Region
100− | Foreign ModuleName.Canonical Can.Annotation
101− | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
75+ | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
10276
10377
10478
@@ -165,10 +139,7 @@ addLocalLeft _ region =
165139addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
166140addLocalBoth name region var =
167141 case var of
168− Foreign _ _ ->
169− Result.ok (Local region)
170−
171− Foreigns _ _ ->
142+ Foreign _ ->
172143 Result.ok (Local region)
173144
174145 Local parentRegion ->
@@ -179,18 +150,17 @@ addLocalBoth name region var =
179150
180151
181152
182−
183153-- FIND TYPE
184154
185155
186156findType :: A.Region -> Env -> Name.Name -> Result i w Type
187157findType region (Env _ _ ts _ _ _ qts _) name =
188158 case Map.lookup name ts of
189− Just (Specific _ tipe) ->
159+ Just (I.Bin 1 _ tipe _ _) ->
190160 Result.ok tipe
191161
192− Just (Ambiguous h hs) ->
193− Result.throw (Error.AmbiguousType region Nothing name h hs)
162+ Just homes ->
163+ Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
194164
195165 Nothing ->
196166 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -201,11 +171,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
201171 case Map.lookup prefix qts of
202172 Just qualified ->
203173 case Map.lookup name qualified of
204− Just (Specific _ tipe) ->
174+ Just (I.Bin 1 _ tipe _ _) ->
205175 Result.ok tipe
206176
207− Just (Ambiguous h hs) ->
208− Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
177+ Just homes ->
178+ Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
209179
210180 Nothing ->
211181 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -221,11 +191,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
221191findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
222192findCtor region (Env _ _ _ cs _ _ _ qcs) name =
223193 case Map.lookup name cs of
224− Just (Specific _ ctor) ->
194+ Just (I.Bin 1 _ ctor _ _) ->
225195 Result.ok ctor
226196
227− Just (Ambiguous h hs) ->
228− Result.throw (Error.AmbiguousVariant region Nothing name h hs)
197+ Just homes ->
198+ Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
229199
230200 Nothing ->
231201 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -236,11 +206,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
236206 case Map.lookup prefix qcs of
237207 Just qualified ->
238208 case Map.lookup name qualified of
239− Just (Specific _ pattern) ->
209+ Just (I.Bin 1 _ pattern _ _) ->
240210 Result.ok pattern
241211
242− Just (Ambiguous h hs) ->
243− Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
212+ Just homes ->
213+ Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
244214
245215 Nothing ->
246216 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -256,11 +226,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
256226findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
257227findBinop region (Env _ _ _ _ binops _ _ _) name =
258228 case Map.lookup name binops of
259− Just (Specific _ binop) ->
229+ Just (I.Bin 1 _ binop _ _) ->
260230 Result.ok binop
261231
262− Just (Ambiguous h hs) ->
263− Result.throw (Error.AmbiguousBinop region name h hs)
232+ Just homes ->
233+ Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
264234
265235 Nothing ->
266236 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
compiler/src/Canonicalize/Environment/Dups.hs+3−6
@@ -57,11 +57,8 @@ detectHelp toError name values =
5757 OneOrMore.One (Info _ value) ->
5858 return value
5959
60− OneOrMore.More left right ->
61− let
62− (Info r1 _, Info r2 _) =
63− OneOrMore.getFirstTwo left right
64− in
60+ OneOrMore.More _ _ ->
61+ let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in
6562 Result.throw (toError name r1 r2)
6663
6764
@@ -105,7 +102,7 @@ one name region value =
105102
106103insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
107104insert name region value dict =
108− Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
105+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
109106
110107
111108union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+37−49
@@ -35,14 +35,7 @@ type Result i w a =
3535createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
3636createInitialEnv home ifaces imports =
3737 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
38− Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
39−
40−
41−infoToVar :: Env.Info Can.Annotation -> Env.Var
42−infoToVar info =
43− case info of
44− Env.Specific home tipe -> Env.Foreign home tipe
45− Env.Ambiguous h hs -> Env.Foreigns h hs
38+ Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
4639
4740
4841
@@ -68,7 +61,7 @@ emptyState =
6861
6962emptyTypes :: Env.Exposed Env.Type
7063emptyTypes =
71− Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
64+ Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
7265
7366
7467
@@ -109,8 +102,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
109102 (Map.mapMaybeWithKey (unionToType home) unions)
110103 (Map.mapMaybeWithKey (aliasToType home) aliases)
111104
112− !vars = Map.map (Env.Specific home) defs
113− !types = Map.map (Env.Specific home . fst) rawTypeInfo
105+ !vars = Map.map (Map.singleton home) defs
106+ !types = Map.map (Map.singleton home . fst) rawTypeInfo
114107 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
115108
116109 !qvs2 = addQualified prefix vars qvs
@@ -136,7 +129,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
136129
137130addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
138131addExposed =
139− Map.unionWith Env.mergeInfo
132+ Map.unionWith Map.union
140133
141134
142135addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -157,7 +150,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
157150unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
158151 let
159152 addCtor dict (Can.Ctor ctor index _ args) =
160− Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
153+ Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
161154 in
162155 ( Env.Union (length vars) home
163156 , List.foldl' addCtor Map.empty ctors
@@ -188,7 +181,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
188181 (Can.TAlias home name avars (Can.Filled tipe))
189182 (Can.fieldsToList fields)
190183 in
191− Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
184+ Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
192185
193186 _ ->
194187 Map.empty
@@ -199,9 +192,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
199192-- BINOP
200193
201194
202−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
195+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
203196binopToBinop home op (I.Binop name annotation associativity precedence) =
204− Env.Specific home (Env.Binop op home name annotation associativity precedence)
197+ Map.singleton home (Env.Binop op home name annotation associativity precedence)
205198
206199
207200
@@ -214,19 +207,19 @@ addExposedValue
214207 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
215208 -> Map.Map Name.Name I.Binop
216209 -> State
217− -> Src.Exposed
210+ -> A.Located Src.Exposed
218211 -> Result i w State
219−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
212+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
220213 case exposed of
221− Src.Lower (A.At region name) ->
214+ Src.Lower name ->
222215 case Map.lookup name vars of
223216 Just info ->
224− Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
217+ Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
225218
226219 Nothing ->
227220 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
228221
229− Src.Upper (A.At region name) privacy ->
222+ Src.Upper name privacy ->
230223 case privacy of
231224 Src.Private ->
232225 case Map.lookup name types of
@@ -234,43 +227,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
234227 case tipe of
235228 Env.Union _ _ ->
236229 let
237− !ts2 = Map.insert name (Env.Specific home tipe) ts
230+ !ts2 = Map.insert name (Map.singleton home tipe) ts
238231 in
239232 Result.ok (State vs ts2 cs bs qvs qts qcs)
240233
241234 Env.Alias _ _ _ _ ->
242235 let
243− !ts2 = Map.insert name (Env.Specific home tipe) ts
236+ !ts2 = Map.insert name (Map.singleton home tipe) ts
244237 !cs2 = addExposed cs ctors
245238 in
246239 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
247240
248241 Nothing ->
249− case checkForCtorMistake name types of
250− tipe:_ ->
242+ case Map.lookup name (toCtors types) of
243+ Just tipe ->
251244 Result.throw $ Error.ImportCtorByName region name tipe
252245
253− [] ->
246+ Nothing ->
254247 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
255248
256− Src.Public dotDotRegion ->
249+ Src.Public ->
257250 case Map.lookup name types of
258251 Just (tipe, ctors) ->
259252 case tipe of
260253 Env.Union _ _ ->
261254 let
262− !ts2 = Map.insert name (Env.Specific home tipe) ts
255+ !ts2 = Map.insert name (Map.singleton home tipe) ts
263256 !cs2 = addExposed cs ctors
264257 in
265258 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
266259
267260 Env.Alias _ _ _ _ ->
268− Result.throw (Error.ImportOpenAlias dotDotRegion name)
261+ Result.throw (Error.ImportOpenAlias region name)
269262
270263 Nothing ->
271264 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
272265
273− Src.Operator region op ->
266+ Src.Operator op ->
274267 case Map.lookup op binops of
275268 Just binop ->
276269 let
@@ -282,23 +275,18 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
282275 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
283276
284277
285−checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
286−checkForCtorMistake givenName types =
287− Map.foldr addMatches [] types
278+
279+toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
280+toCtors types =
281+ Map.foldr addCtors Map.empty types
288282 where
289− addMatches (_, exposedCtors) matches =
290− Map.foldrWithKey addMatch matches exposedCtors
291−
292− addMatch ctorName info matches =
293− if ctorName /= givenName
294− then matches
295− else
296− case info of
297− Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
298− tipeName : matches
299−
300− Env.Specific _ (Env.RecordCtor _ _ _) ->
301− matches
302−
303− Env.Ambiguous _ _ ->
304− matches
283+ addCtors (_, exposedCtors) dict =
284+ Map.foldrWithKey addCtor dict exposedCtors
285+
286+ addCtor ctorName homes dict =
287+ case Map.elems homes of
288+ [Env.Ctor _ tipeName _ _ _] ->
289+ Map.insert ctorName tipeName dict
290+
291+ _ ->
292+ dict
compiler/src/Canonicalize/Environment/Local.hs+8−8
@@ -54,7 +54,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
5454
5555
5656collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57−collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
57+collectVars (Src.Module _ _ _ values _ _ _ effects) =
5858 let
5959 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
6060 Dups.insert name region (Env.TopLevel region) dict
@@ -95,7 +95,7 @@ toEffectDups effects =
9595
9696
9797addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
98−addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
98+addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
9999 let
100100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs
110110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112112 do arity <- checkUnionFreeVars union
113− let one = Env.Specific home (Env.Union arity home)
113+ let one = Map.singleton home (Env.Union arity home)
114114 Result.ok $ Map.insert name one types
115115
116116
@@ -133,7 +133,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
133133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134134 do args <- checkAliasFreeVars alias
135135 ctype <- Type.canonicalize env tipe
136− let one = Env.Specific home (Env.Alias (length args) home args ctype)
136+ let one = Map.singleton home (Env.Alias (length args) home args ctype)
137137 let ts1 = Map.insert name one ts
138138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139139
@@ -262,7 +262,7 @@ addFreeVars freeVars (A.At region tipe) =
262262
263263
264264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
265−addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
265+addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266266 do unionInfo <- traverse (canonicalizeUnion env) unions
267267 aliasInfo <- traverse (canonicalizeAlias env) aliases
268268
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs
281281 )
282282
283283
284−type CtorDups = Dups.Dict (Env.Info Env.Ctor)
284+type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
285285
286286
287287
@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297297 ,
298298 case ctipe of
299299 Can.TRecord fields Nothing ->
300− Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
300+ Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
301301
302302 _ ->
303303 Dups.none
@@ -351,5 +351,5 @@ toOpts ctors =
351351
352352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Env.Specific home $
354+ Dups.one name region $ Map.singleton home $
355355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+7−6
@@ -14,6 +14,7 @@ import Control.Monad (foldM)
1414import qualified Data.Graph as Graph
1515import qualified Data.List as List
1616import qualified Data.Map.Strict as Map
17+import qualified Data.Map.Strict.Internal as I
1718import qualified Data.Name as Name
1819
1920import qualified AST.Canonical as Can
@@ -695,15 +696,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
695696 Env.TopLevel _ ->
696697 logVar name (Can.VarTopLevel localHome name)
697698
698− Env.Foreign home annotation ->
699+ Env.Foreign (I.Bin 1 home annotation _ _) ->
699700 Result.ok $
700701 if home == ModuleName.debug then
701702 Can.VarDebug localHome name annotation
702703 else
703704 Can.VarForeign home name annotation
704705
705− Env.Foreigns h hs ->
706− Result.throw (Error.AmbiguousVar region Nothing name h hs)
706+ Env.Foreign homes ->
707+ Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
707708
708709 Nothing ->
709710 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -714,15 +715,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
714715 case Map.lookup prefix qvs of
715716 Just qualified ->
716717 case Map.lookup name qualified of
717− Just (Env.Specific home annotation) ->
718+ Just (I.Bin 1 home annotation _ _) ->
718719 Result.ok $
719720 if home == ModuleName.debug then
720721 Can.VarDebug localHome name annotation
721722 else
722723 Can.VarForeign home name annotation
723724
724− Just (Env.Ambiguous h hs) ->
725− Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
725+ Just homes ->
726+ Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
726727
727728 Nothing ->
728729 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
compiler/src/Canonicalize/Module.hs+19−31
@@ -42,7 +42,7 @@ type Result i w a =
4242
4343
4444canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
45−canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
45+canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops effects) =
4646 do let home = ModuleName.Canonical pkg (Src.getName modul)
4747 let cbinops = Map.fromList (map canonicalizeBinop binops)
4848
@@ -54,15 +54,15 @@ canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ bino
5454 ceffects <- Effects.canonicalize env values cunions effects
5555 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
5656
57− return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
57+ return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects
5858
5959
6060
6161-- CANONICALIZE BINOP
6262
6363
64−canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65−canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
64+canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )
65+canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =
6666 ( op, Can.Binop_ associativity precedence func )
6767
6868
@@ -93,11 +93,13 @@ detectCycles sccs =
9393 Graph.AcyclicSCC (def, _, _) ->
9494 Can.Declare def <$> detectCycles otherSccs
9595
96+ Graph.CyclicSCC [] ->
97+ detectCycles otherSccs
98+
9699 Graph.CyclicSCC subNodes ->
97− do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)
98− case defs of
99− [] -> detectCycles otherSccs
100− d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs
100+ Can.DeclareRec
101+ <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
102+ <*> detectCycles otherSccs
101103
102104
103105detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
@@ -106,22 +108,8 @@ detectBadCycles scc =
106108 Graph.AcyclicSCC def ->
107109 Result.ok def
108110
109− Graph.CyclicSCC [] ->
110− error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!"
111−
112− Graph.CyclicSCC (def:defs) ->
113− let
114− (A.At region name) = extractDefName def
115− names = map (A.toValue . extractDefName) defs
116− in
117− Result.throw (Error.RecursiveDecl region name names)
118−
119−
120−extractDefName :: Can.Def -> A.Located Name.Name
121−extractDefName def =
122− case def of
123− Can.Def name _ _ -> name
124− Can.TypedDef name _ _ _ _ -> name
111+ Graph.CyclicSCC cyclicValueDefs ->
112+ Result.throw (Error.RecursiveDecl cyclicValueDefs)
125113
126114
127115
@@ -236,11 +224,11 @@ checkExposed
236224 -> Map.Map Name.Name alias
237225 -> Map.Map Name.Name binop
238226 -> Can.Effects
239− -> Src.Exposed
227+ -> A.Located Src.Exposed
240228 -> Result i w (Dups.Dict (A.Located Can.Export))
241−checkExposed values unions aliases binops effects exposed =
229+checkExposed values unions aliases binops effects (A.At region exposed) =
242230 case exposed of
243− Src.Lower (A.At region name) ->
231+ Src.Lower name ->
244232 if Map.member name values then
245233 ok name region Can.ExportValue
246234 else
@@ -252,23 +240,23 @@ checkExposed values unions aliases binops effects exposed =
252240 Result.throw $ Error.ExportNotFound region Error.BadVar name $
253241 ports ++ Map.keys values
254242
255− Src.Operator region name ->
243+ Src.Operator name ->
256244 if Map.member name binops then
257245 ok name region Can.ExportBinop
258246 else
259247 Result.throw $ Error.ExportNotFound region Error.BadOp name $
260248 Map.keys binops
261249
262− Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
250+ Src.Upper name Src.Public ->
263251 if Map.member name unions then
264252 ok name region Can.ExportUnionOpen
265253 else if Map.member name aliases then
266− Result.throw $ Error.ExportOpenAlias dotDotRegion name
254+ Result.throw $ Error.ExportOpenAlias region name
267255 else
268256 Result.throw $ Error.ExportNotFound region Error.BadType name $
269257 Map.keys unions ++ Map.keys aliases
270258
271− Src.Upper (A.At region name) Src.Private ->
259+ Src.Upper name Src.Private ->
272260 if Map.member name unions then
273261 ok name region Can.ExportUnionClosed
274262 else if Map.member name aliases then
compiler/src/Canonicalize/Pattern.hs+2−3
@@ -8,7 +8,6 @@ module Canonicalize.Pattern
88 where
99
1010
11−import qualified Data.List as List
1211import qualified Data.Map.Strict as Map
1312import qualified Data.Name as Name
1413
@@ -174,8 +173,8 @@ logVar name region value =
174173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
175174logFields fields value =
176175 let
177− addField dict (A.At region name) =
176+ addField (A.At region name) dict =
178177 Dups.insert name region region dict
179178 in
180179 Result.Result $ \bindings warnings _ ok ->
181− ok (List.foldl' addField bindings fields) warnings value
180+ ok (foldr addField bindings fields) warnings value
compiler/src/Compile.hs+19−27
@@ -8,6 +8,7 @@ module Compile
88
99import qualified Data.Map as Map
1010import qualified Data.Name as Name
11+import qualified Data.OneOrMore as OneOrMore
1112
1213import qualified AST.Source as Src
1314import qualified AST.Canonical as Can
@@ -20,7 +21,7 @@ import qualified Nitpick.PatternMatches as PatternMatches
2021import qualified Optimize.Module as Optimize
2122import qualified Reporting.Error as E
2223import qualified Reporting.Result as R
23−import qualified Reporting.Render.Type.Localizer as Localizer
24+import qualified Reporting.Warning as W
2425import qualified Type.Constrain.Module as Type
2526import qualified Type.Solve as Type
2627
@@ -35,16 +36,17 @@ data Artifacts =
3536 Artifacts
3637 { _modul :: Can.Module
3738 , _types :: Map.Map Name.Name Can.Annotation
38− , _graph :: Opt.LocalGraph
39+ , _graph :: Opt.Graph
3940 }
4041
4142
42−compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
43+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> ([W.Warning], Either (OneOrMore.OneOrMore E.Error) Artifacts)
4344compile pkg ifaces modul =
45+ R.run $
4446 do canonical <- canonicalize pkg ifaces modul
45− annotations <- typeCheck modul canonical
47+ annotations <- typeCheck canonical
4648 () <- nitpick canonical
47− objects <- optimize modul annotations canonical
49+ objects <- optimize annotations canonical
4850 return (Artifacts canonical annotations objects)
4951
5052
@@ -52,41 +54,31 @@ compile pkg ifaces modul =
5254-- PHASES
5355
5456
55−canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
57+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> R.Result i [W.Warning] E.Error Can.Module
5658canonicalize pkg ifaces modul =
57− case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of
58− Right canonical ->
59− Right canonical
60−
61− Left errors ->
62− Left $ E.BadNames errors
59+ R.mapError E.Canonicalize $ Canonicalize.canonicalize pkg ifaces modul
6360
6461
65−typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
66−typeCheck modul canonical =
62+typeCheck :: Can.Module -> R.Result i w E.Error (Map.Map Name.Name Can.Annotation)
63+typeCheck canonical =
6764 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
6865 Right annotations ->
69− Right annotations
66+ R.ok annotations
7067
7168 Left errors ->
72− Left (E.BadTypes (Localizer.fromModule modul) errors)
69+ R.throw (E.Type errors)
7370
7471
75−nitpick :: Can.Module -> Either E.Error ()
72+nitpick :: Can.Module -> R.Result i w E.Error ()
7673nitpick canonical =
7774 case PatternMatches.check canonical of
7875 Right () ->
79− Right ()
76+ R.ok ()
8077
8178 Left errors ->
82− Left (E.BadPatterns errors)
79+ R.throw (E.Pattern errors)
8380
8481
85−optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
86−optimize modul annotations canonical =
87− case snd $ R.run $ Optimize.optimize annotations canonical of
88− Right localGraph ->
89− Right localGraph
90−
91− Left errors ->
92− Left (E.BadMains (Localizer.fromModule modul) errors)
82+optimize :: Map.Map Name.Name Can.Annotation -> Can.Module -> R.Result i [W.Warning] E.Error Opt.Graph
83+optimize annotations canonical =
84+ R.mapError E.Main $ Optimize.optimize annotations canonical
compiler/src/Data/Map/Utils.hsdeleted−43
@@ -1,43 +0,0 @@
1−module Data.Map.Utils
2− ( fromKeys
3− , fromKeysA
4− , fromValues
5− , any
6− )
7− where
8−
9−
10−import Prelude hiding (any)
11−import qualified Data.Map as Map
12−import Data.Map.Internal (Map(..))
13−
14−
15−
16−-- FROM KEYS
17−
18−
19−fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v
20−fromKeys toValue keys =
21− Map.fromList $ map (\k -> (k, toValue k)) keys
22−
23−
24−fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v)
25−fromKeysA toValue keys =
26− Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
27−
28−
29−fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v
30−fromValues toKey values =
31− Map.fromList $ map (\v -> (toKey v, v)) values
32−
33−
34−
35−-- ANY
36−
37−
38−{-# INLINE any #-}
39−any :: (v -> Bool) -> Map.Map k v -> Bool
40−any isGood = go
41− where
42− go Tip = False
43− go (Bin _ _ v l r) = isGood v || go l || go r
compiler/src/Data/Name.hs+177−166
@@ -1,119 +1,130 @@
11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
33module Data.Name
44 ( Name
5− --
6− , toChars
7− , toElmString
8− , toBuilder
9− --
10− , fromPtr
11− , fromChars
12− --
5+ , toUtf8
6+ , fromUtf8
7+ , toEscapedBuilder
8+ , Utf8.toBuilder
9+ , Utf8.fromPtr
10+ , Utf8.fromChars
11+ , Utf8.toChars
12+ -- misc
1313 , getKernel
1414 , hasDot
15− , splitDots
1615 , isKernel
1716 , isNumberType
1817 , isComparableType
1918 , isAppendableType
2019 , isCompappendType
2120 , fromVarIndex
21+ , fromReplCount
2222 , fromWords
2323 , fromManyNames
2424 , fromTypeVariable
2525 , fromTypeVariableScheme
2626 , sepBy
27− --
27+ -- interned
2828 , int, float, bool, char, string
2929 , maybe, result, list, array, dict, tuple, jsArray
3030 , task, router, cmd, sub, platform, virtualDom
3131 , shader, debug, debugger, bitwise, basics
3232 , utils, negate, true, false, value
33− , node, program, _main, _Main, dollar, identity
34− , replModule, replValueToPrint
33+ , node, program, main, dollar, identity
34+ , replModule
3535 )
3636 where
3737
3838
3939import Prelude hiding (length, maybe, negate)
4040import Control.Exception (assert)
41−import qualified Data.Binary as Binary
4241import qualified Data.ByteString.Builder.Internal as B
43−import qualified Data.Coerce as Coerce
42+import Data.Coerce (coerce)
4443import qualified Data.List as List
45−import qualified Data.String as Chars
4644import qualified Data.Utf8 as Utf8
45+import Foreign.Ptr (plusPtr, minusPtr)
4746import GHC.Exts
48− ( Int(I#), Ptr
47+ ( Int(I#), Ptr(Ptr)
48+ , RealWorld
4949 , MutableByteArray#
5050 , isTrue#
5151 , newByteArray#
5252 , sizeofByteArray#
53+ , writeWord8OffAddr#
54+ , copyByteArrayToAddr#
5355 , unsafeFreezeByteArray#
5456 )
57+import GHC.IO
5558import GHC.ST (ST(ST), runST)
5659import GHC.Prim
5760import GHC.Word (Word8(W8#))
5861
59−import qualified Elm.String as ES
60−
6162
6263
6364-- NAME
6465
6566
66−type Name =
67− Utf8.Utf8 ELM_NAME
68−
69−
70−data ELM_NAME
71−
72−
73−
74−-- INSTANCES
75−
67+type Name = Utf8.Under256 NAME
7668
77−instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78− fromString = Utf8.fromChars
7969
80−instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81− get = Utf8.getUnder256
82− put = Utf8.putUnder256
70+data NAME
8371
8472
73+toUtf8 :: Name -> Utf8.String
74+toUtf8 =
75+ coerce
8576
86−-- TO
8777
78+fromUtf8 :: Utf8.String -> Name
79+fromUtf8 =
80+ coerce
8881
89−toChars :: Name -> [Char]
90−toChars =
91− Utf8.toChars
9282
9383
94−toElmString :: Name -> ES.String
95−toElmString =
96− Coerce.coerce
84+-- TO ESCAPED BUILDER
9785
9886
99−{-# INLINE toBuilder #-}
100−toBuilder :: Name -> B.Builder
101−toBuilder =
102− Utf8.toBuilder
87+{-# INLINE toEscapedBuilder #-}
88+toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
89+toEscapedBuilder before after =
90+ \name -> B.builder (toEscapedBuilderHelp before after name)
10391
10492
93+{-# INLINE toEscapedBuilderHelp #-}
94+toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
95+toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
96+ go 0 (I# (sizeofByteArray# ba#))
97+ where
98+ go !offset !len !(B.BufferRange bOffset bEnd) =
99+ let
100+ !bLen = minusPtr bEnd bOffset
101+ in
102+ if len <= bLen then
103+ do -- TODO test if writing word-by-word is faster
104+ stToIO (copyToPtr name offset bOffset len)
105+ stToIO (escape before after bOffset name offset len 0)
106+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
107+ k newBufferRange
108+ else
109+ do stToIO (copyToPtr name offset bOffset bLen)
110+ stToIO (escape before after bOffset name offset bLen 0)
111+ let !newOffset = offset + bLen
112+ let !newLength = len - bLen
113+ return $ B.bufferFull 1 bEnd (go newOffset newLength)
114+
115+
116+escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
117+escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
118+ if isTrue# (i# <# len#) then
119+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
120+ then
121+ do writeWordToPtr ptr i after
122+ escape before after ptr name offset len (i + 1)
123+ else
124+ do escape before after ptr name offset len (i + 1)
105125
106−-- FROM
107−
108−
109−fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110−fromPtr =
111− Utf8.fromPtr
112−
113−
114−fromChars :: [Char] -> Name
115−fromChars =
116− Utf8.fromChars
126+ else
127+ return ()
117128
118129
119130
@@ -122,12 +133,7 @@ fromChars =
122133
123134hasDot :: Name -> Bool
124135hasDot name =
125− Utf8.contains 0x2E {- . -} name
126−
127−
128−splitDots :: Name -> [Name]
129−splitDots name =
130− Utf8.split 0x2E {- . -} name
136+ Utf8.contains 0x2E {- . -} (coerce name)
131137
132138
133139
@@ -175,23 +181,23 @@ isCompappendType = Utf8.startsWith prefix_compappend
175181
176182{-# NOINLINE prefix_kernel #-}
177183prefix_kernel :: Name
178−prefix_kernel = fromChars "Elm.Kernel."
184+prefix_kernel = "Elm.Kernel."
179185
180186{-# NOINLINE prefix_number #-}
181187prefix_number :: Name
182−prefix_number = fromChars "number"
188+prefix_number = "number"
183189
184190{-# NOINLINE prefix_comparable #-}
185191prefix_comparable :: Name
186−prefix_comparable = fromChars "comparable"
192+prefix_comparable = "comparable"
187193
188194{-# NOINLINE prefix_appendable #-}
189195prefix_appendable :: Name
190−prefix_appendable = fromChars "appendable"
196+prefix_appendable = "appendable"
191197
192198{-# NOINLINE prefix_compappend #-}
193199prefix_compappend :: Name
194−prefix_compappend = fromChars "compappend"
200+prefix_compappend = "compappend"
195201
196202
197203
@@ -202,11 +208,11 @@ fromVarIndex :: Int -> Name
202208fromVarIndex n =
203209 runST
204210 (
205− do let !size = 2 + getIndexSize n
211+ do let !size = getIndexSize n
206212 mba <- newByteArray size
207213 writeWord8 mba 0 0x5F {- _ -}
208214 writeWord8 mba 1 0x76 {- v -}
209− writeDigitsAtEnd mba size n
215+ writeDigits mba (size - 1) n
210216 freeze mba
211217 )
212218
@@ -214,20 +220,19 @@ fromVarIndex n =
214220{-# INLINE getIndexSize #-}
215221getIndexSize :: Int -> Int
216222getIndexSize n
217− | n < 10 = 1
218− | n < 100 = 2
219− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
223+ | n < 10 = 3
224+ | n < 100 = 4
225+ | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
220226
221227
222228
223−writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
224−writeDigitsAtEnd !mba !oldOffset !n =
229+writeDigits :: MBA s -> Int -> Int -> ST s ()
230+writeDigits !mba !offset !n =
225231 do let (q,r) = quotRem n 10
226− let !newOffset = oldOffset - 1
227− writeWord8 mba newOffset (0x30 + fromIntegral r)
232+ writeWord8 mba offset (0x30 + fromIntegral r)
228233 if q <= 0
229234 then return ()
230− else writeDigitsAtEnd mba newOffset q
235+ else writeDigits mba (offset-1) q
231236
232237
233238
@@ -250,7 +255,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
250255 mba <- newByteArray size
251256 copyToMBA name mba
252257 writeWord8 mba (I# len#) 0x5F {- _ -}
253− writeDigitsAtEnd mba size index
258+ writeDigits mba (size - 1) index
254259 freeze mba
255260 )
256261 else
@@ -259,7 +264,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
259264 do let !size = I# len# + getIndexSize index
260265 mba <- newByteArray size
261266 copyToMBA name mba
262− writeDigitsAtEnd mba size index
267+ writeDigits mba (size - 1) index
263268 freeze mba
264269 )
265270
@@ -278,61 +283,61 @@ fromTypeVariableScheme scheme =
278283 freeze mba
279284 else
280285 do let (extra, letter) = quotRem scheme 26
281− let !size = 1 + getIndexSize extra
286+ let !size = getIndexSize extra
282287 mba <- newByteArray size
283288 writeWord8 mba 0 (0x61 + fromIntegral letter)
284− writeDigitsAtEnd mba size extra
289+ writeDigits mba (size - 1) extra
285290 freeze mba
286291 )
287292
288293
289294
295+-- FROM REPL COUNT
296+
297+
298+fromReplCount :: Int -> Name
299+fromReplCount n =
300+ Utf8.fromChars ("repl_value_" ++ show n)
301+
302+
303+
290304-- FROM MANY NAMES
291−--
292−-- Creating a unique name by combining all the subnames can create names
293−-- longer than 256 bytes relatively easily. So instead, the first given name
294−-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295−--
296−-- This should be a unique name since 0.19 disallows shadowing. It would not
297−-- be possible for multiple top-level cycles to include values with the same
298−-- name, so the important thing is to make the cycle name distinct from the
299−-- normal name. Same logic for destructuring patterns like (x,y)
300305
301306
302307fromManyNames :: [Name] -> Name
303308fromManyNames names =
304− case names of
305− [] ->
306− blank
307− -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)
308− -- but maybe unused patterns should be stripped out instead
309−
310− Utf8.Utf8 ba# : _ ->
311− let
312− len# = sizeofByteArray# ba#
313− in
314− runST
315− (
316− ST $ \s ->
317− case newByteArray# (len# +# 3#) s of
318− (# s, mba# #) ->
319− case writeWord8Array# mba# 0# 0x5F## {-_-} s of
320− s ->
321− case writeWord8Array# mba# 1# 0x4D## {-M-} s of
322− s ->
323− case writeWord8Array# mba# 2# 0x24## {-$-} s of
324− s ->
325− case copyByteArray# ba# 0# mba# 3# len# s of
326− s ->
327− case unsafeFreezeByteArray# mba# s of
328− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329− )
309+ let
310+ !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
311+ in
312+ runST
313+ (
314+ ST $ \s ->
315+ case newByteArray# size# s of
316+ (# s, mba# #) ->
317+ case writeNames mba# 0# names s of
318+ s ->
319+ case unsafeFreezeByteArray# mba# s of
320+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
321+ )
330322
331323
332−{-# NOINLINE blank #-}
333−blank :: Name
334−blank =
335− fromWords [0x5F,0x4D,0x24] {-_M$-}
324+writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
325+writeNames mba# !offset# names s =
326+ case names of
327+ [] ->
328+ s
329+
330+ (Utf8.Utf8 ba#) : names ->
331+ case writeWord8Array# mba# offset# 0x24## {- $ -} s of
332+ s ->
333+ let
334+ !offset1# = offset# +# 1#
335+ !len# = sizeofByteArray# ba#
336+ !newOffset# = offset1# +# len#
337+ in
338+ case copyByteArray# ba# 0# mba# offset1# len# s of
339+ s ->
340+ writeNames mba# newOffset# names s
336341
337342
338343
@@ -418,6 +423,22 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
418423 s -> (# s, () #)
419424
420425
426+{-# INLINE writeWordToPtr #-}
427+writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()
428+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
429+ ST $ \s ->
430+ case writeWord8OffAddr# addr# offset# word# s of
431+ s -> (# s, () #)
432+
433+
434+{-# INLINE copyToPtr #-}
435+copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
436+copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =
437+ ST $ \s ->
438+ case copyByteArrayToAddr# ba# offset# addr# len# s of
439+ s -> (# s, () #)
440+
441+
421442{-# INLINE copyToMBA #-}
422443copyToMBA :: Name -> MBA s -> ST s ()
423444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
@@ -432,179 +453,169 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
432453
433454{-# NOINLINE int #-}
434455int :: Name
435−int = fromChars "Int"
456+int = "Int"
436457
437458
438459{-# NOINLINE float #-}
439460float :: Name
440−float = fromChars "Float"
461+float = "Float"
441462
442463
443464{-# NOINLINE bool #-}
444465bool :: Name
445−bool = fromChars "Bool"
466+bool = "Bool"
446467
447468
448469{-# NOINLINE char #-}
449470char :: Name
450−char = fromChars "Char"
471+char = "Char"
451472
452473
453474{-# NOINLINE string #-}
454475string :: Name
455−string = fromChars "String"
476+string = "String"
456477
457478
458479{-# NOINLINE maybe #-}
459480maybe :: Name
460−maybe = fromChars "Maybe"
481+maybe = "Maybe"
461482
462483
463484{-# NOINLINE result #-}
464485result :: Name
465−result = fromChars "Result"
486+result = "Result"
466487
467488
468489{-# NOINLINE list #-}
469490list :: Name
470−list = fromChars "List"
491+list = "List"
471492
472493
473494{-# NOINLINE array #-}
474495array :: Name
475−array = fromChars "Array"
496+array = "Array"
476497
477498
478499{-# NOINLINE dict #-}
479500dict :: Name
480−dict = fromChars "Dict"
501+dict = "Dict"
481502
482503
483504{-# NOINLINE tuple #-}
484505tuple :: Name
485−tuple = fromChars "Tuple"
506+tuple = "Tuple"
486507
487508
488509{-# NOINLINE jsArray #-}
489510jsArray :: Name
490−jsArray = fromChars "JsArray"
511+jsArray = "JsArray"
491512
492513
493514{-# NOINLINE task #-}
494515task :: Name
495−task = fromChars "Task"
516+task = "Task"
496517
497518
498519{-# NOINLINE router #-}
499520router :: Name
500−router = fromChars "Router"
521+router = "Router"
501522
502523
503524{-# NOINLINE cmd #-}
504525cmd :: Name
505−cmd = fromChars "Cmd"
526+cmd = "Cmd"
506527
507528
508529{-# NOINLINE sub #-}
509530sub :: Name
510−sub = fromChars "Sub"
531+sub = "Sub"
511532
512533
513534{-# NOINLINE platform #-}
514535platform :: Name
515−platform = fromChars "Platform"
536+platform = "Platform"
516537
517538
518539{-# NOINLINE virtualDom #-}
519540virtualDom :: Name
520−virtualDom = fromChars "VirtualDom"
541+virtualDom = "VirtualDom"
521542
522543
523544{-# NOINLINE shader #-}
524545shader :: Name
525−shader = fromChars "Shader"
546+shader = "Shader"
526547
527548
528549{-# NOINLINE debug #-}
529550debug :: Name
530−debug = fromChars "Debug"
551+debug = "Debug"
531552
532553
533554{-# NOINLINE debugger #-}
534555debugger :: Name
535−debugger = fromChars "Debugger"
556+debugger = "Debugger"
536557
537558
538559{-# NOINLINE bitwise #-}
539560bitwise :: Name
540−bitwise = fromChars "Bitwise"
561+bitwise = "Bitwise"
541562
542563
543564{-# NOINLINE basics #-}
544565basics :: Name
545−basics = fromChars "Basics"
566+basics = "Basics"
546567
547568
548569{-# NOINLINE utils #-}
549570utils :: Name
550−utils = fromChars "Utils"
571+utils = "Utils"
551572
552573
553574{-# NOINLINE negate #-}
554575negate :: Name
555−negate = fromChars "negate"
576+negate = "negate"
556577
557578
558579{-# NOINLINE true #-}
559580true :: Name
560−true = fromChars "True"
581+true = "True"
561582
562583
563584{-# NOINLINE false #-}
564585false :: Name
565−false = fromChars "False"
586+false = "False"
566587
567588
568589{-# NOINLINE value #-}
569590value :: Name
570−value = fromChars "Value"
591+value = "Value"
571592
572593
573594{-# NOINLINE node #-}
574595node :: Name
575−node = fromChars "Node"
596+node = "Node"
576597
577598
578599{-# NOINLINE program #-}
579600program :: Name
580−program = fromChars "Program"
581−
601+program = "Program"
582602
583−{-# NOINLINE _main #-}
584−_main :: Name
585−_main = fromChars "main"
586603
587−
588−{-# NOINLINE _Main #-}
589−_Main :: Name
590−_Main = fromChars "Main"
604+{-# NOINLINE main #-}
605+main :: Name
606+main = "main"
591607
592608
593609{-# NOINLINE dollar #-}
594610dollar :: Name
595−dollar = fromChars "$"
611+dollar = "$"
596612
597613
598614{-# NOINLINE identity #-}
599615identity :: Name
600−identity = fromChars "identity"
616+identity = "identity"
601617
602618
603619{-# NOINLINE replModule #-}
604620replModule :: Name
605−replModule = fromChars "Elm_Repl"
606−
607−
608−{-# NOINLINE replValueToPrint #-}
609−replValueToPrint :: Name
610−replValueToPrint = fromChars "repl_input_value_"
621+replModule = "Elm_Repl"
compiler/src/Data/NonEmptyList.hsdeleted−78
@@ -1,78 +0,0 @@
1−module Data.NonEmptyList
2− ( List(..)
3− , singleton
4− , toList
5− , sortBy
6− )
7− where
8−
9−
10−import Control.Monad (liftM2)
11−import Data.Binary (Binary, get, put)
12−import qualified Data.List as List
13−
14−
15−
16−-- LIST
17−
18−
19−data List a =
20− List a [a]
21−
22−
23−singleton :: a -> List a
24−singleton a =
25− List a []
26−
27−
28−toList :: List a -> [a]
29−toList (List x xs) =
30− x:xs
31−
32−
33−
34−-- INSTANCES
35−
36−
37−instance Functor List where
38− fmap func (List x xs) = List (func x) (map func xs)
39−
40−
41−instance Traversable List where
42− traverse func (List x xs) = List <$> func x <*> traverse func xs
43−
44−
45−instance Foldable List where
46− foldr step state (List x xs) = step x (foldr step state xs)
47− foldl step state (List x xs) = foldl step (step state x) xs
48− foldl1 step (List x xs) = foldl step x xs
49−
50−
51−
52−-- SORT BY
53−
54−
55−sortBy :: (Ord b) => (a -> b) -> List a -> List a
56−sortBy toRank (List x xs) =
57− let
58− comparison a b =
59− compare (toRank a) (toRank b)
60− in
61− case List.sortBy comparison xs of
62− [] ->
63− List x []
64−
65− y:ys ->
66− case comparison x y of
67− LT -> List x (y:ys)
68− EQ -> List x (y:ys)
69− GT -> List y (List.insertBy comparison x ys)
70−
71−
72−
73−-- BINARY
74−
75−
76−instance (Binary a) => Binary (List a) where
77− put (List x xs) = put x >> put xs
78− get = liftM2 List get get
compiler/src/Data/OneOrMore.hs+24−39
@@ -3,9 +3,9 @@ module Data.OneOrMore
33 ( OneOrMore(..)
44 , one
55 , more
6+ , toList
67 , map
78 , destruct
8− , getFirstTwo
99 )
1010 where
1111
@@ -33,6 +33,25 @@ more =
3333
3434
3535
36+-- TO LIST
37+
38+
39+toList :: OneOrMore a -> [a]
40+toList oneOrMore =
41+ toListHelp oneOrMore []
42+
43+
44+toListHelp :: OneOrMore a -> [a] -> [a]
45+toListHelp oneOrMore list =
46+ case oneOrMore of
47+ One x ->
48+ x : list
49+
50+ More a b ->
51+ toListHelp a (toListHelp b list)
52+
53+
54+
3655-- MAP
3756
3857
@@ -52,48 +71,14 @@ map func oneOrMore =
5271
5372destruct :: (a -> [a] -> b) -> OneOrMore a -> b
5473destruct func oneOrMore =
55− destructLeft func oneOrMore []
74+ destructHelp func oneOrMore []
5675
5776
58−destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
59−destructLeft func oneOrMore xs =
77+destructHelp :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
78+destructHelp func oneOrMore xs =
6079 case oneOrMore of
6180 One x ->
6281 func x xs
6382
6483 More a b ->
65− destructLeft func a (destructRight b xs)
66−
67−
68−destructRight :: OneOrMore a -> [a] -> [a]
69−destructRight oneOrMore xs =
70− case oneOrMore of
71− One x ->
72− x : xs
73−
74− More a b ->
75− destructRight a (destructRight b xs)
76−
77−
78−
79−-- GET FIRST TWO
80−
81−
82−getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)
83−getFirstTwo left right =
84− case left of
85− One x ->
86− (x, getFirstOne right)
87−
88− More lleft lright ->
89− getFirstTwo lleft lright
90−
91−
92−getFirstOne :: OneOrMore a -> a
93−getFirstOne oneOrMore =
94− case oneOrMore of
95− One x ->
96− x
97−
98− More left _ ->
99− getFirstOne left
84+ destructHelp func a (toListHelp b xs)
compiler/src/Data/Utf8.hs+300−158
@@ -1,42 +1,36 @@
11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
33module Data.Utf8
4− ( Utf8(..)
4+ ( String
5+ , Utf8(..)
6+ , VeryLong
7+ , Under256
58 , isEmpty
6− , empty
79 , size
810 , contains
11+ , containsDouble
912 , startsWith
1013 , startsWithChar
11− , endsWithWord8
14+ , endsWithWord
1215 , split
1316 , join
14− --
15− , getUnder256
16− , putUnder256
17− --
18− , getVeryLong
19− , putVeryLong
20− --
17+ , all
18+ , any
19+ , toWord16
20+ , fromWord16
21+ -- conversions
22+ , fromChars
2123 , toChars
2224 , toBuilder
23− , toEscapedBuilder
24− --
2525 , fromPtr
26− , fromSnippet
27− , fromChars
28− --
29− , MBA
30− , newByteArray
31− , copyFromPtr
32− , writeWord8
33− , freeze
26+ , fromChunks
27+ , Chunk(..)
3428 )
3529 where
3630
3731
3832import Prelude hiding (String, all, any, concat)
39−import Data.Binary (Get, get, getWord8, Put, put, putWord8)
33+import Data.Binary (Binary(..), Get, getWord8, putWord8)
4034import Data.Binary.Put (putBuilder)
4135import Data.Binary.Get.Internal (readN)
4236import Data.Bits ((.&.), shiftR)
@@ -44,6 +38,7 @@ import qualified Data.ByteString.Internal as B
4438import qualified Data.ByteString.Builder.Internal as B
4539import qualified Data.Char as Char
4640import qualified Data.List as List
41+import Data.String (IsString(..))
4742import Foreign.ForeignPtr (touchForeignPtr)
4843import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
4944import Foreign.Ptr (minusPtr, plusPtr)
@@ -58,35 +53,36 @@ import GHC.Exts
5853 , copyByteArray#
5954 , copyAddrToByteArray#
6055 , copyByteArrayToAddr#
61− , writeWord8Array#
56+ , writeWord8Array#,
6257 )
6358import GHC.IO
6459import GHC.ST (ST(ST), runST)
6560import GHC.Prim
66−import GHC.Word (Word8(W8#))
67−
68−import qualified Parse.Primitives as P
61+import GHC.Word (Word8(W8#), Word16(W16#))
6962
7063
7164
7265-- UTF-8
7366
7467
75−data Utf8 tipe =
68+data Utf8 size tipe =
7669 Utf8 ByteArray#
7770
7871
72+type String = Utf8 VERY_LONG STRING
73+type VeryLong t = Utf8 VERY_LONG t
74+type Under256 t = Utf8 UNDER_256 t
7975
80−-- EMPTY
76+data STRING
77+data VERY_LONG
78+data UNDER_256
8179
8280
83−{-# NOINLINE empty #-}
84−empty :: Utf8 t
85−empty =
86− runST (freeze =<< newByteArray 0)
8781
82+-- IS EMPTY
8883
89−isEmpty :: Utf8 t -> Bool
84+
85+isEmpty :: Utf8 l t -> Bool
9086isEmpty (Utf8 ba#) =
9187 isTrue# (sizeofByteArray# ba# ==# 0#)
9288
@@ -95,7 +91,7 @@ isEmpty (Utf8 ba#) =
9591-- SIZE
9692
9793
98−size :: Utf8 t -> Int
94+size :: Utf8 l t -> Int
9995size (Utf8 ba#) =
10096 I# (sizeofByteArray# ba#)
10197
@@ -104,7 +100,7 @@ size (Utf8 ba#) =
104100-- CONTAINS
105101
106102
107−contains :: Word8 -> Utf8 t -> Bool
103+contains :: Word8 -> Utf8 l t -> Bool
108104contains (W8# word#) (Utf8 ba#) =
109105 containsHelp word# ba# 0# (sizeofByteArray# ba#)
110106
@@ -120,11 +116,32 @@ containsHelp word# ba# !offset# len# =
120116
121117
122118
119+-- CONTAINS DOUBLE
120+
121+
122+containsDouble :: Word8 -> Utf8 l t -> Bool
123+containsDouble (W8# word#) (Utf8 ba#) =
124+ containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)
125+
126+
127+containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
128+containsDoubleHelp word# ba# !offset# len# =
129+ let !offset1# = offset# +# 1# in
130+ if isTrue# (offset1# <# len#) then
131+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))
132+ && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))
133+ then True
134+ else containsDoubleHelp word# ba# (offset# +# 1#) len#
135+ else
136+ False
137+
138+
139+
123140-- STARTS WITH
124141
125142
126143{-# INLINE startsWith #-}
127−startsWith :: Utf8 t -> Utf8 t -> Bool
144+startsWith :: Utf8 l t -> Utf8 l t -> Bool
128145startsWith (Utf8 ba1#) (Utf8 ba2#) =
129146 let
130147 !len1# = sizeofByteArray# ba1#
@@ -139,9 +156,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =
139156-- STARTS WITH CHAR
140157
141158
142−startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
143−startsWithChar isGood bytes@(Utf8 ba#) =
144− if isEmpty bytes then
159+startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
160+startsWithChar isGood str@(Utf8 ba#) =
161+ if isEmpty str then
145162 False
146163 else
147164 let
@@ -159,8 +176,8 @@ startsWithChar isGood bytes@(Utf8 ba#) =
159176-- ENDS WITH WORD
160177
161178
162−endsWithWord8 :: Word8 -> Utf8 t -> Bool
163−endsWithWord8 (W8# w#) (Utf8 ba#) =
179+endsWithWord :: Word8 -> Utf8 l t -> Bool
180+endsWithWord (W8# w#) (Utf8 ba#) =
164181 let len# = sizeofByteArray# ba# in
165182 isTrue# (len# ># 0#)
166183 &&
@@ -171,12 +188,12 @@ endsWithWord8 (W8# w#) (Utf8 ba#) =
171188-- SPLIT
172189
173190
174−split :: Word8 -> Utf8 t -> [Utf8 t]
191+split :: Word8 -> String -> [String]
175192split (W8# divider#) str@(Utf8 ba#) =
176193 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
177194
178195
179−splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
196+splitHelp :: String -> Int -> [Int] -> [String]
180197splitHelp str start offsets =
181198 case offsets of
182199 [] ->
@@ -197,7 +214,7 @@ findDividers divider# ba# !offset# len# revOffsets =
197214 reverse revOffsets
198215
199216
200−unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
217+unsafeSlice :: String -> Int -> Int -> String
201218unsafeSlice str start end =
202219 let !len = end - start in
203220 if len == 0 then
@@ -213,7 +230,7 @@ unsafeSlice str start end =
213230-- JOIN
214231
215232
216−join :: Word8 -> [Utf8 t] -> Utf8 t
233+join :: Word8 -> [String] -> String
217234join sep strings =
218235 case strings of
219236 [] ->
@@ -227,7 +244,7 @@ join sep strings =
227244 freeze mba
228245
229246
230−joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
247+joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
231248joinHelp sep mba offset str strings =
232249 let
233250 !len = size str
@@ -245,10 +262,46 @@ joinHelp sep mba offset str strings =
245262
246263
247264
265+-- ALL
266+
267+
268+all :: (Char -> Bool) -> Utf8 l t -> Bool
269+all isGood utf8 =
270+ not (any (not . isGood) utf8)
271+
272+
273+
274+-- ANY
275+
276+
277+any :: (Char -> Bool) -> Utf8 l t -> Bool
278+any isGood (Utf8 ba#) =
279+ anyHelp isGood ba# 0# (sizeofByteArray# ba#)
280+
281+
282+anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool
283+anyHelp isGood ba# offset# len# =
284+ if isTrue# (offset# >=# len#) then
285+ False
286+ else
287+ let
288+ !w# = indexWord8Array# ba# offset#
289+ !(# char, width# #)
290+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
291+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
292+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
293+ | True = (# chr4 ba# offset# w#, 4# #)
294+ in
295+ if isGood char
296+ then True
297+ else anyHelp isGood ba# (offset# +# width#) len#
298+
299+
300+
248301-- EQUAL
249302
250303
251−instance Eq (Utf8 t) where
304+instance Eq (Utf8 l t) where
252305 (==) (Utf8 ba1#) (Utf8 ba2#) =
253306 let
254307 !len1# = sizeofByteArray# ba1#
@@ -261,11 +314,9 @@ instance Eq (Utf8 t) where
261314
262315
263316-- COMPARE
264−--
265−-- TODO: is it fine to sort by length and only compare bytes on length ties?
266−--
267317
268−instance Ord (Utf8 t) where
318+
319+instance Ord (Utf8 l t) where
269320 compare (Utf8 ba1#) (Utf8 ba2#) =
270321 let
271322 !len1# = sizeofByteArray# ba1#
@@ -282,20 +333,84 @@ instance Ord (Utf8 t) where
282333
283334
284335
336+-- TO WORD16
337+
338+
339+toWord16 :: String -> Maybe Word16
340+toWord16 (Utf8 ba#) =
341+ let !len# = sizeofByteArray# ba# in
342+ if isTrue# (len# ==# 0#) then
343+ Nothing
344+ else
345+ let !w# = indexWord8Array# ba# 0# in
346+ if isTrue# (eqWord# w# 0x30##) then
347+ if isTrue# (len# ==# 1#) then Just 0 else Nothing
348+ else
349+ toWordHelp ba# 0# len# 0##
350+
351+
352+toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16
353+toWordHelp ba# offset# len# number# =
354+ if isTrue# (offset# <# len#) then
355+ let !w# = indexWord8Array# ba# offset# in
356+ if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then
357+ let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in
358+ toWordHelp ba# (offset# +# 1#) len# newNumber#
359+ else
360+ Nothing
361+ else
362+ Just (W16# number#)
363+
364+
365+
366+-- FROM WORD16
367+
368+
369+fromWord16 :: Word16 -> String
370+fromWord16 n =
371+ runST $
372+ do let !size = getWordSize n
373+ mba <- newByteArray size
374+ writeDigits mba (size - 1) n
375+ freeze mba
376+
377+
378+getWordSize :: Word16 -> Int
379+getWordSize n
380+ | n < 10 = 1
381+ | n < 100 = 2
382+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
383+
384+
385+writeDigits :: MBA s -> Int -> Word16 -> ST s ()
386+writeDigits !mba !offset !n =
387+ do let (q,r) = quotRem n 10
388+ writeWord8 mba offset (0x30 + fromIntegral r)
389+ if q <= 0
390+ then return ()
391+ else writeDigits mba (offset-1) q
392+
393+
394+
285395-- FROM STRING
286396
287397
288−fromChars :: [Char] -> Utf8 t
289−fromChars chars =
290− runST
291− (
292− do mba <- newByteArray (sum (map getWidth chars))
293− writeChars mba 0 chars
294− )
398+fromChars :: [Char] -> Utf8 l t
399+fromChars =
400+ fromString
401+
295402
403+instance IsString (Utf8 l t) where
404+ fromString str =
405+ runST
406+ (
407+ do mba <- newByteArray (sum (map getWidth str))
408+ writeString mba 0 str
409+ )
296410
297−writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
298−writeChars !mba !offset chars =
411+
412+writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
413+writeString !mba !offset chars =
299414 case chars of
300415 [] ->
301416 freeze mba
@@ -303,25 +418,25 @@ writeChars !mba !offset chars =
303418 char : chars
304419 | n < 0x80 ->
305420 do writeWord8 mba (offset ) (fromIntegral n)
306− writeChars mba (offset + 1) chars
421+ writeString mba (offset + 1) chars
307422
308423 | n < 0x800 ->
309424 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
310425 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
311− writeChars mba (offset + 2) chars
426+ writeString mba (offset + 2) chars
312427
313428 | n < 0x10000 ->
314429 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
315430 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
316431 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
317− writeChars mba (offset + 3) chars
432+ writeString mba (offset + 3) chars
318433
319434 | otherwise ->
320435 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
321436 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
322437 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
323438 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
324− writeChars mba (offset + 4) chars
439+ writeString mba (offset + 4) chars
325440
326441 where
327442 n = Char.ord char
@@ -339,10 +454,10 @@ getWidth char
339454
340455
341456
342−-- TO CHARS
457+-- TO STRING
343458
344459
345−toChars :: Utf8 t -> [Char]
460+toChars :: Utf8 l t -> [Char]
346461toChars (Utf8 ba#) =
347462 toCharsHelp ba# 0# (sizeofByteArray# ba#)
348463
@@ -412,13 +527,13 @@ chr4 ba# offset# firstWord# =
412527
413528
414529{-# INLINE toBuilder #-}
415−toBuilder :: Utf8 t -> B.Builder
530+toBuilder :: Utf8 l t -> B.Builder
416531toBuilder =
417532 \bytes -> B.builder (toBuilderHelp bytes)
418533
419534
420535{-# INLINE toBuilderHelp #-}
421−toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
536+toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
422537toBuilderHelp !bytes@(Utf8 ba#) k =
423538 go 0 (I# (sizeofByteArray# ba#))
424539 where
@@ -438,57 +553,10 @@ toBuilderHelp !bytes@(Utf8 ba#) k =
438553
439554
440555
441−-- TO ESCAPED BUILDER
442−
443−
444−{-# INLINE toEscapedBuilder #-}
445−toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
446−toEscapedBuilder before after =
447− \name -> B.builder (toEscapedBuilderHelp before after name)
448−
449−
450−{-# INLINE toEscapedBuilderHelp #-}
451−toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a
452−toEscapedBuilderHelp before after !name@(Utf8 ba#) k =
453− go 0 (I# (sizeofByteArray# ba#))
454− where
455− go !offset !len !(B.BufferRange bOffset bEnd) =
456− let
457− !bLen = minusPtr bEnd bOffset
458− in
459− if len <= bLen then
460− do -- PERF test if writing word-by-word is faster
461− copyToPtr name offset bOffset len
462− escape before after bOffset name offset len 0
463− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
464− k newBufferRange
465− else
466− do copyToPtr name offset bOffset bLen
467− escape before after bOffset name offset bLen 0
468− let !newOffset = offset + bLen
469− let !newLength = len - bLen
470− return $ B.bufferFull 1 bEnd (go newOffset newLength)
471−
472−
473−escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()
474−escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
475− if isTrue# (i# <# len#) then
476− if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
477− then
478− do writeWordToPtr ptr i after
479− escape before after ptr name offset len (i + 1)
480− else
481− do escape before after ptr name offset len (i + 1)
482−
483− else
484− return ()
485−
486−
487−
488556-- FROM PTR
489557
490558
491−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
559+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
492560fromPtr pos end =
493561 unsafeDupablePerformIO (stToIO (
494562 do let !len = minusPtr end pos
@@ -499,48 +567,130 @@ fromPtr pos end =
499567
500568
501569
502−-- FROM SNIPPET
570+-- FROM CHUNKS
503571
504572
505−fromSnippet :: P.Snippet -> Utf8 t
506−fromSnippet (P.Snippet fptr off len _ _) =
573+data Chunk
574+ = Slice (Ptr Word8) Int
575+ | Escape Word8
576+ | CodePoint Int
577+
578+
579+fromChunks :: [Chunk] -> Utf8 l t
580+fromChunks chunks =
507581 unsafeDupablePerformIO (stToIO (
508− do mba <- newByteArray len
509− let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
510− copyFromPtr pos mba 0 len
582+ do let !len = sum (map chunkToWidth chunks)
583+ mba <- newByteArray len
584+ writeChunks mba 0 chunks
511585 freeze mba
512586 ))
513587
514588
589+chunkToWidth :: Chunk -> Int
590+chunkToWidth chunk =
591+ case chunk of
592+ Slice _ len ->
593+ len
594+
595+ Escape _ ->
596+ 2
597+
598+ CodePoint code ->
599+ if code < 0xFFFF then 6 else 12
600+
601+
602+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
603+writeChunks mba offset chunks =
604+ case chunks of
605+ [] ->
606+ return ()
607+
608+ chunk : chunks ->
609+ case chunk of
610+ Slice ptr len ->
611+ do copyFromPtr ptr mba offset len
612+ let !newOffset = offset + len
613+ writeChunks mba newOffset chunks
614+
615+ Escape word ->
616+ do writeWord8 mba offset 0x5C {- \ -}
617+ writeWord8 mba (offset + 1) word
618+ let !newOffset = offset + 2
619+ writeChunks mba newOffset chunks
620+
621+ CodePoint code ->
622+ if code < 0xFFFF then
623+ do writeCode mba offset code
624+ let !newOffset = offset + 6
625+ writeChunks mba newOffset chunks
626+ else
627+ do let (hi,lo) = divMod (code - 0x10000) 0x400
628+ writeCode mba (offset ) (hi + 0xD800)
629+ writeCode mba (offset + 6) (lo + 0xDC00)
630+ let !newOffset = offset + 12
631+ writeChunks mba newOffset chunks
632+
633+
634+-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
635+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
636+writeCode mba offset code =
637+ do writeWord8 mba offset 0x5C {- \ -}
638+ writeWord8 mba offset 0x75 {- u -}
639+ writeHex mba (offset + 2) (shiftR code 12)
640+ writeHex mba (offset + 3) (shiftR code 8)
641+ writeHex mba (offset + 4) (shiftR code 4)
642+ writeHex mba (offset + 5) code
643+
644+
645+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
646+writeHex mba !offset !bits =
647+ do let !n = fromIntegral bits .&. 0x0F
648+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
515649
516−-- BINARY
517650
518651
519−putUnder256 :: Utf8 t -> Put
520−putUnder256 bytes =
521− do putWord8 (fromIntegral (size bytes))
522− putBuilder (toBuilder bytes)
652+-- UNDER 256 BINARY
523653
524654
525−getUnder256 :: Get (Utf8 t)
526−getUnder256 =
527− do word <- getWord8
528− let !n = fromIntegral word
529− readN n (copyFromByteString n)
655+instance Binary (Utf8 UNDER_256 t) where
656+ put bytes@(Utf8 ba#) =
657+ do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
658+ putBuilder (toBuilder bytes)
659+ get =
660+ getUnder256 =<< getWord8
530661
531662
532−putVeryLong :: Utf8 t -> Put
533−putVeryLong bytes =
534− do put (size bytes)
535− putBuilder (toBuilder bytes)
663+{-# INLINE getUnder256 #-}
664+getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
665+getUnder256 w =
666+ let !n = fromIntegral w in
667+ readN n (copyFromByteString n)
536668
537669
538−getVeryLong :: Get (Utf8 t)
539−getVeryLong =
540− do n <- get
541− if n > 0
542− then readN n (copyFromByteString n)
543− else return empty
670+
671+-- VERY LONG BINARY
672+
673+
674+instance Binary (Utf8 VERY_LONG t) where
675+ put str =
676+ do put (size str)
677+ putBuilder (toBuilder str)
678+ get =
679+ getVeryLong =<< get
680+
681+
682+{-# INLINE getVeryLong #-}
683+getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
684+getVeryLong n =
685+ if n > 0
686+ then readN n (copyFromByteString n)
687+ else return empty
688+
689+
690+{-# NOINLINE empty #-}
691+empty :: Utf8 l t
692+empty =
693+ runST (freeze =<< newByteArray 0)
544694
545695
546696
@@ -548,7 +698,7 @@ getVeryLong =
548698
549699
550700{-# INLINE copyFromByteString #-}
551−copyFromByteString :: Int -> B.ByteString -> Utf8 t
701+copyFromByteString :: Int -> B.ByteString -> Utf8 l t
552702copyFromByteString len (B.PS fptr offset _) =
553703 unsafeDupablePerformIO
554704 (
@@ -567,21 +717,21 @@ data MBA s =
567717 MBA# (MutableByteArray# s)
568718
569719
570−newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
720+newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
571721newByteArray (I# len#) =
572722 ST $ \s ->
573723 case newByteArray# len# s of
574724 (# s, mba# #) -> (# s, MBA# mba# #)
575725
576726
577−freeze :: MBA s -> ST s (Utf8 t)
727+freeze :: MBA s -> ST s (Utf8 l t)
578728freeze (MBA# mba#) =
579729 ST $ \s ->
580730 case unsafeFreezeByteArray# mba# s of
581731 (# s, ba# #) -> (# s, Utf8 ba# #)
582732
583733
584−copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
734+copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
585735copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
586736 ST $ \s ->
587737 case copyByteArray# ba# offset# mba# i# len# s of
@@ -595,11 +745,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
595745 s -> (# s, () #)
596746
597747
598−copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
748+copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
599749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
600− IO $ \s ->
601− case copyByteArrayToAddr# ba# offset# mba# len# s of
602− s -> (# s, () #)
750+ IO $ \s ->
751+ case copyByteArrayToAddr# ba# offset# mba# len# s of
752+ s -> (# s, () #)
603753
604754
605755{-# INLINE writeWord8 #-}
@@ -608,11 +758,3 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
608758 ST $ \s ->
609759 case writeWord8Array# mba# offset# w# s of
610760 s -> (# s, () #)
611−
612−
613−{-# INLINE writeWordToPtr #-}
614−writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()
615−writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
616− IO $ \s ->
617− case writeWord8OffAddr# addr# offset# word# s of
618− s -> (# s, () #)
compiler/src/Elm/Compiler.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Compiler
3+ ( Compile.Artifacts(..)
4+ , compile
5+ , Error.Error
6+ , errorsToDoc
7+ , errorsToJson
8+ , Warning.Warning
9+ )
10+ where
11+
12+
13+import qualified Data.ByteString as BS
14+import qualified Data.Map as Map
15+import qualified Data.Name as Name
16+import qualified Data.Utf8 as Utf8
17+
18+import qualified Compile
19+import qualified Elm.Interface as I
20+import qualified Elm.ModuleName as ModuleName
21+import qualified Elm.Package as Pkg
22+import qualified Json.Encode as E
23+import Json.Encode ((==>))
24+import qualified Reporting.Annotation as A
25+import qualified Reporting.Doc as D
26+import qualified Reporting.Error as Error
27+import qualified Reporting.Render.Code as Code
28+import qualified Reporting.Report as Report
29+import qualified Reporting.Result as Result
30+import qualified Reporting.Warning as Warning
31+
32+
33+
34+-- COMPILE
35+
36+
37+compile
38+ :: Pkg.Name
39+ -> Map.Map ModuleName.Raw ModuleName.Canonical
40+ -> I.Interfaces
41+ -> BS.ByteString
42+ -> ( [Warning.Warning], Either [Error.Error] Compile.Artifacts )
43+compile pkg importDict interfaces source =
44+ Result.run $ Compile.compile pkg importDict interfaces source
45+
46+
47+
48+-- ERRORS TO DOC
49+
50+
51+errorsToDoc :: FilePath -> String -> [Error.Error] -> D.Doc
52+errorsToDoc filePath source errors =
53+ let
54+ reports =
55+ concatMap (Error.toReports (Code.toSource source)) errors
56+ in
57+ D.vcat $ map (Report.toDoc filePath) reports
58+
59+
60+
61+-- ERRORS TO JSON
62+
63+
64+errorsToJson :: ModuleName.Raw -> FilePath -> String -> [Error.Error] -> E.Value
65+errorsToJson moduleName filePath source errors =
66+ let
67+ reports =
68+ concatMap (Error.toReports (Code.toSource source)) errors
69+ in
70+ E.object
71+ [ "path" ==> E.string (Utf8.fromChars filePath)
72+ , "name" ==> E.string (Name.toUtf8 moduleName)
73+ , "problems" ==> E.array (map reportToJson reports)
74+ ]
75+
76+
77+reportToJson :: Report.Report -> E.Value
78+reportToJson (Report.Report title region _sgstns message) =
79+ E.object
80+ [ "title" ==> E.string (Utf8.fromChars title)
81+ , "region" ==> encodeRegion region
82+ , "message" ==> D.encode message
83+ ]
84+
85+
86+encodeRegion :: A.Region -> E.Value
87+encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
88+ E.object
89+ [ "start" ==>
90+ E.object
91+ [ ("line", E.int (fromIntegral sr))
92+ , ("column", E.int (fromIntegral sc))
93+ ]
94+ , "end" ==>
95+ E.object
96+ [ ("line", E.int (fromIntegral er))
97+ , ("column", E.int (fromIntegral ec))
98+ ]
99+ ]
compiler/src/Elm/Compiler/Imports.hs+13−4
@@ -1,7 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Elm.Compiler.Imports
4− ( defaults
4+ ( addDefaults
55 )
66 where
77
@@ -14,6 +14,15 @@ import qualified Reporting.Annotation as A
1414
1515
1616
17+-- ADD DEFAULTS
18+
19+
20+addDefaults :: [Src.Import] -> [Src.Import]
21+addDefaults imports =
22+ defaults ++ imports
23+
24+
25+
1726-- DEFAULTS
1827
1928
@@ -49,14 +58,14 @@ closed =
4958
5059typeOpen :: Name.Name -> Src.Exposing
5160typeOpen name =
52− Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
61+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]
5362
5463
5564typeClosed :: Name.Name -> Src.Exposing
5665typeClosed name =
57− Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
66+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
5867
5968
6069operator :: Name.Name -> Src.Exposing
6170operator op =
62− Src.Explicit [ Src.Operator A.zero op ]
71+ Src.Explicit [ A.At A.zero (Src.Operator op) ]
compiler/src/Elm/Compiler/Type.hs+35−33
@@ -15,19 +15,21 @@ module Elm.Compiler.Type
1515
1616
1717import qualified Data.Name as Name
18+import qualified Data.Text as Text
19+import qualified Data.Text.Encoding as Text
1820
1921import qualified AST.Source as Src
20−import qualified Json.Decode as D
21−import qualified Json.Encode as E
22−import Json.Encode ((==>))
23−import qualified Json.String as Json
24−import qualified Parse.Primitives as P
22+import qualified Parse.Primitives as Parse
2523import qualified Parse.Type as Type
2624import qualified Reporting.Annotation as A
2725import qualified Reporting.Doc as D
2826import qualified Reporting.Render.Type as RT
2927import qualified Reporting.Render.Type.Localizer as L
3028
29+import qualified Json.Decode as Decode
30+import qualified Json.Encode as Encode
31+import Json.Encode ((==>))
32+
3133
3234
3335-- TYPES
@@ -111,18 +113,20 @@ collectLambdas tipe =
111113-- JSON for TYPE
112114
113115
114−encode :: Type -> E.Value
116+encode :: Type -> Encode.Value
115117encode tipe =
116− E.chars $ D.toLine (toDoc L.empty RT.None tipe)
118+ Encode.text $ Text.pack $ D.toLine (toDoc L.empty RT.None tipe)
117119
118120
119−decoder :: D.Decoder () Type
121+decoder :: Decode.Decoder () Type
120122decoder =
121− let
122− parser =
123− P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
124− in
125− D.customString parser (\_ _ -> ())
123+ do txt <- Decode.text
124+ case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
125+ Left _ ->
126+ Decode.fail ()
127+
128+ Right (tipe, _, _) ->
129+ Decode.succeed (fromRawType tipe)
126130
127131
128132fromRawType :: Src.Type -> Type
@@ -160,35 +164,33 @@ fromRawType (A.At _ astType) =
160164-- JSON for PROGRAM
161165
162166
163−encodeMetadata :: DebugMetadata -> E.Value
167+encodeMetadata :: DebugMetadata -> Encode.Value
164168encodeMetadata (DebugMetadata msg aliases unions) =
165− E.object
169+ Encode.object
166170 [ "message" ==> encode msg
167− , "aliases" ==> E.object (map toTypeAliasField aliases)
168− , "unions" ==> E.object (map toCustomTypeField unions)
171+ , "aliases" ==> Encode.object (map toAliasField aliases)
172+ , "unions" ==> Encode.object (map toUnionField unions)
169173 ]
170174
171175
172−toTypeAliasField :: Alias -> ( Json.String, E.Value )
173−toTypeAliasField (Alias name args tipe) =
174− ( Json.fromName name
175− , E.object
176− [ "args" ==> E.list E.name args
176+toAliasField :: Alias -> ( Text.Text, Encode.Value )
177+toAliasField (Alias name args tipe) =
178+ Name.toText name ==>
179+ Encode.object
180+ [ "args" ==> Encode.list Encode.name args
177181 , "type" ==> encode tipe
178182 ]
179− )
180183
181184
182−toCustomTypeField :: Union -> ( Json.String, E.Value )
183−toCustomTypeField (Union name args constructors) =
184− ( Json.fromName name
185− , E.object
186− [ "args" ==> E.list E.name args
187− , "tags" ==> E.object (map toVariantObject constructors)
185+toUnionField :: Union -> ( Text.Text, Encode.Value )
186+toUnionField (Union name args constructors) =
187+ Name.toText name ==>
188+ Encode.object
189+ [ "args" ==> Encode.list Encode.name args
190+ , "tags" ==> Encode.object (map toCtorObject constructors)
188191 ]
189− )
190192
191193
192−toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )
193−toVariantObject (name, args) =
194− ( Json.fromName name, E.list encode args )
194+toCtorObject :: (Name.Name, [Type]) -> ( Text.Text, Encode.Value )
195+toCtorObject (name, args) =
196+ Name.toText name ==> Encode.list encode args
compiler/src/Elm/Compiler/Type/Extract.hs+20−69
@@ -1,20 +1,15 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE Rank2Types #-}
34module Elm.Compiler.Type.Extract
45 ( fromAnnotation
56 , fromType
6− , Types(..)
7− , mergeMany
8− , merge
9− , fromInterface
10− , fromDependencyInterface
117 , fromMsg
128 )
139 where
1410
1511
1612import Data.Map ((!))
17−import qualified Data.Map as Map
1813import qualified Data.Maybe as Maybe
1914import qualified Data.Name as Name
2015import qualified Data.Set as Set
@@ -82,70 +77,23 @@ toPublicName (ModuleName.Canonical _ home) name =
8277
8378
8479
85−-- TRANSITIVELY AVAILABLE TYPES
86−
87−
88−newtype Types =
89− Types (Map.Map ModuleName.Canonical Types_)
90− -- PERF profile Opt.Global representation
91− -- current representation needs less allocation
92− -- but maybe the lookup is much worse
93−
94−
95−data Types_ =
96− Types_
97− { _union_info :: Map.Map Name.Name Can.Union
98− , _alias_info :: Map.Map Name.Name Can.Alias
99− }
100−
101−
102−mergeMany :: [Types] -> Types
103−mergeMany listOfTypes =
104− case listOfTypes of
105− [] -> Types Map.empty
106− t:ts -> foldr merge t ts
107−
108−
109−merge :: Types -> Types -> Types
110−merge (Types types1) (Types types2) =
111− Types (Map.union types1 types2)
112−
113−
114−fromInterface :: ModuleName.Raw -> I.Interface -> Types
115−fromInterface name (I.Interface pkg _ unions aliases _) =
116− Types $ Map.singleton (ModuleName.Canonical pkg name) $
117− Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
118−
119−
120−fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types
121−fromDependencyInterface home di =
122− Types $ Map.singleton home $
123− case di of
124− I.Public (I.Interface _ _ unions aliases _) ->
125− Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
126−
127− I.Private _ unions aliases ->
128− Types_ unions aliases
129−
130−
131−
13280-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
13381
13482
135−fromMsg :: Types -> Can.Type -> T.DebugMetadata
136−fromMsg types message =
83+fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
84+fromMsg interfaces message =
13785 let
13886 (msgDeps, msgType) =
13987 run (extract message)
14088
14189 (aliases, unions) =
142− extractTransitive types noDeps msgDeps
90+ extractTransitive interfaces noDeps msgDeps
14391 in
14492 T.DebugMetadata msgType aliases unions
14593
14694
147−extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )
148−extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
95+extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
96+extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
14997 let
15098 aliases = Set.difference nextAliases seenAliases
15199 unions = Set.difference nextUnions seenUnions
@@ -158,36 +106,39 @@ extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnio
158106 (newDeps, result) =
159107 run $
160108 (,)
161− <$> traverse (extractAlias types) (Set.toList aliases)
162− <*> traverse (extractUnion types) (Set.toList unions)
109+ <$> traverse (extractAlias interfaces) (Set.toList aliases)
110+ <*> traverse (extractUnion interfaces) (Set.toList unions)
163111
164112 oldDeps =
165113 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
166114
167115 remainingResult =
168− extractTransitive types oldDeps newDeps
116+ extractTransitive interfaces oldDeps newDeps
169117 in
170118 mappend result remainingResult
171119
172120
173−extractAlias :: Types -> Opt.Global -> Extractor T.Alias
174−extractAlias (Types dict) (Opt.Global home name) =
121+extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
122+extractAlias interfaces (Opt.Global home name) =
175123 let
176− (Can.Alias args aliasType) = _alias_info (dict ! home) ! name
124+ (I.Interface _ _ aliases _) = interfaces ! home
125+ (Can.Alias args aliasType) = I.toAliasInternals (aliases ! name)
177126 in
178127 T.Alias (toPublicName home name) args <$> extract aliasType
179128
180129
181−extractUnion :: Types -> Opt.Global -> Extractor T.Union
182−extractUnion (Types dict) (Opt.Global home name) =
130+extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
131+extractUnion interfaces (Opt.Global home name) =
183132 if name == Name.list && home == ModuleName.list
184133 then return $ T.Union (toPublicName home name) ["a"] []
185134 else
186135 let
187136 pname = toPublicName home name
188− (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name
137+ unions = I._unions (interfaces ! home)
189138 in
190− T.Union pname vars <$> traverse extractCtor ctors
139+ case I.toUnionInternals (unions ! name) of
140+ Can.Union vars ctors _ _ ->
141+ T.Union pname vars <$> traverse extractCtor ctors
191142
192143
193144extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])
compiler/src/Elm/Constraint.hs+77−55
@@ -5,6 +5,9 @@ module Elm.Constraint
55 , exactly
66 , anything
77 , toChars
8+ , toString
9+ , Error(..)
10+ , fromString
811 , satisfies
912 , check
1013 , intersect
@@ -13,8 +16,6 @@ module Elm.Constraint
1316 , untilNextMajor
1417 , untilNextMinor
1518 , expand
16− --
17− , Error(..)
1819 , decoder
1920 , encode
2021 )
@@ -23,12 +24,11 @@ module Elm.Constraint
2324
2425import Control.Monad (liftM4)
2526import Data.Binary (Binary, get, put, getWord8, putWord8)
27+import qualified Data.Utf8 as Utf8
2628
2729import qualified Elm.Version as V
2830import qualified Json.Decode as D
2931import qualified Json.Encode as E
30−import qualified Parse.Primitives as P
31−import Parse.Primitives (Row, Col)
3232
3333
3434
@@ -61,21 +61,78 @@ anything =
6161
6262
6363
64−-- TO CHARS
64+-- TO STRING
6565
6666
67−toChars :: Constraint -> [Char]
67+toChars :: Constraint -> String
6868toChars constraint =
69+ Utf8.toChars (toString constraint)
70+
71+
72+toString :: Constraint -> Utf8.String
73+toString constraint =
6974 case constraint of
7075 Range lower lowerOp upperOp upper ->
71− V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper
76+ Utf8.join 0x20 {- -}
77+ [ V.toString lower
78+ , toStringHelp lowerOp
79+ , "v"
80+ , toStringHelp upperOp
81+ , V.toString upper
82+ ]
7283
7384
74−opToChars :: Op -> [Char]
75−opToChars op =
85+toStringHelp :: Op -> Utf8.String
86+toStringHelp op =
7687 case op of
77− Less -> " < "
78− LessOrEqual -> " <= "
88+ Less -> "<"
89+ LessOrEqual -> "<="
90+
91+
92+
93+-- FROM STRING
94+
95+
96+data Error
97+ = BadLower Utf8.String
98+ | BadUpper Utf8.String
99+ | BadFormat
100+ | InvalidOp
101+ | InvalidRange V.Version V.Version
102+
103+
104+fromString :: Utf8.String -> Either Error Constraint
105+fromString string =
106+ case Utf8.split 0x20 {- -} string of
107+ [lower, lowerOp, "v", upperOp, upper] ->
108+ do lo <- versionFromString lower BadLower
109+ lop <- opFromString lowerOp
110+ hop <- opFromString upperOp
111+ hi <- versionFromString upper BadUpper
112+ if lo < hi
113+ then Right (Range lo lop hop hi)
114+ else Left (InvalidRange lo hi)
115+
116+ _ ->
117+ Left BadFormat
118+
119+
120+versionFromString :: Utf8.String -> (Utf8.String -> Error) -> Either Error V.Version
121+versionFromString string toError =
122+ case V.fromString string of
123+ Just vsn ->
124+ Right vsn
125+
126+ Nothing ->
127+ Left (toError string)
128+
129+
130+opFromString :: Utf8.String -> Either Error Op
131+opFromString text =
132+ case text of
133+ "<=" -> Right LessOrEqual
134+ "<" -> Right Less
135+ _ -> Left InvalidOp
79136
80137
81138
@@ -188,12 +245,18 @@ expand constraint@(Range lower lowerOp upperOp upper) version
188245
189246encode :: Constraint -> E.Value
190247encode constraint =
191− E.chars (toChars constraint)
248+ E.string (toString constraint)
192249
193250
194251decoder :: D.Decoder Error Constraint
195252decoder =
196− D.customString parser BadFormat
253+ do str <- D.string
254+ case fromString str of
255+ Right constraint ->
256+ return constraint
257+
258+ Left err ->
259+ D.failure err
197260
198261
199262
@@ -216,45 +279,4 @@ instance Binary Op where
216279 case n of
217280 0 -> return Less
218281 1 -> return LessOrEqual
219− _ -> fail "binary encoding of Op was corrupted"
220−
221−
222−
223−-- PARSER
224−
225−
226−data Error
227− = BadFormat Row Col
228− | InvalidRange V.Version V.Version
229−
230−
231−parser :: P.Parser Error Constraint
232−parser =
233− do lower <- parseVersion
234− P.word1 0x20 {- -} BadFormat
235− loOp <- parseOp
236− P.word1 0x20 {- -} BadFormat
237− P.word1 0x76 {-v-} BadFormat
238− P.word1 0x20 {- -} BadFormat
239− hiOp <- parseOp
240− P.word1 0x20 {- -} BadFormat
241− higher <- parseVersion
242− P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
243− if lower < higher
244− then eok (Range lower loOp hiOp higher) state
245− else eerr row col (\_ _ -> InvalidRange lower higher)
246−
247−
248−parseVersion :: P.Parser Error V.Version
249−parseVersion =
250− P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser
251−
252−
253−parseOp :: P.Parser Error Op
254−parseOp =
255− do P.word1 0x3C {-<-} BadFormat
256− P.oneOfWithFallback
257− [ do P.word1 0x3D {-=-} BadFormat
258− return LessOrEqual
259− ]
260− Less
282+ _ -> error "binary encoding of Op was corrupted"
compiler/src/Elm/Docs.hs+158−218
@@ -1,7 +1,8 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE OverloadedStrings #-}
33module Elm.Docs
44 ( Documentation
5+ , toDict
56 , Module(..)
67 , fromModule
78 , Union(..)
@@ -17,35 +18,33 @@ module Elm.Docs
1718 where
1819
1920
20−import qualified Data.Coerce as Coerce
21+import qualified Data.ByteString as B
2122import qualified Data.List as List
2223import Data.Map ((!))
2324import qualified Data.Map as Map
24−import qualified Data.Map.Merge.Strict as Map
2525import qualified Data.Name as Name
26−import qualified Data.NonEmptyList as NE
27−import qualified Data.OneOrMore as OneOrMore
28−import Data.Word (Word8)
29−import Foreign.Ptr (Ptr, plusPtr)
26+import qualified Data.Text as Text
27+import qualified Data.Text.Encoding as Text
3028
3129import qualified AST.Canonical as Can
32−import qualified AST.Source as Src
3330import qualified AST.Utils.Binop as Binop
31+import qualified Data.OneOrMore as OneOrMore
3432import qualified Elm.Compiler.Type as Type
3533import qualified Elm.Compiler.Type.Extract as Extract
3634import qualified Elm.ModuleName as ModuleName
3735import qualified Json.Decode as D
3836import qualified Json.Encode as E
3937import Json.Encode ((==>))
40−import qualified Json.String as Json
41−import Parse.Primitives (Row, Col, word1)
42−import qualified Parse.Primitives as P
43−import qualified Parse.Space as Space
44−import qualified Parse.Symbol as Symbol
45−import qualified Parse.Variable as Var
4638import qualified Reporting.Annotation as A
39+import qualified Reporting.Error as Error
4740import qualified Reporting.Error.Docs as E
41+import qualified Reporting.Region as R
4842import qualified Reporting.Result as Result
43+import Parse.Primitives (Parser)
44+import qualified Parse.Primitives as P
45+import qualified Parse.Primitives.Symbol as Symbol
46+import qualified Parse.Primitives.Variable as Var
47+import qualified Parse.Primitives.Whitespace as W
4948
5049
5150
@@ -56,6 +55,21 @@ type Documentation =
5655 Map.Map Name.Name Module
5756
5857
58+toDict :: [Module] -> Documentation
59+toDict modules =
60+ Map.fromList (map toPair modules)
61+
62+
63+
64+toPair :: Module -> (Name.Name, Module)
65+toPair modul@(Module name _ _ _ _ _) =
66+ (name, modul)
67+
68+
69+
70+-- MODULES
71+
72+
5973data Module =
6074 Module
6175 { _name :: Name.Name
@@ -66,7 +80,9 @@ data Module =
6680 , _binops :: Map.Map Name.Name Binop
6781 }
6882
69−type Comment = Json.String
83+
84+type Comment = Text.Text
85+
7086
7187data Alias = Alias Comment [Name.Name] Type.Type
7288data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -75,19 +91,14 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
7591
7692
7793
78−-- JSON
79−
80−
81−encode :: Documentation -> E.Value
82−encode docs =
83− E.list encodeModule (Map.elems docs)
94+-- JSON ENCODE / DECODE
8495
8596
86−encodeModule :: Module -> E.Value
87−encodeModule (Module name comment unions aliases values binops) =
97+encode :: Module -> E.Value
98+encode (Module name comment unions aliases values binops) =
8899 E.object $
89100 [ "name" ==> ModuleName.encode name
90− , "comment" ==> E.string comment
101+ , "comment" ==> E.text comment
91102 , "unions" ==> E.list encodeUnion (Map.toList unions)
92103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
93104 , "values" ==> E.list encodeValue (Map.toList values)
@@ -96,31 +107,16 @@ encodeModule (Module name comment unions aliases values binops) =
96107
97108
98109data Error
99− = BadAssociativity
100− | BadModuleName
110+ = BadAssociativity Text.Text
111+ | BadName
101112 | BadType
102113
103114
104−decoder :: D.Decoder Error Documentation
115+decoder :: D.Decoder Error Module
105116decoder =
106− toDict <$> D.list moduleDecoder
107−
108−
109−toDict :: [Module] -> Documentation
110−toDict modules =
111− Map.fromList (map toDictHelp modules)
112−
113−
114−toDictHelp :: Module -> (Name.Name, Module)
115−toDictHelp modul@(Module name _ _ _ _ _) =
116− (name, modul)
117−
118−
119−moduleDecoder :: D.Decoder Error Module
120−moduleDecoder =
121117 Module
122− <$> D.field "name" moduleNameDecoder
123− <*> D.field "comment" D.string
118+ <$> D.field "name" nameDecoder
119+ <*> D.field "comment" D.text
124120 <*> D.field "unions" (dictDecoder union)
125121 <*> D.field "aliases" (dictDecoder alias)
126122 <*> D.field "values" (dictDecoder value)
@@ -135,18 +131,13 @@ dictDecoder entryDecoder =
135131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
136132named entryDecoder =
137133 (,)
138− <$> D.field "name" nameDecoder
134+ <$> D.field "name" D.name
139135 <*> entryDecoder
140136
141137
142−nameDecoder :: D.Decoder e Name.Name
138+nameDecoder :: D.Decoder Error Name.Name
143139nameDecoder =
144− fmap Coerce.coerce D.string
145−
146−
147−moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148−moduleNameDecoder =
149− D.mapError (const BadModuleName) ModuleName.decoder
140+ D.mapError (const BadName) ModuleName.decoder
150141
151142
152143typeDecoder :: D.Decoder Error Type.Type
@@ -162,7 +153,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
162153encodeUnion (name, Union comment args cases) =
163154 E.object
164155 [ "name" ==> E.name name
165− , "comment" ==> E.string comment
156+ , "comment" ==> E.text comment
166157 , "args" ==> E.list E.name args
167158 , "cases" ==> E.list encodeCase cases
168159 ]
@@ -171,8 +162,8 @@ encodeUnion (name, Union comment args cases) =
171162union :: D.Decoder Error Union
172163union =
173164 Union
174− <$> D.field "comment" D.string
175− <*> D.field "args" (D.list nameDecoder)
165+ <$> D.field "comment" D.text
166+ <*> D.field "args" (D.list D.name)
176167 <*> D.field "cases" (D.list caseDecoder)
177168
178169
@@ -183,7 +174,7 @@ encodeCase ( tag, args ) =
183174
184175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
185176caseDecoder =
186− D.pair nameDecoder (D.list typeDecoder)
177+ D.pair D.name (D.list typeDecoder)
187178
188179
189180
@@ -194,7 +185,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
194185encodeAlias ( name, Alias comment args tipe) =
195186 E.object
196187 [ "name" ==> E.name name
197− , "comment" ==> E.string comment
188+ , "comment" ==> E.text comment
198189 , "args" ==> E.list E.name args
199190 , "type" ==> Type.encode tipe
200191 ]
@@ -203,8 +194,8 @@ encodeAlias ( name, Alias comment args tipe) =
203194alias :: D.Decoder Error Alias
204195alias =
205196 Alias
206− <$> D.field "comment" D.string
207− <*> D.field "args" (D.list nameDecoder)
197+ <$> D.field "comment" D.text
198+ <*> D.field "args" (D.list D.name)
208199 <*> D.field "type" typeDecoder
209200
210201
@@ -216,7 +207,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
216207encodeValue (name, Value comment tipe) =
217208 E.object
218209 [ "name" ==> E.name name
219− , "comment" ==> E.string comment
210+ , "comment" ==> E.text comment
220211 , "type" ==> Type.encode tipe
221212 ]
222213
@@ -224,7 +215,7 @@ encodeValue (name, Value comment tipe) =
224215value :: D.Decoder Error Value
225216value =
226217 Value
227− <$> D.field "comment" D.string
218+ <$> D.field "comment" D.text
228219 <*> D.field "type" typeDecoder
229220
230221
@@ -236,7 +227,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
236227encodeBinop (name, Binop comment tipe assoc prec) =
237228 E.object
238229 [ "name" ==> E.name name
239− , "comment" ==> E.string comment
230+ , "comment" ==> E.text comment
240231 , "type" ==> Type.encode tipe
241232 , "associativity" ==> encodeAssoc assoc
242233 , "precedence" ==> encodePrec prec
@@ -246,7 +237,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
246237binop :: D.Decoder Error Binop
247238binop =
248239 Binop
249− <$> D.field "comment" D.string
240+ <$> D.field "comment" D.text
250241 <*> D.field "type" typeDecoder
251242 <*> D.field "associativity" assocDecoder
252243 <*> D.field "precedence" precDecoder
@@ -259,23 +250,19 @@ binop =
259250encodeAssoc :: Binop.Associativity -> E.Value
260251encodeAssoc assoc =
261252 case assoc of
262− Binop.Left -> E.chars "left"
263− Binop.Non -> E.chars "non"
264− Binop.Right -> E.chars "right"
253+ Binop.Left -> E.text "left"
254+ Binop.Non -> E.text "non"
255+ Binop.Right -> E.text "right"
265256
266257
267258assocDecoder :: D.Decoder Error Binop.Associativity
268259assocDecoder =
269− let
270− left = Json.fromChars "left"
271− non = Json.fromChars "non"
272− right = Json.fromChars "right"
273− in
274− do str <- D.string
275− if | str == left -> return Binop.Left
276− | str == non -> return Binop.Non
277− | str == right -> return Binop.Right
278− | otherwise -> D.failure BadAssociativity
260+ do txt <- D.text
261+ case txt of
262+ "left" -> D.succeed Binop.Left
263+ "non" -> D.succeed Binop.Non
264+ "right" -> D.succeed Binop.Right
265+ _ -> D.fail (BadAssociativity txt)
279266
280267
281268
@@ -296,190 +283,142 @@ precDecoder =
296283-- FROM MODULE
297284
298285
299−fromModule :: Can.Module -> Either E.Error Module
300−fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
286+fromModule :: Can.Module -> Result.Result i w Error.Error Module
287+fromModule (Can.Module name docs exports decls unions aliases binops effects) =
301288 case exports of
302289 Can.ExportEverything region ->
303− Left (E.ImplicitExposing region)
290+ Result.throw $ Error.Docs $ E.ImplicitExposing region
304291
305292 Can.Export exportDict ->
306293 case docs of
307− Src.NoDocs region ->
308− Left (E.NoDocs region)
294+ Can.NoDocs region ->
295+ Result.throw $ Error.Docs $ E.NoDocs region
309296
310− Src.YesDocs overview comments ->
311− do names <- parseOverview overview
312− checkNames exportDict names
313− checkDefs exportDict overview (Map.fromList comments) modul
297+ Can.YesDocs region overview comments ->
298+ do names <- parseOverview region overview
299+ Result.mapError Error.Docs $
300+ do checkNames exportDict names
301+ let types = gatherTypes decls Map.empty
302+ let info = Info comments types unions aliases binops effects
303+ inserters <- Map.traverseWithKey (checkExport info) exportDict
304+ return $ foldr ($) (emptyModule name overview) inserters
305+
306+
307+emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
308+emptyModule (ModuleName.Canonical _ name) overview =
309+ Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
314310
315311
316312
317313-- PARSE OVERVIEW
318314
319315
320−parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
321−parseOverview (Src.Comment snippet) =
322− case P.fromSnippet (chompOverview []) E.BadEnd snippet of
316+parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
317+parseOverview (R.Region (R.Position row col) _) overview =
318+ case P.runAt row (col + 3) (chompOverview []) overview of
323319 Left err ->
324− Left (E.SyntaxProblem err)
320+ Result.throw (Error.Syntax err)
325321
326322 Right names ->
327− Right names
328−
329−
330−type Parser a =
331− P.Parser E.SyntaxProblem a
323+ Result.ok names
332324
333325
334326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335327chompOverview names =
336− do isDocs <- chompUntilDocs
328+ do isDocs <- W.chompUntilDocs
337329 if isDocs
338− then
339− do Space.chomp E.Space
340− chompOverview =<< chompDocs names
341− else
342− return names
330+ then chompOverviewHelp names
331+ else return names
332+
333+
334+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335+chompOverviewHelp names =
336+ do pos <- P.getPosition
337+ (W.SPos spos) <- W.whitespace
338+ if pos == spos
339+ then chompOverview names
340+ else chompOverview =<< chompDocs names
343341
344342
345343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
346344chompDocs names =
347− do name <-
348− P.addLocation $
349− P.oneOf E.Name
350− [ Var.lower E.Name
351− , Var.upper E.Name
352− , chompOperator
353− ]
354−
355− Space.chomp E.Space
356−
357− P.oneOfWithFallback
358− [ do pos <- P.getPosition
359− Space.checkIndent pos E.Comma
360− word1 0x2C {-,-} E.Comma
361− Space.chomp E.Space
345+ do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
346+ spos <- W.whitespace
347+ P.oneOf
348+ [ do P.checkSpace spos
349+ Symbol.comma
350+ P.spaces
362351 chompDocs (name:names)
352+ , return (name:names)
363353 ]
364− (name:names)
365−
366−
367−chompOperator :: Parser Name.Name
368−chompOperator =
369− do word1 0x28 {-(-} E.Op
370− op <- Symbol.operator E.Op E.OpBad
371− word1 0x29 {-)-} E.Op
372− return op
373−
374−
375−-- TODO add rule that @docs must be after newline in 0.20
376−--
377−chompUntilDocs :: Parser Bool
378−chompUntilDocs =
379− P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
380− let
381− (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col
382− !newState = P.State src newPos end indent newRow newCol
383− in
384− cok isDocs newState
385−
386−
387−untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)
388−untilDocs pos end row col =
389− if pos >= end then
390− (# False, pos, row, col #)
391− else
392− let !word = P.unsafeIndex pos in
393− if word == 0x0A {-\n-} then
394− untilDocs (plusPtr pos 1) end (row + 1) 1
395− else
396− let !pos5 = plusPtr pos 5 in
397− if pos5 <= end
398− && P.unsafeIndex ( pos ) == 0x40 {-@-}
399− && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}
400− && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}
401− && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}
402− && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}
403− && Var.getInnerWidth pos5 end == 0
404− then
405− (# True, pos5, row, col + 5 #)
406− else
407− let !newPos = plusPtr pos (P.getCharWidth word) in
408− untilDocs newPos end row (col + 1)
354+
355+
356+chompBinop :: Parser Name.Name
357+chompBinop =
358+ do Symbol.leftParen
359+ name <- Symbol.binop
360+ Symbol.rightParen
361+ return name
409362
410363
411364
412365-- CHECK NAMES
413366
414367
415−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
416−checkNames exports names =
417− let
418− docs = List.foldl' addName Map.empty names
419− loneDoc = Map.traverseMissing onlyInDocs
420− loneExport = Map.traverseMissing onlyInExports
421− checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)
422− in
423− case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of
424− (_, Right _) -> Right ()
425− (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))
368+type Result i w a =
369+ Result.Result i w E.Error a
370+
371+
372+type Dups =
373+ Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
426374
427375
428−type DocNameRegions =
429− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
376+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
377+checkNames exports names =
378+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
379+ let overlap = Map.size (Map.intersection docs exports)
380+ if Map.size exports == overlap && overlap == Map.size docs
381+ then Result.ok ()
382+ else
383+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
385+ Result.ok ()
430386
431387
432−addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
388+addName :: Dups -> A.Located Name.Name -> Dups
433389addName dict (A.At region name) =
434390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
435391
436392
437−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
393+isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
438394isUnique name regions =
439395 case regions of
440396 OneOrMore.One region ->
441397 Result.ok region
442398
443− OneOrMore.More left right ->
444− let (r1, r2) = OneOrMore.getFirstTwo left right in
445− Result.throw (E.NameDuplicate name r1 r2)
399+ OneOrMore.More _ _ ->
400+ let (r1:r2:_) = OneOrMore.toList regions in
401+ Result.throw (E.Duplicate name r1 r2)
446402
447403
448−onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
449−onlyInDocs name regions =
450− do region <- isUnique name regions
451− Result.throw $ E.NameOnlyInDocs name region
404+onlyInDocs :: Name.Name -> R.Region -> Result i w a
405+onlyInDocs name region =
406+ Result.throw $ E.OnlyInDocs name region
452407
453408
454−onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
409+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
455410onlyInExports name (A.At region _) =
456− Result.throw $ E.NameOnlyInExports name region
457−
458−
459−
460−-- CHECK DEFS
461−
411+ Result.throw $ E.OnlyInExports name region
462412
463−checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module
464−checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =
465− let
466− types = gatherTypes decls Map.empty
467− info = Info comments types unions aliases infixes effects
468− in
469− case Result.run (Map.traverseWithKey (checkExport info) exportDict) of
470− (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)
471− (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters
472413
473414
474−emptyModule :: ModuleName.Canonical -> Src.Comment -> Module
475−emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =
476− Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty
415+-- CHECK EXPORTS
477416
478417
479418data Info =
480419 Info
481− { _iComments :: Map.Map Name.Name Src.Comment
482− , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
420+ { _iComments :: Map.Map Name.Name Comment
421+ , _iValues :: Types
483422 , _iUnions :: Map.Map Name.Name Can.Union
484423 , _iAliases :: Map.Map Name.Name Can.Alias
485424 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -487,7 +426,7 @@ data Info =
487426 }
488427
489428
490−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
429+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
491430checkExport info name (A.At region export) =
492431 case export of
493432 Can.ExportValue ->
@@ -528,23 +467,23 @@ checkExport info name (A.At region export) =
528467 m { _values = Map.insert name (Value comment tipe) (_values m) }
529468
530469
531−getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
470+getComment :: R.Region -> Name.Name -> Info -> Result i w Comment
532471getComment region name info =
533472 case Map.lookup name (_iComments info) of
534473 Nothing ->
535474 Result.throw (E.NoComment name region)
536475
537− Just (Src.Comment snippet) ->
538− Result.ok (Json.fromComment snippet)
476+ Just comment ->
477+ Result.ok comment
539478
540479
541−getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
480+getType :: Name.Name -> Info -> Result i w Type.Type
542481getType name info =
543482 case _iValues info ! name of
544− Left region ->
545− Result.throw (E.NoAnnotation name region)
483+ A.At defRegion Nothing ->
484+ Result.throw (E.NoAnnotation name defRegion)
546485
547− Right tipe ->
486+ A.At _ (Just tipe) ->
548487 Result.ok (Extract.fromType tipe)
549488
550489
@@ -558,7 +497,7 @@ dector (Can.Ctor name _ _ args) =
558497
559498
560499type Types =
561− Map.Map Name.Name (Either A.Region Can.Type)
500+ Map.Map Name.Name (A.Located (Maybe Can.Type))
562501
563502
564503gatherTypes :: Can.Decls -> Types -> Types
@@ -567,8 +506,8 @@ gatherTypes decls types =
567506 Can.Declare def subDecls ->
568507 gatherTypes subDecls (addDef types def)
569508
570− Can.DeclareRec def defs subDecls ->
571− gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
509+ Can.DeclareRec defs subDecls ->
510+ gatherTypes subDecls (List.foldl' addDef types defs)
572511
573512 Can.SaveTheEnvironment ->
574513 types
@@ -578,10 +517,11 @@ addDef :: Types -> Can.Def -> Types
578517addDef types def =
579518 case def of
580519 Can.Def (A.At region name) _ _ ->
581− Map.insert name (Left region) types
520+ Map.insert name (A.At region Nothing) types
582521
583− Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
522+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
584523 let
585− tipe = foldr Can.TLambda resultType (map snd typedArgs)
524+ tipe =
525+ foldr Can.TLambda resultType (map snd typedArgs)
586526 in
587− Map.insert name (Right tipe) types
527+ Map.insert name (A.At region (Just tipe)) types
compiler/src/Elm/Float.hsdeleted−51
@@ -1,51 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}
3−module Elm.Float
4− ( Float
5− , fromPtr
6− , toBuilder
7− )
8− where
9−
10−
11−import Prelude hiding (Float)
12−import Data.Binary (Binary, get, put)
13−import qualified Data.ByteString.Builder as B
14−import qualified Data.Utf8 as Utf8
15−import Data.Word (Word8)
16−import Foreign.Ptr (Ptr)
17−
18−
19−
20−-- FLOATS
21−
22−
23−type Float =
24− Utf8.Utf8 ELM_FLOAT
25−
26−
27−data ELM_FLOAT
28−
29−
30−
31−-- HELPERS
32−
33−
34−fromPtr :: Ptr Word8 -> Ptr Word8 -> Float
35−fromPtr =
36− Utf8.fromPtr
37−
38−
39−{-# INLINE toBuilder #-}
40−toBuilder :: Float -> B.Builder
41−toBuilder =
42− Utf8.toBuilder
43−
44−
45−
46−-- BINARY
47−
48−
49−instance Binary (Utf8.Utf8 ELM_FLOAT) where
50− get = Utf8.getUnder256
51− put = Utf8.putUnder256
compiler/src/Elm/Interface.hs+14−17
@@ -11,13 +11,11 @@ module Elm.Interface
1111 , public
1212 , private
1313 , privatize
14− , extractUnion
15− , extractAlias
1614 )
1715 where
1816
1917
20−import Control.Monad (liftM, liftM3, liftM4, liftM5)
18+import Control.Monad (liftM, liftM2, liftM4, liftM5)
2119import Data.Binary
2220import Data.Map.Strict ((!))
2321import qualified Data.Map.Strict as Map
@@ -73,7 +71,7 @@ data Binop =
7371
7472
7573fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
76−fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =
74+fromModule home (Can.Module _ exports _ unions aliases binops _) annotations =
7775 Interface
7876 { _home = home
7977 , _values = restrict exports annotations
@@ -155,10 +153,7 @@ toPublicAlias iAlias =
155153
156154data DependencyInterface
157155 = Public Interface
158− | Private
159− Pkg.Name
160− (Map.Map Name.Name Can.Union)
161− (Map.Map Name.Name Can.Alias)
156+ | Private (Map.Map Name.Name Can.Union) (Map.Map Name.Name Can.Alias)
162157
163158
164159public :: Interface -> DependencyInterface
@@ -167,8 +162,10 @@ public =
167162
168163
169164private :: Interface -> DependencyInterface
170−private (Interface pkg _ unions aliases _) =
171− Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases)
165+private (Interface _ _ unions aliases _) =
166+ Private
167+ (Map.map extractUnion unions)
168+ (Map.map extractAlias aliases)
172169
173170
174171extractUnion :: Union -> Can.Union
@@ -190,7 +187,7 @@ privatize :: DependencyInterface -> DependencyInterface
190187privatize di =
191188 case di of
192189 Public i -> private i
193− Private _ _ _ -> di
190+ Private _ _ -> di
194191
195192
196193
@@ -215,7 +212,7 @@ instance Binary Union where
215212 0 -> liftM OpenUnion get
216213 1 -> liftM ClosedUnion get
217214 2 -> liftM PrivateUnion get
218− _ -> fail "binary encoding of Union was corrupted"
215+ _ -> error "binary encoding of Union was corrupted"
219216
220217
221218instance Binary Alias where
@@ -229,7 +226,7 @@ instance Binary Alias where
229226 case n of
230227 0 -> liftM PublicAlias get
231228 1 -> liftM PrivateAlias get
232− _ -> fail "binary encoding of Alias was corrupted"
229+ _ -> error "binary encoding of Alias was corrupted"
233230
234231
235232instance Binary Binop where
@@ -243,12 +240,12 @@ instance Binary Binop where
243240instance Binary DependencyInterface where
244241 put union =
245242 case union of
246− Public a -> putWord8 0 >> put a
247− Private a b c -> putWord8 1 >> put a >> put b >> put c
243+ Public a -> putWord8 0 >> put a
244+ Private a b -> putWord8 1 >> put a >> put b
248245
249246 get =
250247 do n <- getWord8
251248 case n of
252249 0 -> liftM Public get
253− 1 -> liftM3 Private get get get
254− _ -> fail "binary encoding of DependencyInterface was corrupted"
250+ 1 -> liftM2 Private get get
251+ _ -> error "binary encoding of DependencyInterface was corrupted"
compiler/src/Elm/Kernel.hs+127−132
@@ -3,40 +3,55 @@
33module Elm.Kernel
44 ( Content(..)
55 , Chunk(..)
6− , fromByteString
7− , countFields
6+ , Dep(..)
7+ , parser
88 )
99 where
1010
1111
1212import Control.Monad (liftM, liftM2)
1313import Data.Binary (Binary, get, put, getWord8, putWord8)
14−import qualified Data.ByteString.Internal as B
14+import Data.Coerce (coerce)
1515import qualified Data.List as List
1616import qualified Data.Map as Map
1717import qualified Data.Name as Name
18−import Data.Word (Word8)
19−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20−import Foreign.ForeignPtr (ForeignPtr)
21−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
18+import qualified Data.Set as Set
19+import qualified Data.Utf8 as Utf8
20+import Data.Word (Word8, Word16)
21+import Foreign.Ptr (Ptr, plusPtr)
2222
2323import qualified AST.Source as Src
2424import qualified Elm.ModuleName as ModuleName
2525import qualified Elm.Package as Pkg
2626import qualified Parse.Module as Module
27−import qualified Parse.Space as Space
2827import qualified Parse.Variable as Var
29−import Parse.Primitives hiding (fromByteString)
28+import Parse.Utils
29+import Parse.Primitives hiding (Parser, State)
3030import qualified Parse.Primitives as P
3131import qualified Reporting.Annotation as A
32+import qualified Reporting.Error.Syntax as E
3233
3334
3435
35−-- CHUNK
36+-- CONTENT
37+
38+
39+data Content =
40+ Content [Chunk] (Set.Set Dep)
41+
42+
43+data Dep
44+ = ElmDep ModuleName.Canonical Name.Name
45+ | KernelDep Name.Name
46+ deriving (Eq, Ord)
47+
48+
49+
50+-- CHUNKS
3651
3752
3853data Chunk
39− = JS B.ByteString
54+ = JS (Utf8.VeryLong UNCHECKED)
4055 | ElmVar ModuleName.Canonical Name.Name
4156 | JsVar Name.Name Name.Name
4257 | ElmField Name.Name
@@ -46,93 +61,56 @@ data Chunk
4661 | Prod
4762
4863
64+data UNCHECKED
4965
50−-- COUNT FIELDS
51−
52−
53−countFields :: [Chunk] -> Map.Map Name.Name Int
54−countFields chunks =
55− foldr addField Map.empty chunks
5666
5767
58−addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int
59−addField chunk fields =
60− case chunk of
61− JS _ -> fields
62− ElmVar _ _ -> fields
63− JsVar _ _ -> fields
64− ElmField f -> Map.insertWith (+) f 1 fields
65− JsField _ -> fields
66− JsEnum _ -> fields
67− Debug -> fields
68− Prod -> fields
68+-- PARSE
6969
7070
71+type ImportDict =
72+ Map.Map Name.Name [Pkg.Name]
7173
72−-- FROM FILE
73−
74−
75−data Content =
76− Content [Src.Import] [Chunk]
7774
78−
79−type Foreigns =
80− Map.Map ModuleName.Raw Pkg.Name
81−
82−
83−fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content
84−fromByteString pkg foreigns bytes =
85− case P.fromByteString (parser pkg foreigns) toError bytes of
86− Right content ->
87− Just content
88−
89− Left () ->
90− Nothing
91−
92−
93−parser :: Pkg.Name -> Foreigns -> Parser () Content
94−parser pkg foreigns =
95− do word2 0x2F 0x2A {-/*-} toError
96− Space.chomp ignoreError
97− Space.checkFreshLine toError
98− imports <- specialize ignoreError (Module.chompImports [])
99− word2 0x2A 0x2F {-*/-} toError
100− chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty
101− return (Content imports chunks)
102−
103−
104−toError :: Row -> Col -> ()
105−toError _ _ =
106− ()
107−
108−
109−ignoreError :: a -> Row -> Col -> ()
110−ignoreError _ _ _ =
111− ()
75+parser :: ImportDict -> Parser Content
76+parser importDict =
77+ do word2 0x2F 0x2A {-/*-} E.XXX
78+ Module.freshLine
79+ imports <- Module.chompImports []
80+ word2 0x2A 0x2F {-*/-} E.XXX
81+ let (vtable, deps) = processImports importDict imports
82+ chunks <- parseChunks vtable Map.empty Map.empty
83+ return $ Content chunks deps
11284
11385
11486
11587-- PARSE CHUNKS
11688
11789
118−parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
90+parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]
11991parseChunks vtable enums fields =
120− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
92+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr _ ->
12193 let
12294 (# chunks, newPos, newRow, newCol #) =
123− chompChunks vtable enums fields src pos end row col pos []
95+ chompChunks vtable enums fields pos end row col pos []
12496 in
12597 if newPos == end then
126− cok chunks (P.State src newPos end indent newRow newCol)
98+ cok chunks (P.State newPos end indent newRow newCol ctx)
12799 else
128− cerr row col toError
100+ cerr row col ctx E.XXX
101+
102+
103+addJS :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
104+addJS start end revChunks =
105+ if start == end
106+ then revChunks
107+ else JS (Utf8.fromPtr start end) : revChunks
129108
130109
131−chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
132−chompChunks vs es fs src pos end row col lastPos revChunks =
110+chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
111+chompChunks vs es fs pos end row col lastPos revChunks =
133112 if pos >= end then
134− let !js = toByteString src lastPos end in
135− (# reverse (JS js : revChunks), pos, row, col #)
113+ (# reverse (addJS lastPos end revChunks), pos, row, col #)
136114
137115 else
138116 let !word = unsafeIndex pos in
@@ -142,45 +120,31 @@ chompChunks vs es fs src pos end row col lastPos revChunks =
142120 !pos3 = plusPtr pos 3
143121 in
144122 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
145− let !js = toByteString src lastPos pos in
146− chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)
123+ chompTag vs es fs pos3 end row (col + 3) (addJS lastPos pos revChunks)
147124 else
148− chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks
125+ chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks
149126
150127 else if word == 0x0A {-\n-} then
151− chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
128+ chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
152129
153130 else
154131 let
155− !newPos = plusPtr pos (getCharWidth word)
132+ !newPos = plusPtr pos (getCharWidth pos end word)
156133 in
157− chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
158−
159−
160−toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString
161−toByteString src pos end =
162− let
163− !off = minusPtr pos (unsafeForeignPtrToPtr src)
164− !len = minusPtr end pos
165− in
166− B.PS src off len
167−
134+ chompChunks vs es fs newPos end row (col + 1) lastPos revChunks
168135
169136
170137-- relies on external checks in chompChunks
171−chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
172−chompTag vs es fs src pos end row col revChunks =
138+chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
139+chompTag vs es fs pos end row col revChunks =
173140 let
174141 (# newPos, newCol #) = Var.chompInnerChars pos end col
175142 !tagPos = plusPtr pos (-1)
176143 !word = unsafeIndex tagPos
177144 in
178145 if word == 0x24 {-$-} then
179− let
180− !name = Name.fromPtr pos newPos
181− in
182− chompChunks vs es fs src newPos end row newCol newPos $
183− ElmField name : revChunks
146+ chompChunks vs es fs newPos end row newCol newPos $
147+ ElmField (Name.fromPtr pos newPos) : revChunks
184148 else
185149 let
186150 !name = Name.fromPtr tagPos newPos
@@ -190,7 +154,7 @@ chompTag vs es fs src pos end row col revChunks =
190154 (enum, newEnums) =
191155 lookupEnum (word - 0x30) name es
192156 in
193− chompChunks vs newEnums fs src newPos end row newCol newPos $
157+ chompChunks vs newEnums fs newPos end row newCol newPos $
194158 JsEnum enum : revChunks
195159
196160 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
@@ -198,19 +162,19 @@ chompTag vs es fs src pos end row col revChunks =
198162 (field, newFields) =
199163 lookupField name fs
200164 in
201− chompChunks vs es newFields src newPos end row newCol newPos $
165+ chompChunks vs es newFields newPos end row newCol newPos $
202166 JsField field : revChunks
203167
204168 else if name == "DEBUG" then
205− chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)
169+ chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)
206170
207171 else if name == "PROD" then
208− chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)
172+ chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)
209173
210174 else
211175 case Map.lookup name vs of
212176 Just chunk ->
213− chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)
177+ chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)
214178
215179 Nothing ->
216180 (# revChunks, pos, row, col #)
@@ -266,34 +230,60 @@ type VarTable =
266230 Map.Map Name.Name Chunk
267231
268232
269−toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable
270−toVarTable pkg foreigns imports =
271− List.foldl' (addImport pkg foreigns) Map.empty imports
233+type State =
234+ (VarTable, Set.Set Dep)
272235
273236
274−addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable
275−addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) =
276− if Name.isKernel importName then
237+processImports :: ImportDict -> [Src.Import] -> State
238+processImports importDict imports =
239+ List.foldl' (addImport importDict) (Map.empty, Set.empty) imports
240+
241+
242+addImport :: ImportDict -> State -> Src.Import -> State
243+addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
244+ if Name.isKernel home then
277245 case maybeAlias of
278246 Just _ ->
279− error ("cannot use `as` with kernel import of: " ++ Name.toChars importName)
247+ error ("Cannot use aliases on kernel import of: " ++ Name.toChars home)
280248
281249 Nothing ->
250+ addKernelImport (Name.getKernel home) exposing state
251+
252+ else
253+ case Map.lookup home importDict of
254+ Just [pkg] ->
282255 let
283− home = Name.getKernel importName
284− add table name =
285− Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table
256+ canonicalHome = ModuleName.Canonical pkg home
257+ prefix = toPrefix home maybeAlias
286258 in
287− List.foldl' add vtable (toNames exposing)
259+ addNormalImport canonicalHome prefix exposing state
288260
289− else
290− let
291− home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName
292− prefix = toPrefix importName maybeAlias
293− add table name =
294− Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table
295− in
296− List.foldl' add vtable (toNames exposing)
261+ _ ->
262+ error ("Cannot find kernel import of: " ++ Name.toChars home)
263+
264+
265+-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
266+--
267+addKernelImport :: Name.Name -> Src.Exposing -> State -> State
268+addKernelImport home exposing (vtable, deps) =
269+ let
270+ addVar table name =
271+ Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table
272+ in
273+ ( List.foldl' addVar vtable (toNames exposing)
274+ , Set.insert (KernelDep home) deps
275+ )
276+
277+
278+addNormalImport :: ModuleName.Canonical -> Name.Name -> Src.Exposing -> State -> State
279+addNormalImport home prefix exposing state =
280+ let
281+ addVar (vtable, deps) name =
282+ ( Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) vtable
283+ , Set.insert (ElmDep home name) deps
284+ )
285+ in
286+ List.foldl' addVar state (toNames exposing)
297287
298288
299289toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name
@@ -313,25 +303,25 @@ toNames :: Src.Exposing -> [Name.Name]
313303toNames exposing =
314304 case exposing of
315305 Src.Open ->
316− error "cannot have `exposing (..)` in kernel code."
306+ error "Cannot have `exposing (..)` in kernel code."
317307
318308 Src.Explicit exposedList ->
319309 map toName exposedList
320310
321311
322−toName :: Src.Exposed -> Name.Name
323−toName exposed =
312+toName :: A.Located Src.Exposed -> Name.Name
313+toName (A.At _ exposed) =
324314 case exposed of
325− Src.Lower (A.At _ name) ->
315+ Src.Lower name ->
326316 name
327317
328− Src.Upper (A.At _ name) Src.Private ->
318+ Src.Upper name Src.Private ->
329319 name
330320
331− Src.Upper _ (Src.Public _) ->
321+ Src.Upper _ Src.Public ->
332322 error "cannot have Maybe(..) syntax in kernel code header"
333323
334− Src.Operator _ _ ->
324+ Src.Operator _ ->
335325 error "cannot use binops in kernel code"
336326
337327
@@ -342,7 +332,7 @@ toName exposed =
342332instance Binary Chunk where
343333 put chunk =
344334 case chunk of
345− JS a -> putWord8 0 >> put a
335+ JS a -> putWord8 0 >> put (coerce a :: Utf8.String)
346336 ElmVar a b -> putWord8 1 >> put a >> put b
347337 JsVar a b -> putWord8 2 >> put a >> put b
348338 ElmField a -> putWord8 3 >> put a
@@ -354,7 +344,7 @@ instance Binary Chunk where
354344 get =
355345 do word <- getWord8
356346 case word of
357− 0 -> liftM JS get
347+ 0 -> liftM toJS get
358348 1 -> liftM2 ElmVar get get
359349 2 -> liftM2 JsVar get get
360350 3 -> liftM ElmField get
@@ -363,3 +353,8 @@ instance Binary Chunk where
363353 6 -> return Debug
364354 7 -> return Prod
365355 _ -> error "problem deserializing Elm.Kernel.Chunk"
356+
357+
358+toJS :: Utf8.String -> Chunk
359+toJS str =
360+ JS (coerce str)
compiler/src/Elm/Licenses.hs+65−48
@@ -9,12 +9,14 @@ module Elm.Licenses
99 where
1010
1111
12+import Control.Monad (liftM2)
13+import Data.Binary (Binary, get, put)
14+import Data.Map ((!))
1215import qualified Data.Map as Map
1316import qualified Data.Utf8 as Utf8
1417
1518import qualified Json.Decode as D
1619import qualified Json.Encode as E
17−import qualified Json.String as Json
1820import qualified Reporting.Suggest as Suggest
1921
2022
@@ -22,21 +24,25 @@ import qualified Reporting.Suggest as Suggest
2224-- LICENCES
2325
2426
25−newtype License =
26− License Json.String
27+data License =
28+ License
29+ { _name :: Utf8.String
30+ , _code :: Utf8.String
31+ }
32+ deriving (Eq, Ord)
2733
2834
2935bsd3 :: License
3036bsd3 =
31− License (Json.fromChars "BSD-3-Clause")
37+ osiApprovedSpdxLicenses ! "BSD-3-Clause"
3238
3339
3440encode :: License -> E.Value
35−encode (License code) =
41+encode (License _ code) =
3642 E.string code
3743
3844
39−decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License
45+decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License
4046decoder toError =
4147 do str <- D.string
4248 case check str of
@@ -51,93 +57,97 @@ decoder toError =
5157-- CHECK
5258
5359
54−check :: Json.String -> Either [Json.String] License
55−check givenCode =
56− if Map.member givenCode osiApprovedSpdxLicenses then
57− Right (License givenCode)
60+check :: Utf8.String -> Either [Utf8.String] License
61+check rawName =
62+ case Map.lookup rawName osiApprovedSpdxLicenses of
63+ Just license ->
64+ Right license
5865
59− else
60− let
61− pairs =
62− map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)
63− ++
64− Map.toList osiApprovedSpdxLicenses
65− in
66− Left $ map fst $ take 4 $
67− Suggest.sort (Utf8.toChars givenCode) snd pairs
66+ Nothing ->
67+ let
68+ toPairs (License name code) =
69+ [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]
70+
71+ pairs =
72+ concatMap toPairs (Map.elems osiApprovedSpdxLicenses)
73+ in
74+ Left $ map snd $
75+ Suggest.sort (Utf8.toChars rawName) fst pairs
6876
6977
7078
7179-- LIST OF LICENCES
7280
7381
74−(==>) :: [Char] -> [Char] -> (Json.String, [Char])
75−(==>) code fullName =
76− ( Json.fromChars code, fullName )
82+(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)
83+(==>) code name =
84+ ( code, License name code )
7785
7886
7987--
8088-- OSI approved licenses in SPDX format.
8189-- <https://spdx.org/licenses/>
8290--
83−osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
91+osiApprovedSpdxLicenses :: Map.Map Utf8.String License
8492osiApprovedSpdxLicenses =
8593 Map.fromList
86− [ "0BSD" ==> "BSD Zero Clause License"
87− , "AAL" ==> "Attribution Assurance License"
88− , "AFL-1.1" ==> "Academic Free License v1.1"
94+ [ "AFL-1.1" ==> "Academic Free License v1.1"
8995 , "AFL-1.2" ==> "Academic Free License v1.2"
9096 , "AFL-2.0" ==> "Academic Free License v2.0"
9197 , "AFL-2.1" ==> "Academic Free License v2.1"
9298 , "AFL-3.0" ==> "Academic Free License v3.0"
93− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
99+ , "APL-1.0" ==> "Adaptive Public License 1.0"
94100 , "Apache-1.1" ==> "Apache License 1.1"
95101 , "Apache-2.0" ==> "Apache License 2.0"
96− , "APL-1.0" ==> "Adaptive Public License 1.0"
97102 , "APSL-1.0" ==> "Apple Public Source License 1.0"
98103 , "APSL-1.1" ==> "Apple Public Source License 1.1"
99104 , "APSL-1.2" ==> "Apple Public Source License 1.2"
100105 , "APSL-2.0" ==> "Apple Public Source License 2.0"
101106 , "Artistic-1.0" ==> "Artistic License 1.0"
102− , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
103107 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
108+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
104109 , "Artistic-2.0" ==> "Artistic License 2.0"
110+ , "AAL" ==> "Attribution Assurance License"
111+ , "BSL-1.0" ==> "Boost Software License 1.0"
105112 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
106113 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
107− , "BSL-1.0" ==> "Boost Software License 1.0"
108− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
114+ , "0BSD" ==> "BSD Zero Clause License"
110115 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
111116 , "CNRI-Python" ==> "CNRI Python License"
117+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
112118 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
113119 , "CPL-1.0" ==> "Common Public License 1.0"
120+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
114121 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
122+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
115123 , "ECL-1.0" ==> "Educational Community License v1.0"
116124 , "ECL-2.0" ==> "Educational Community License v2.0"
117125 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
118126 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
119127 , "Entessa" ==> "Entessa Public License v1.0"
120− , "EPL-1.0" ==> "Eclipse Public License 1.0"
121128 , "EUDatagrid" ==> "EU DataGrid Software License"
122129 , "EUPL-1.1" ==> "European Union Public License 1.1"
123130 , "Fair" ==> "Fair License"
124131 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
132+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
125133 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
126134 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
135+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
136+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
137+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
127138 , "HPND" ==> "Historic Permission Notice and Disclaimer"
139+ , "IPL-1.0" ==> "IBM Public License v1.0"
128140 , "Intel" ==> "Intel Open Source License"
129141 , "IPA" ==> "IPA Font License"
130− , "IPL-1.0" ==> "IBM Public License v1.0"
131142 , "ISC" ==> "ISC License"
132− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
133− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
143+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
135144 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
136− , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
137145 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
138− , "LPL-1.0" ==> "Lucent Public License Version 1.0"
146+ , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
139147 , "LPL-1.02" ==> "Lucent Public License v1.02"
140− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
148+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"
149+ , "MS-PL" ==> "Microsoft Public License"
150+ , "MS-RL" ==> "Microsoft Reciprocal License"
141151 , "MirOS" ==> "MirOS Licence"
142152 , "MIT" ==> "MIT License"
143153 , "Motosoto" ==> "Motosoto License"
@@ -145,41 +155,48 @@ osiApprovedSpdxLicenses =
145155 , "MPL-1.1" ==> "Mozilla Public License 1.1"
146156 , "MPL-2.0" ==> "Mozilla Public License 2.0"
147157 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
148− , "MS-PL" ==> "Microsoft Public License"
149− , "MS-RL" ==> "Microsoft Reciprocal License"
150158 , "Multics" ==> "Multics License"
151159 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
152160 , "Naumen" ==> "Naumen Public License"
153− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
154161 , "NGPL" ==> "Nethack General Public License"
155162 , "Nokia" ==> "Nokia Open Source License"
156163 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
157164 , "NTP" ==> "NTP License"
158165 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159− , "OFL-1.1" ==> "SIL Open Font License 1.1"
160166 , "OGTSL" ==> "Open Group Test Suite License"
161− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
162167 , "OSL-1.0" ==> "Open Software License 1.0"
163168 , "OSL-2.0" ==> "Open Software License 2.0"
164169 , "OSL-2.1" ==> "Open Software License 2.1"
165170 , "OSL-3.0" ==> "Open Software License 3.0"
171+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
166172 , "PHP-3.0" ==> "PHP License v3.0"
167173 , "PostgreSQL" ==> "PostgreSQL License"
168174 , "Python-2.0" ==> "Python License 2.0"
169175 , "QPL-1.0" ==> "Q Public License 1.0"
176+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
170177 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
171178 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
173179 , "RSCPL" ==> "Ricoh Source Code Public License"
180+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
174181 , "SimPL-2.0" ==> "Simple Public License 2.0"
175− , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176182 , "Sleepycat" ==> "Sleepycat License"
183+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"
177184 , "SPL-1.0" ==> "Sun Public License v1.0"
185+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
178186 , "UPL-1.0" ==> "Universal Permissive License v1.0"
187+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
179188 , "VSL-1.0" ==> "Vovida Software License v1.0"
180189 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
182190 , "Xnet" ==> "X.Net License"
183191 , "Zlib" ==> "zlib License"
184192 , "ZPL-2.0" ==> "Zope Public License 2.0"
185193 ]
194+
195+
196+
197+-- BINARY
198+
199+
200+instance Binary License where
201+ get = liftM2 License get get
202+ put (License a b) = put a >> put b
compiler/src/Elm/ModuleName.hs+46−72
@@ -1,19 +1,19 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}
1+{-# LANGUAGE OverloadedStrings #-}
22module Elm.ModuleName
33 ( Raw
44 , toChars
5+ , toString
56 , toFilePath
67 , toHyphenPath
7− --
8+ , fromHyphenPath
89 , encode
910 , decoder
10− , parser
11− --
1211 , Canonical(..)
12+ , canonicalIsKernel
1313 , basics, char, string
1414 , maybe, result, list, array, dict, tuple
1515 , platform, cmd, sub
16− , debug
16+ , debug, bitwise
1717 , virtualDom
1818 , jsonDecode, jsonEncode
1919 , webgl, texture, vector2, vector3, vector4, matrix4
@@ -23,19 +23,15 @@ module Elm.ModuleName
2323
2424import Control.Monad (liftM2)
2525import Data.Binary (Binary(..))
26+import qualified Data.Char as Char
2627import qualified Data.Name as Name
2728import qualified Data.Utf8 as Utf8
28−import Data.Word (Word8)
29−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
3029import Prelude hiding (maybe)
3130import qualified System.FilePath as FP
3231
3332import qualified Elm.Package as Pkg
34−import qualified Json.Decode as D
35−import qualified Json.Encode as E
36−import qualified Parse.Variable as Var
37−import qualified Parse.Primitives as P
38−import Parse.Primitives (Row, Col)
33+import qualified Json.Decode as Decode
34+import qualified Json.Encode as Encode
3935
4036
4137
@@ -50,6 +46,11 @@ toChars =
5046 Name.toChars
5147
5248
49+toString :: Raw -> Utf8.String
50+toString =
51+ Name.toUtf8
52+
53+
5354toFilePath :: Raw -> FilePath
5455toFilePath name =
5556 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)
@@ -60,68 +61,38 @@ toHyphenPath name =
6061 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
6162
6263
64+fromHyphenPath :: Utf8.String -> Maybe Raw
65+fromHyphenPath str =
66+ let
67+ chunks =
68+ Utf8.split 0x2D {- - -} str
69+ in
70+ if all isGoodChunk chunks
71+ then Just (Name.fromUtf8 (Utf8.join 0x2E {- . -} chunks))
72+ else Nothing
73+
74+
6375
6476-- JSON
6577
6678
67−encode :: Raw -> E.Value
79+encode :: Raw -> Encode.Value
6880encode =
69− E.name
81+ Encode.name
7082
7183
72−decoder :: D.Decoder (Row, Col) Raw
84+decoder :: Decode.Decoder Utf8.String Raw
7385decoder =
74− D.customString parser (,)
86+ do str <- Decode.string
87+ if all isGoodChunk (Utf8.split 0x2E {- . -} str)
88+ then return (Name.fromUtf8 str)
89+ else Decode.failure str
7590
7691
77−
78−-- PARSER
79−
80−
81−parser :: P.Parser (Row, Col) Raw
82−parser =
83− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
84− let
85− (# isGood, newPos, newCol #) = chompStart pos end col
86− in
87− if isGood && minusPtr newPos pos < 256 then
88− let !newState = P.State src newPos end indent row newCol in
89− cok (Utf8.fromPtr pos newPos) newState
90−
91− else if col == newCol then
92− eerr row newCol (,)
93−
94− else
95− cerr row newCol (,)
96−
97−
98−chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
99−chompStart pos end col =
100− let
101− !width = Var.getUpperWidth pos end
102− in
103− if width == 0 then
104− (# False, pos, col #)
105− else
106− chompInner (plusPtr pos width) end (col + 1)
107−
108−
109−chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
110−chompInner pos end col =
111− if pos >= end then
112− (# True, pos, col #)
113− else
114− let
115− !word = P.unsafeIndex pos
116− !width = Var.getInnerWidthHelp pos end word
117− in
118− if width == 0 then
119− if word == 0x2E {-.-} then
120− chompStart (plusPtr pos 1) end (col + 1)
121− else
122− (# True, pos, col #)
123− else
124− chompInner (plusPtr pos width) end (col + 1)
92+isGoodChunk :: Utf8.String -> Bool
93+isGoodChunk chunk =
94+ Utf8.startsWithChar Char.isUpper chunk
95+ && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk
12596
12697
12798
@@ -133,6 +104,12 @@ data Canonical =
133104 { _package :: !Pkg.Name
134105 , _module :: !Name.Name
135106 }
107+ deriving (Ord)
108+
109+
110+canonicalIsKernel :: Canonical -> Bool
111+canonicalIsKernel (Canonical _ name) =
112+ Name.isKernel name
136113
137114
138115
@@ -144,14 +121,6 @@ instance Eq Canonical where
144121 name1 == name2 && pkg1 == pkg2
145122
146123
147−instance Ord Canonical where
148− compare (Canonical pkg1 name1) (Canonical pkg2 name2) =
149− case compare name1 name2 of
150− LT -> LT
151− EQ -> compare pkg1 pkg2
152− GT -> GT
153−
154−
155124instance Binary Canonical where
156125 put (Canonical a b) = put a >> put b
157126 get = liftM2 Canonical get get
@@ -226,6 +195,11 @@ debug :: Canonical
226195debug = Canonical Pkg.core Name.debug
227196
228197
198+{-# NOINLINE bitwise #-}
199+bitwise :: Canonical
200+bitwise = Canonical Pkg.core Name.bitwise
201+
202+
229203
230204-- HTML
231205
compiler/src/Elm/Package.hs+89−220
@@ -1,52 +1,38 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}
2+{-# LANGUAGE OverloadedStrings #-}
33module Elm.Package
44 ( Name(..)
5− , Author
6− , Project
75 , Canonical(..)
86 , isKernel
7+ , toString
98 , toChars
109 , toUrl
1110 , toFilePath
12− , toJsonString
13− --
11+ , BadName(..)
12+ , fromString
1413 , dummyName, kernel, core
1514 , browser, virtualDom, html
1615 , json, http, url
1716 , webgl, linearAlgebra
18− --
1917 , suggestions
20− , nearbyNames
21− --
2218 , decoder
2319 , encode
24− , keyDecoder
25− --
26− , parser
2720 )
2821 where
2922
3023
3124import Control.Monad (liftM2)
3225import Data.Binary (Binary, get, put)
33−import qualified Data.Coerce as Coerce
34−import qualified Data.List as List
35−import qualified Data.Map as Map
26+import qualified Data.Char as Char
3627import qualified Data.Name as Name
28+import qualified Data.Map as Map
3729import Data.Monoid ((<>))
3830import qualified Data.Utf8 as Utf8
39−import Data.Word (Word8)
40−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
4131import System.FilePath ((</>))
4232
4333import qualified Elm.Version as V
44−import qualified Json.Decode as D
45−import qualified Json.Encode as E
46−import qualified Json.String as Json
47−import qualified Parse.Primitives as P
48−import Parse.Primitives (Row, Col)
49−import qualified Reporting.Suggest as Suggest
34+import qualified Json.Decode as Decode
35+import qualified Json.Encode as Encode
5036
5137
5238
@@ -55,17 +41,10 @@ import qualified Reporting.Suggest as Suggest
5541
5642data Name =
5743 Name
58− { _author :: !Author
59− , _project :: !Project
44+ { _author :: !Name.Name
45+ , _project :: !Name.Name
6046 }
61− deriving (Ord)
62−
63−
64−type Author = Utf8.Utf8 AUTHOR
65−type Project = Utf8.Utf8 PROJECT
66−
67−data AUTHOR
68−data PROJECT
47+ deriving (Eq, Ord)
6948
7049
7150data Canonical =
@@ -73,7 +52,7 @@ data Canonical =
7352 { _name :: !Name
7453 , _version :: !V.Version
7554 }
76− deriving (Ord)
55+ deriving (Eq, Ord)
7756
7857
7958
@@ -82,114 +61,127 @@ data Canonical =
8261
8362isKernel :: Name -> Bool
8463isKernel (Name author _) =
85− author == elm || author == elm_explorations
64+ author == "elm" || author == "elm-explorations"
65+
66+
67+toString :: Name -> Utf8.String
68+toString (Name author project) =
69+ Utf8.join 0x2F [ Name.toUtf8 author, Name.toUtf8 project ]
8670
8771
8872toChars :: Name -> String
8973toChars (Name author project) =
90− Utf8.toChars author <> "/" <> Utf8.toChars project
74+ Name.toChars author <> "/" <> Name.toChars project
9175
9276
9377toUrl :: Name -> String
9478toUrl (Name author project) =
95− Utf8.toChars author ++ "/" ++ Utf8.toChars project
79+ Name.toChars author ++ "/" ++ Name.toChars project
9680
9781
9882toFilePath :: Name -> FilePath
9983toFilePath (Name author project) =
100− Utf8.toChars author </> Utf8.toChars project
84+ Name.toChars author </> Name.toChars project
10185
10286
103−toJsonString :: Name -> Json.String
104−toJsonString (Name author project) =
105− Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]
87+fromString :: Utf8.String -> Either BadName Name
88+fromString str =
89+ case Utf8.split 0x2F {- / -} str of
90+ [author, project]
91+ | Utf8.isEmpty author -> Left BadStructure
92+ | Utf8.isEmpty project -> Left BadStructure
93+ | Utf8.size project >= 256 -> Left TooLong
94+ | Utf8.containsDouble 0x2D {- - -} project -> Left HasDoubleDash
95+ | Utf8.contains 0x5F {- _ -} project -> Left HasUnderscore
96+ | Utf8.contains 0x2E {- . -} project -> Left HasDot
97+ | Utf8.any Char.isUpper project -> Left HasUppercase
98+ | Utf8.endsWithWord 0x2D {- - -} project -> Left HasDashEnd
99+ | Utf8.startsWithChar Char.isLower project -> Right (Name (Name.fromUtf8 author) (Name.fromUtf8 project))
100+ | True -> Left HasNonLowercaseStart
106101
102+ _ ->
103+ Left BadStructure
107104
108105
109−-- COMMON PACKAGE NAMES
106+data BadName
107+ = BadStructure
108+ | TooLong
109+ | HasDoubleDash
110+ | HasUnderscore
111+ | HasDot
112+ | HasUppercase
113+ | HasDashEnd
114+ | HasNonLowercaseStart
115+
110116
111117
112−toName :: Author -> [Char] -> Name
113−toName author project =
114− Name author (Utf8.fromChars project)
118+-- COMMON PACKAGE NAMES
115119
116120
117121{-# NOINLINE dummyName #-}
118122dummyName :: Name
119123dummyName =
120− toName (Utf8.fromChars "author") "project"
124+ Name "author" "project"
121125
122126
123127{-# NOINLINE kernel #-}
124128kernel :: Name
125129kernel =
126− toName elm "kernel"
130+ Name "elm" "kernel"
127131
128132
129133{-# NOINLINE core #-}
130134core :: Name
131135core =
132− toName elm "core"
136+ Name "elm" "core"
133137
134138
135139{-# NOINLINE browser #-}
136140browser :: Name
137141browser =
138− toName elm "browser"
142+ Name "elm" "browser"
139143
140144
141145{-# NOINLINE virtualDom #-}
142146virtualDom :: Name
143147virtualDom =
144− toName elm "virtual-dom"
148+ Name "elm" "virtual-dom"
145149
146150
147151{-# NOINLINE html #-}
148152html :: Name
149153html =
150− toName elm "html"
154+ Name "elm" "html"
151155
152156
153157{-# NOINLINE json #-}
154158json :: Name
155159json =
156− toName elm "json"
160+ Name "elm" "json"
157161
158162
159163{-# NOINLINE http #-}
160164http :: Name
161165http =
162− toName elm "http"
166+ Name "elm" "http"
163167
164168
165169{-# NOINLINE url #-}
166170url :: Name
167171url =
168− toName elm "url"
172+ Name "elm" "url"
169173
170174
171175{-# NOINLINE webgl #-}
172176webgl :: Name
173177webgl =
174− toName elm_explorations "webgl"
178+ Name "elm-explorations" "webgl"
175179
176180
177181{-# NOINLINE linearAlgebra #-}
178182linearAlgebra :: Name
179183linearAlgebra =
180− toName elm_explorations "linear-algebra"
181−
182−
183−{-# NOINLINE elm #-}
184−elm :: Author
185−elm =
186− Utf8.fromChars "elm"
187−
188−
189−{-# NOINLINE elm_explorations #-}
190−elm_explorations :: Author
191−elm_explorations =
192− Utf8.fromChars "elm-explorations"
184+ Name "elm-explorations" "linear-algebra"
193185
194186
195187
@@ -198,177 +190,54 @@ elm_explorations =
198190
199191suggestions :: Map.Map Name.Name Name
200192suggestions =
201− let
202− random = toName elm "random"
203− time = toName elm "time"
204− file = toName elm "file"
205− in
206193 Map.fromList
207− [ "Browser" ==> browser
208− , "File" ==> file
209− , "File.Download" ==> file
210− , "File.Select" ==> file
211− , "Html" ==> html
212− , "Html.Attributes" ==> html
213− , "Html.Events" ==> html
214− , "Http" ==> http
215− , "Json.Decode" ==> json
216− , "Json.Encode" ==> json
217− , "Random" ==> random
218− , "Time" ==> time
219− , "Url.Parser" ==> url
220− , "Url" ==> url
194+ [ ("Browser", browser)
195+ , ("Html", html)
196+ , ("Http", http)
197+ , ("Json.Decode", json)
198+ , ("Json.Encode", json)
199+ , ("Url.Parser", url)
200+ , ("Url", url)
221201 ]
222202
223203
224−(==>) :: [Char] -> Name -> (Name.Name, Name)
225−(==>) moduleName package =
226− ( Utf8.fromChars moduleName, package )
227−
228−
229−
230−-- NEARBY NAMES
231−
232−
233−nearbyNames :: Name -> [Name] -> [Name]
234−nearbyNames (Name author1 project1) possibleNames =
235− let
236− authorDist = authorDistance (Utf8.toChars author1)
237− projectDist = projectDistance (Utf8.toChars project1)
238−
239− nameDistance (Name author2 project2) =
240− authorDist author2 + projectDist project2
241− in
242− take 4 $ List.sortOn nameDistance possibleNames
243−
244−
245−authorDistance :: [Char] -> Author -> Int
246−authorDistance given possibility =
247− if possibility == elm || possibility == elm_explorations
248− then 0
249− else abs (Suggest.distance given (Utf8.toChars possibility))
250−
251−
252−projectDistance :: [Char] -> Project -> Int
253−projectDistance given possibility =
254− abs (Suggest.distance given (Utf8.toChars possibility))
255−
256−
257−
258−-- INSTANCES
259−
260−
261−instance Eq Name where
262− (==) (Name author1 project1) (Name author2 project2) =
263− project1 == project2 && author1 == author2
264−
265−
266−instance Eq Canonical where
267− (==) (Canonical package1 version1) (Canonical package2 version2) =
268− version1 == version2 && package1 == package2
269−
270−
271204
272205-- BINARY
273206
274207
275−instance Binary Name where -- PERF try storing as a Word16
276− get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
277− put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
208+instance Binary Name where
209+ get =
210+ liftM2 Name get get
211+
212+ put (Name author project) =
213+ do put author
214+ put project
278215
279216
280217instance Binary Canonical where
281− get = liftM2 Canonical get get
282− put (Canonical a b) = put a >> put b
218+ get =
219+ liftM2 Canonical get get
220+
221+ put (Canonical name version) =
222+ do put name
223+ put version
283224
284225
285226
286227-- JSON
287228
288229
289−decoder :: D.Decoder (Row, Col) Name
230+decoder :: Decode.Decoder BadName Name
290231decoder =
291− D.customString parser (,)
232+ do str <- Decode.string
233+ case fromString str of
234+ Right name ->
235+ return name
236+
237+ Left err ->
238+ Decode.failure err
292239
293240
294−encode :: Name -> E.Value
241+encode :: Name -> Encode.Value
295242encode name =
296− E.chars (toChars name)
297−
298−
299−keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name
300−keyDecoder toError =
301− let
302− keyParser =
303− P.specialize (\(r,c) _ _ -> toError r c) parser
304− in
305− D.KeyDecoder keyParser toError
306−
307−
308−
309−-- PARSER
310−
311−
312−parser :: P.Parser (Row, Col) Name
313−parser =
314− do author <- parseName isAlphaOrDigit isAlphaOrDigit
315− P.word1 0x2F {-/-} (,)
316− project <- parseName isLower isLowerOrDigit
317− return (Name author project)
318−
319−
320−parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)
321−parseName isGoodStart isGoodInner =
322− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
323− if pos >= end then
324− eerr row col (,)
325− else
326− let !word = P.unsafeIndex pos in
327− if not (isGoodStart word) then
328− eerr row col (,)
329− else
330− let
331− (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False
332− !len = fromIntegral (minusPtr newPos pos)
333− !newCol = col + len
334− in
335− if isGood && len < 256 then
336− let !newState = P.State src newPos end indent row newCol in
337− cok (Utf8.fromPtr pos newPos) newState
338− else
339− cerr row newCol (,)
340−
341−
342−isLower :: Word8 -> Bool
343−isLower word =
344− 0x61 {-a-} <= word && word <= 0x7A {-z-}
345−
346−
347−isLowerOrDigit :: Word8 -> Bool
348−isLowerOrDigit word =
349− 0x61 {-a-} <= word && word <= 0x7A {-z-}
350− || 0x30 {-0-} <= word && word <= 0x39 {-9-}
351−
352−
353−isAlphaOrDigit :: Word8 -> Bool
354−isAlphaOrDigit word =
355− 0x61 {-a-} <= word && word <= 0x7A {-z-}
356− || 0x41 {-A-} <= word && word <= 0x5A {-Z-}
357− || 0x30 {-0-} <= word && word <= 0x39 {-9-}
358−
359−
360−chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)
361−chompName isGoodChar pos end prevWasDash =
362− if pos >= end then
363− (# not prevWasDash, pos #)
364− else
365− let !word = P.unsafeIndex pos in
366− if isGoodChar word then
367− chompName isGoodChar (plusPtr pos 1) end False
368− else if word == 0x2D {---} then
369− if prevWasDash then
370− (# False, pos #)
371− else
372− chompName isGoodChar (plusPtr pos 1) end True
373− else
374− (# True, pos #)
243+ Encode.string (toString name)
compiler/src/Elm/String.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}
3−module Elm.String
4− ( String
5− , toChars
6− , toBuilder
7− , Chunk(..)
8− , fromChunks
9− )
10− where
11−
12−
13−import Prelude hiding (String)
14−import Data.Binary (Binary, get, put)
15−import Data.Bits ((.&.), shiftR)
16−import qualified Data.ByteString.Builder as B
17−import qualified Data.Utf8 as Utf8
18−import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
19−import GHC.Exts (RealWorld, Ptr)
20−import GHC.IO (stToIO, unsafeDupablePerformIO)
21−import GHC.ST (ST)
22−import GHC.Word (Word8)
23−
24−
25−
26−-- STRINGS
27−
28−
29−type String =
30− Utf8.Utf8 ELM_STRING
31−
32−
33−data ELM_STRING
34−
35−
36−
37−-- HELPERS
38−
39−
40−toChars :: String -> [Char]
41−toChars =
42− Utf8.toChars
43−
44−
45−{-# INLINE toBuilder #-}
46−toBuilder :: String -> B.Builder
47−toBuilder =
48− Utf8.toBuilder
49−
50−
51−
52−-- FROM CHUNKS
53−
54−
55−data Chunk
56− = Slice (Ptr Word8) Int
57− | Escape Word8
58− | CodePoint Int
59−
60−
61−fromChunks :: [Chunk] -> String
62−fromChunks chunks =
63− unsafeDupablePerformIO (stToIO (
64− do let !len = sum (map chunkToWidth chunks)
65− mba <- newByteArray len
66− writeChunks mba 0 chunks
67− freeze mba
68− ))
69−
70−
71−chunkToWidth :: Chunk -> Int
72−chunkToWidth chunk =
73− case chunk of
74− Slice _ len -> len
75− Escape _ -> 2
76− CodePoint c -> if c < 0xFFFF then 6 else 12
77−
78−
79−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
80−writeChunks mba offset chunks =
81− case chunks of
82− [] ->
83− return ()
84−
85− chunk : chunks ->
86− case chunk of
87− Slice ptr len ->
88− do copyFromPtr ptr mba offset len
89− let !newOffset = offset + len
90− writeChunks mba newOffset chunks
91−
92− Escape word ->
93− do writeWord8 mba offset 0x5C {- \ -}
94− writeWord8 mba (offset + 1) word
95− let !newOffset = offset + 2
96− writeChunks mba newOffset chunks
97−
98− CodePoint code ->
99− if code < 0xFFFF then
100− do writeCode mba offset code
101− let !newOffset = offset + 6
102− writeChunks mba newOffset chunks
103− else
104− do let (hi,lo) = divMod (code - 0x10000) 0x400
105− writeCode mba (offset ) (hi + 0xD800)
106− writeCode mba (offset + 6) (lo + 0xDC00)
107− let !newOffset = offset + 12
108− writeChunks mba newOffset chunks
109−
110−
111−writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112−writeCode mba offset code =
113− do writeWord8 mba offset 0x5C {- \ -}
114− writeWord8 mba (offset + 1) 0x75 {- u -}
115− writeHex mba (offset + 2) (shiftR code 12)
116− writeHex mba (offset + 3) (shiftR code 8)
117− writeHex mba (offset + 4) (shiftR code 4)
118− writeHex mba (offset + 5) code
119−
120−
121−writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
122−writeHex mba !offset !bits =
123− do let !n = fromIntegral bits .&. 0x0F
124− writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
125−
126−
127−
128−-- BINARY
129−
130−
131−instance Binary (Utf8.Utf8 ELM_STRING) where
132− get = Utf8.getVeryLong
133− put = Utf8.putVeryLong
compiler/src/Elm/Version.hs+50−79
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples #-}
31module Elm.Version
42 ( Version(..)
53 , one
@@ -9,27 +7,24 @@ module Elm.Version
97 , bumpMinor
108 , bumpMajor
119 , toChars
12− --
10+ , toString
11+ , fromString
1312 , decoder
1413 , encode
15− --
16− , parser
1714 )
1815 where
1916
2017
2118import Prelude hiding (max)
22−import Control.Monad (liftM3)
19+import Control.Monad (liftM, liftM3)
2320import Data.Binary (Binary, get, put, getWord8, putWord8)
21+import qualified Data.Utf8 as Utf8
2422import qualified Data.Version as Version
25−import Data.Word (Word8, Word16)
26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
23+import Data.Word (Word16)
2724import qualified Paths_elm
2825
2926import qualified Json.Decode as D
3027import qualified Json.Encode as E
31−import qualified Parse.Primitives as P
32−import Parse.Primitives (Row, Col)
3328
3429
3530
@@ -91,26 +86,58 @@ bumpMajor (Version major _minor _patch) =
9186
9287
9388
94−-- TO CHARS
89+-- TO STRING
9590
9691
97−toChars :: Version -> [Char]
98−toChars (Version major minor patch) =
99− show major ++ '.' : show minor ++ '.' : show patch
92+toChars :: Version -> String
93+toChars vsn =
94+ Utf8.toChars (toString vsn)
95+
96+
97+toString :: Version -> Utf8.String
98+toString (Version major minor patch) =
99+ Utf8.join 0x2E {- . -}
100+ [ Utf8.fromWord16 major
101+ , Utf8.fromWord16 minor
102+ , Utf8.fromWord16 patch
103+ ]
104+
105+
106+
107+-- FROM STRING
108+
109+
110+fromString :: Utf8.String -> Maybe Version
111+fromString str =
112+ case Utf8.split 0x2E {- . -} str of
113+ [major, minor, patch] ->
114+ Version
115+ <$> Utf8.toWord16 major
116+ <*> Utf8.toWord16 minor
117+ <*> Utf8.toWord16 patch
118+
119+ _ ->
120+ Nothing
100121
101122
102123
103124-- JSON
104125
105126
106−decoder :: D.Decoder (Row, Col) Version
127+decoder :: D.Decoder Utf8.String Version
107128decoder =
108− D.customString parser (,)
129+ do str <- D.string
130+ case fromString str of
131+ Just version ->
132+ return version
133+
134+ Nothing ->
135+ D.failure str
109136
110137
111138encode :: Version -> E.Value
112139encode version =
113− E.chars (toChars version)
140+ E.string (toString version)
114141
115142
116143
@@ -120,77 +147,21 @@ encode version =
120147instance Binary Version where
121148 get =
122149 do word <- getWord8
123− if word == 255
150+ if word == 0
124151 then liftM3 Version get get get
125152 else
126− do minor <- getWord8
127− patch <- getWord8
128− return (Version (fromIntegral word) (fromIntegral minor) (fromIntegral patch))
153+ do minor <- liftM fromIntegral getWord8
154+ patch <- liftM fromIntegral getWord8
155+ return (Version (fromIntegral word) minor patch)
129156
130157 put (Version major minor patch) =
131− if major < 255 && minor < 256 && patch < 256 then
158+ if major < 256 && minor < 256 && patch < 256 then
132159 do putWord8 (fromIntegral major)
133160 putWord8 (fromIntegral minor)
134161 putWord8 (fromIntegral patch)
135162 else
136− do putWord8 255
163+ do putWord8 0
137164 put major
138165 put minor
139166 put patch
140167
141−
142−
143−-- PARSER
144−
145−
146−parser :: P.Parser (Row, Col) Version
147−parser =
148− do major <- numberParser
149− P.word1 0x2E {-.-} (,)
150− minor <- numberParser
151− P.word1 0x2E {-.-} (,)
152− patch <- numberParser
153− return (Version major minor patch)
154−
155−
156−numberParser :: P.Parser (Row, Col) Word16
157−numberParser =
158− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
159− if pos >= end then
160− eerr row col (,)
161− else
162− let !word = P.unsafeIndex pos in
163− if word == 0x30 {-0-} then
164−
165− let
166− !newState = P.State src (plusPtr pos 1) end indent row (col + 1)
167− in
168− cok 0 newState
169−
170− else if isDigit word then
171−
172− let
173− (# total, newPos #) = chompWord16 (plusPtr pos 1) end (fromIntegral (word - 0x30))
174− !newState = P.State src newPos end indent row (col + fromIntegral (minusPtr newPos pos))
175− in
176− cok total newState
177−
178− else
179− eerr row col (,)
180−
181−
182−chompWord16 :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Word16, Ptr Word8 #)
183−chompWord16 pos end total =
184− if pos >= end then
185− (# total, pos #)
186− else
187− let !word = P.unsafeIndex pos in
188− if isDigit word then
189− chompWord16 (plusPtr pos 1) end (10 * total + fromIntegral (word - 0x30))
190− else
191− (# total, pos #)
192−
193−
194−isDigit :: Word8 -> Bool
195−isDigit word =
196− 0x30 {-0-} <= word && word <= 0x39 {-9-}
compiler/src/Generate/Html.hs+4−17
@@ -24,31 +24,18 @@ sandwich moduleName javascript =
2424<head>
2525 <meta charset="UTF-8">
2626 <title>|] <> name <> [r|</title>
27− <style>body { padding: 0; margin: 0; }</style>
2827</head>
2928
3029<body>
31−
32−<pre id="elm"></pre>
33−
30+<div id="elm-df98db9626"></div>
3431<script>
35−try {
3632|] <> javascript <> [r|
3733
38− var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
39−}
40−catch (e)
34+var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm-df98db9626") });
35+if (document.getElementById("elm-df98db9626"))
4136{
42− // display initialization errors (e.g. bad flags, infinite recursion)
43− var header = document.createElement("h1");
44− header.style.fontFamily = "monospace";
45− header.innerText = "Initialization Error";
46− var pre = document.getElementById("elm");
47− document.body.insertBefore(header, pre);
48− pre.innerText = e;
49− throw e;
37+ document.getElementById("elm-df98db9626").innerText = 'This is a headless program, meaning there is nothing to show here.\n\nI started the program anyway though, and you can access it as `app` in the developer console.';
5038}
5139</script>
52−
5340</body>
5441</html>|]
compiler/src/Generate/JavaScript.hs+87−97
@@ -1,8 +1,8 @@
11{-# LANGUAGE OverloadedStrings #-}
22module Generate.JavaScript
3− ( generate
3+ ( Output(..)
4+ , generate
45 , generateForRepl
5− , generateForReplEndpoint
66 )
77 where
88
@@ -20,11 +20,11 @@ import qualified Data.Utf8 as Utf8
2020import qualified AST.Canonical as Can
2121import qualified AST.Optimized as Opt
2222import qualified Data.Index as Index
23+import qualified Elm.Interface as I
2324import qualified Elm.Kernel as K
2425import qualified Elm.ModuleName as ModuleName
2526import qualified Generate.JavaScript.Builder as JS
2627import qualified Generate.JavaScript.Expression as Expr
27−import qualified Generate.JavaScript.Functions as Functions
2828import qualified Generate.JavaScript.Name as JsName
2929import qualified Generate.Mode as Mode
3030import qualified Reporting.Doc as D
@@ -33,27 +33,33 @@ import qualified Reporting.Render.Type.Localizer as L
3333
3434
3535
36−-- GENERATE
36+-- GENERATE MAINS
3737
3838
39−type Graph = Map.Map Opt.Global Opt.Node
40−type Mains = Map.Map ModuleName.Canonical Opt.Main
39+data Output
40+ = None
41+ | Some Name.Name [Name.Name] B.Builder
4142
4243
43−generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder
44−generate mode (Opt.GlobalGraph graph _) mains =
44+generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
45+generate mode (Opt.Graph mains graph _) roots =
4546 let
46− state = Map.foldrWithKey (addMain mode graph) emptyState mains
47+ rootSet = Set.fromList roots
48+ rootMap = Map.restrictKeys mains rootSet
4749 in
48− "(function(scope){\n'use strict';"
49− <> Functions.functions
50− <> perfNote mode
51− <> stateToBuilder state
52− <> toMainExports mode mains
53− <> "}(this));"
50+ case map ModuleName._module (Map.keys rootMap) of
51+ [] ->
52+ None
53+
54+ name:names ->
55+ let
56+ state = Map.foldrWithKey (addMain mode graph) emptyState rootMap
57+ builder = perfNote mode <> stateToBuilder state <> toMainExports mode rootMap
58+ in
59+ Some name names builder
5460
5561
56−addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State
62+addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
5763addMain mode graph home _ state =
5864 addGlobal mode graph state (Opt.Global home "main")
5965
@@ -79,68 +85,34 @@ perfNote mode =
7985-- GENERATE FOR REPL
8086
8187
82−generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
83−generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
88+generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> Name.Name -> B.Builder
89+generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
8490 let
8591 mode = Mode.Dev Nothing
8692 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
8793 evalState = addGlobal mode graph debugState (Opt.Global home name)
8894 in
89− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90− <> Functions.functions
91− <> stateToBuilder evalState
92− <> print ansi localizer home name tipe
95+ stateToBuilder evalState
96+ <>
97+ print ansi localizer home name (I._values iface ! name)
9398
9499
95−print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
96−print ansi localizer home name tipe =
100+print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
101+print ansi localizer home name (Can.Forall _ tipe) =
97102 let
98103 value = JsName.toBuilder (JsName.fromGlobal home name)
99104 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
100105 tipeDoc = RT.canToDoc localizer RT.None tipe
101106 bool = if ansi then "true" else "false"
102107 in
103− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
104− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
105− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
106− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
107− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
108− \} else {\n\
109− \ _print(' : ' + _type);\n\
110− \}\n"
111−
112−
113−
114−-- GENERATE FOR REPL ENDPOINT
115−
116−
117−generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118−generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119− let
120− name = maybe Name.replValueToPrint id maybeName
121− mode = Mode.Dev Nothing
122− debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
123− evalState = addGlobal mode graph debugState (Opt.Global home name)
124− in
125− Functions.functions
126− <> stateToBuilder evalState
127− <> postMessage localizer home maybeName tipe
128−
129−
130−postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131−postMessage localizer home maybeName tipe =
132− let
133− name = maybe Name.replValueToPrint id maybeName
134− value = JsName.toBuilder (JsName.fromGlobal home name)
135− toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136− tipeDoc = RT.canToDoc localizer RT.None tipe
137− toName n = "\"" <> Name.toBuilder n <> "\""
138− in
139− "self.postMessage({\n\
140− \ name: " <> maybe "null" toName maybeName <> ",\n\
141− \ value: " <> toString <> "(true, " <> value <> "),\n\
142− \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
143− \});\n"
108+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
109+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
110+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
111+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
112+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
113+ \} else {\n\
114+ \ _print(' : ' + _type);\n\
115+ \}\n"
144116
145117
146118
@@ -174,6 +146,9 @@ prependBuilders revBuilders monolith =
174146-- ADD DEPENDENCIES
175147
176148
149+type Graph = Map.Map Opt.Global Opt.Node
150+
151+
177152addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
178153addGlobal mode graph state@(State revKernels builders seen) global =
179154 if Set.member global seen then
@@ -261,7 +236,7 @@ addKernel (State revKernels revBuilders seen) kernel =
261236
262237var :: Opt.Global -> Expr.Code -> JS.Stmt
263238var (Opt.Global home name) code =
264− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
239+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
265240
266241
267242isDebugger :: Opt.Global -> Bool
@@ -292,7 +267,7 @@ generateCycle mode (Opt.Global home _) names values functions =
292267 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
293268 <> drawCycle names
294269 <> "\\n\\nThese errors are very tricky, so read "
295− <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
270+ <> B.stringUtf8 (D.makeNakedLink "halting-problem")
296271 <> " to learn how to fix it!"
297272 ]
298273
@@ -301,10 +276,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
301276generateCycleFunc mode home def =
302277 case def of
303278 Opt.Def name expr ->
304− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
279+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
305280
306281 Opt.TailDef name args expr ->
307− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
282+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
308283
309284
310285generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
@@ -320,9 +295,9 @@ generateRealCycle home (name, _) =
320295 realName = JsName.fromGlobal home name
321296 in
322297 JS.Block
323− [ JS.Var realName (JS.Call (JS.Ref safeName) [])
298+ [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
324299 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
325− JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
300+ JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
326301 ]
327302
328303
@@ -350,7 +325,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
350325addChunk mode chunk builder =
351326 case chunk of
352327 K.JS javascript ->
353− B.byteString javascript <> builder
328+ Utf8.toBuilder javascript <> builder
354329
355330 K.ElmVar home name ->
356331 JsName.toBuilder (JsName.fromGlobal home name) <> builder
@@ -390,13 +365,16 @@ addChunk mode chunk builder =
390365
391366generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
392367generateEnum mode global@(Opt.Global home name) index =
393− JS.Var (JsName.fromGlobal home name) $
394− case mode of
395− Mode.Dev _ ->
396− Expr.codeToExpr (Expr.generateCtor mode global index 0)
368+ let
369+ definition =
370+ case mode of
371+ Mode.Dev _ ->
372+ Expr.codeToExpr (Expr.generateCtor mode global index 0)
397373
398− Mode.Prod _ ->
399− JS.Int (Index.toMachine index)
374+ Mode.Prod _ ->
375+ JS.Int (Index.toMachine index)
376+ in
377+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
400378
401379
402380
@@ -405,13 +383,16 @@ generateEnum mode global@(Opt.Global home name) index =
405383
406384generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
407385generateBox mode global@(Opt.Global home name) =
408− JS.Var (JsName.fromGlobal home name) $
409− case mode of
410− Mode.Dev _ ->
411− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
386+ let
387+ definition =
388+ case mode of
389+ Mode.Dev _ ->
390+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
412391
413− Mode.Prod _ ->
414− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
392+ Mode.Prod _ ->
393+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
394+ in
395+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
415396
416397
417398{-# NOINLINE identity #-}
@@ -426,11 +407,14 @@ identity =
426407
427408generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
428409generatePort mode (Opt.Global home name) makePort converter =
429− JS.Var (JsName.fromGlobal home name) $
430− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
431− [ JS.String (Name.toBuilder name)
432− , Expr.codeToExpr (Expr.generate mode converter)
433− ]
410+ let
411+ definition =
412+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
413+ [ JS.String (Name.toBuilder name)
414+ , Expr.codeToExpr (Expr.generate mode converter)
415+ ]
416+ in
417+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
434418
435419
436420
@@ -458,9 +442,11 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)
458442
459443generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
460444generateLeaf home@(ModuleName.Canonical _ moduleName) name =
461− JS.Var (JsName.fromGlobal home name) $
462− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
463−
445+ let
446+ definition =
447+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
448+ in
449+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
464450
465451
466452{-# NOINLINE leaf #-}
@@ -501,7 +487,7 @@ generateManagerHelp home effectsType =
501487-- MAIN EXPORTS
502488
503489
504−toMainExports :: Mode.Mode -> Mains -> B.Builder
490+toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
505491toMainExports mode mains =
506492 let
507493 export = JsName.fromKernel Name.platform "export"
@@ -534,7 +520,7 @@ generateExports mode (Trie maybeMain subs) =
534520 <> List.foldl' (addSubTrie mode) "}" otherSubTries
535521
536522
537−addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
523+addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
538524addSubTrie mode end (name, trie) =
539525 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
540526
@@ -546,7 +532,7 @@ addSubTrie mode end (name, trie) =
546532data Trie =
547533 Trie
548534 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
549− , _subs :: Map.Map Name.Name Trie
535+ , _subs :: Map.Map Utf8.String Trie
550536 }
551537
552538
@@ -557,10 +543,14 @@ emptyTrie =
557543
558544addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
559545addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
560− merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
546+ let
547+ segments =
548+ Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
549+ in
550+ merge trie $ segmentsToTrie home segments main
561551
562552
563−segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
553+segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
564554segmentsToTrie home segments main =
565555 case segments of
566556 [] ->
compiler/src/Generate/JavaScript/Builder.hs+217−207
@@ -16,7 +16,6 @@ module Generate.JavaScript.Builder
1616
1717import Prelude hiding (lines)
1818import qualified Data.List as List
19−import qualified Data.ByteString as BS
2019import Data.ByteString.Builder as B
2120import Data.Monoid ((<>))
2221import qualified Generate.JavaScript.Name as Name
@@ -28,19 +27,6 @@ import qualified Json.Encode as Json
2827-- EXPRESSIONS
2928
3029
31−-- NOTE: I tried making this create a B.Builder directly.
32−--
33−-- The hope was that it'd allocate less and speed things up, but it seemed
34−-- to be neutral for perf.
35−--
36−-- The downside is that Generate.JavaScript.Expression inspects the
37−-- structure of Expr and Stmt on some occassions to try to strip out
38−-- unnecessary closures. I think these closures are already avoided
39−-- by other logic in code gen these days, but I am not 100% certain.
40−--
41−-- For this to be worth it, I think it would be necessary to avoid
42−-- returning tuples when generating expressions.
43−--
4430data Expr
4531 = String Builder
4632 | Float Builder
@@ -51,13 +37,13 @@ data Expr
5137 | Array [Expr]
5238 | Object [(Name, Expr)]
5339 | Ref Name
54− | Access Expr Name -- foo.bar
55− | Index Expr Expr -- foo[bar]
40+ | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
41+ | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
5642 | Prefix PrefixOp Expr
5743 | Infix InfixOp Expr Expr
5844 | If Expr Expr Expr
5945 | Assign LValue Expr
60− | Call Expr [Expr]
46+ | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
6147 | Function (Maybe Name) [Name] [Stmt]
6248
6349
@@ -72,21 +58,20 @@ data LValue
7258
7359
7460data Stmt
75− = Block [Stmt]
76− | EmptyStmt
77− | ExprStmt Expr
78− | IfStmt Expr Stmt Stmt
79− | Switch Expr [Case]
80− | While Expr Stmt
81− | Break (Maybe Name)
82− | Continue (Maybe Name)
83− | Labelled Name Stmt
84− | Try Stmt Name Stmt
85− | Throw Expr
86− | Return Expr
87− | Var Name Expr
88− | Vars [(Name, Expr)]
89− | FunctionStmt Name [Name] [Stmt]
61+ = Block [Stmt] -- {stmts}
62+ | EmptyStmt -- ;
63+ | ExprStmt Expr -- expr;
64+ | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
65+ | Switch Expr [Case] -- switch (e) clauses
66+ | While Expr Stmt -- while (e) do stmt
67+ | Break (Maybe Name) -- break lab;
68+ | Continue (Maybe Name) -- continue lab;
69+ | Labelled Name Stmt -- lab: stmt
70+ | Try Stmt Name Stmt -- try stmt catch (x) stmt
71+ | Throw Expr -- throw expr;
72+ | Return (Maybe Expr) -- return expr;
73+ | Var [(Name, Maybe Expr)] -- var x, y=42;
74+ | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
9075
9176
9277data Case
@@ -99,31 +84,37 @@ data Case
9984
10085
10186data InfixOp
102− = OpAdd -- +
103− | OpSub -- -
87+ = OpLT -- <
88+ | OpLEq -- <=
89+ | OpGT -- >
90+ | OpGEq -- >=
91+ | OpIn -- in
92+ | OpInstanceof -- instanceof
93+ | OpEq -- ==
94+ | OpNEq -- !=
95+ | OpStrictEq -- ===
96+ | OpStrictNEq -- !==
97+ | OpLAnd -- &&
98+ | OpLOr -- ||
10499 | OpMul -- *
105100 | OpDiv -- /
106101 | OpMod -- %
107− | OpEq -- ===
108− | OpNe -- !==
109− | OpLt -- <
110− | OpLe -- <=
111− | OpGt -- >
112− | OpGe -- >=
113− | OpAnd -- &&
114− | OpOr -- ||
115− | OpBitwiseAnd -- &
116− | OpBitwiseXor -- ^
117− | OpBitwiseOr -- |
118− | OpLShift -- <<
119− | OpSpRShift -- >>
120− | OpZfRShift -- >>>
102+ | OpSub -- -
103+ | OpLShift -- <<
104+ | OpSpRShift -- >>
105+ | OpZfRShift -- >>>
106+ | OpBAnd -- &
107+ | OpBXor -- ^
108+ | OpBOr -- |
109+ | OpAdd -- +
121110
122111
123112data PrefixOp
124− = PrefixNot -- !
125− | PrefixNegate -- -
126− | PrefixComplement -- ~
113+ = PrefixLNot -- !
114+ | PrefixBNot -- ~
115+ | PrefixPlus -- +
116+ | PrefixMinus -- -
117+ | PrefixTypeof -- typeof
127118
128119
129120
@@ -132,40 +123,21 @@ data PrefixOp
132123
133124stmtToBuilder :: Stmt -> Builder
134125stmtToBuilder stmts =
135− fromStmt levelZero stmts
126+ fromStmt "" stmts
136127
137128
138129exprToBuilder :: Expr -> Builder
139130exprToBuilder expr =
140− snd $ fromExpr levelZero Whatever expr
141−
142−
143−
144−-- INDENT LEVEL
145−
146−
147−data Level =
148− Level Builder Level
149−
131+ snd $ fromExpr "" Whatever expr
150132
151−levelZero :: Level
152−levelZero =
153− Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
154133
155134
156−makeLevel :: Int -> BS.ByteString -> Level
157−makeLevel level oldTabs =
158− let
159− tabs =
160− if level <= BS.length oldTabs
161− then oldTabs
162− else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
163− in
164− Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
165−
135+-- HELPERS
166136
167137
168−-- HELPERS
138+deeper :: Builder -> Builder
139+deeper indent =
140+ "\t" <> indent
169141
170142
171143commaSep :: [Builder] -> Builder
@@ -173,52 +145,52 @@ commaSep builders =
173145 mconcat (List.intersperse ", " builders)
174146
175147
176−commaNewlineSep :: Level -> [Builder] -> Builder
177−commaNewlineSep (Level _ (Level deeperIndent _)) builders =
178− mconcat (List.intersperse (",\n" <> deeperIndent) builders)
148+commaNewlineSep :: Builder -> [Builder] -> Builder
149+commaNewlineSep indent builders =
150+ mconcat (List.intersperse (",\n" <> deeper indent) builders)
179151
180152
181153
182154-- STATEMENTS
183155
184156
185−fromStmtBlock :: Level -> [Stmt] -> Builder
186−fromStmtBlock level stmts =
187− mconcat (map (fromStmt level) stmts)
157+fromStmtBlock :: Builder -> [Stmt] -> Builder
158+fromStmtBlock indent stmts =
159+ mconcat (map (fromStmt indent) stmts)
188160
189161
190−fromStmt :: Level -> Stmt -> Builder
191−fromStmt level@(Level indent nextLevel) statement =
162+fromStmt :: Builder -> Stmt -> Builder
163+fromStmt indent statement =
192164 case statement of
193165 Block stmts ->
194− fromStmtBlock level stmts
166+ fromStmtBlock indent stmts
195167
196168 EmptyStmt ->
197169 mempty
198170
199171 ExprStmt expr ->
200− indent <> snd (fromExpr level Whatever expr) <> ";\n"
172+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"
201173
202174 IfStmt condition thenStmt elseStmt ->
203175 mconcat
204− [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
205− , fromStmt nextLevel thenStmt
176+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
177+ , fromStmt (deeper indent) thenStmt
206178 , indent, "} else {\n"
207− , fromStmt nextLevel elseStmt
179+ , fromStmt (deeper indent) elseStmt
208180 , indent, "}\n"
209181 ]
210182
211183 Switch expr clauses ->
212184 mconcat
213− [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
214− , mconcat (map (fromClause nextLevel) clauses)
185+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
186+ , mconcat (map (fromClause (deeper indent)) clauses)
215187 , indent, "}\n"
216188 ]
217189
218190 While expr stmt ->
219191 mconcat
220− [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
221− , fromStmt nextLevel stmt
192+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
193+ , fromStmt (deeper indent) stmt
222194 , indent, "}\n"
223195 ]
224196
@@ -237,37 +209,37 @@ fromStmt level@(Level indent nextLevel) statement =
237209 Labelled label stmt ->
238210 mconcat
239211 [ indent, Name.toBuilder label, ":\n"
240− , fromStmt level stmt
212+ , fromStmt indent stmt
241213 ]
242214
243215 Try tryStmt errorName catchStmt ->
244216 mconcat
245217 [ indent, "try {\n"
246− , fromStmt nextLevel tryStmt
218+ , fromStmt (deeper indent) tryStmt
247219 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
248− , fromStmt nextLevel catchStmt
220+ , fromStmt (deeper indent) catchStmt
249221 , indent, "}\n"
250222 ]
251223
252224 Throw expr ->
253− indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
225+ "throw " <> snd (fromExpr indent Whatever expr) <> ";"
254226
255− Return expr ->
256− indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
227+ Return Nothing ->
228+ indent <> "return;\n"
257229
258− Var name expr ->
259− indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
230+ Return (Just expr) ->
231+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
260232
261− Vars [] ->
233+ Var [] ->
262234 mempty
263235
264− Vars vars ->
265− indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
236+ Var vars ->
237+ indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
266238
267239 FunctionStmt name args stmts ->
268240 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
269241 <>
270− fromStmtBlock nextLevel stmts
242+ fromStmtBlock (deeper indent) stmts
271243 <>
272244 indent <> "}\n"
273245
@@ -276,25 +248,30 @@ fromStmt level@(Level indent nextLevel) statement =
276248-- SWITCH CLAUSES
277249
278250
279−fromClause :: Level -> Case -> Builder
280−fromClause level@(Level indent nextLevel) clause =
251+fromClause :: Builder -> Case -> Builder
252+fromClause indent clause =
281253 case clause of
282254 Case expr stmts ->
283− indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
284− <> fromStmtBlock nextLevel stmts
255+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
256+ <> fromStmtBlock (deeper indent) stmts
285257
286258 Default stmts ->
287259 indent <> "default:\n"
288− <> fromStmtBlock nextLevel stmts
260+ <> fromStmtBlock (deeper indent) stmts
289261
290262
291263
292264-- VAR DECLS
293265
294266
295−varToBuilder :: Level -> (Name, Expr) -> Builder
296−varToBuilder level (name, expr) =
297− Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
267+varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
268+varToBuilder indent (name, maybeExpr) =
269+ case maybeExpr of
270+ Nothing ->
271+ Name.toBuilder name
272+
273+ Just expr ->
274+ Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
298275
299276
300277
@@ -312,11 +289,12 @@ merge a b =
312289linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
313290linesMap func xs =
314291 let
315− pairs = map func xs
292+ pairs =
293+ map func xs
316294 in
317− ( any ((==) Many . fst) pairs
318− , map snd pairs
319− )
295+ ( any ((==) Many . fst) pairs
296+ , map snd pairs
297+ )
320298
321299
322300data Grouping = Atomic | Whatever
@@ -332,23 +310,23 @@ parensFor grouping builder =
332310 builder
333311
334312
335−fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
336−fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
313+fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
314+fromExpr indent grouping expression =
337315 case expression of
338316 String string ->
339− ( One, "'" <> string <> "'" )
317+ (One, "'" <> string <> "'")
340318
341319 Float float ->
342− ( One, float )
320+ (One, float)
343321
344322 Int n ->
345− ( One, B.intDec n )
323+ (One, B.intDec n)
346324
347325 Bool bool ->
348− ( One, if bool then "true" else "false" )
326+ (One, if bool then "true" else "false")
349327
350328 Null ->
351− ( One, "null" )
329+ (One, "null")
352330
353331 Json json ->
354332 ( One, Json.encodeUgly json )
@@ -356,90 +334,111 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi
356334 Array exprs ->
357335 (,) Many $
358336 let
359− (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
337+ (anyMany, builders) =
338+ linesMap (fromExpr indent Whatever) exprs
360339 in
361− if anyMany then
362− "[\n"
363− <> deeperIndent
364− <> commaNewlineSep level builders
365− <> "\n" <> indent <> "]"
366− else
367− "[" <> commaSep builders <> "]"
340+ if anyMany then
341+ "[\n"
342+ <> deeper indent
343+ <> commaNewlineSep indent builders
344+ <> "\n" <> indent <> "]"
345+
346+ else
347+ "[" <> commaSep builders <> "]"
368348
369349 Object fields ->
370350 (,) Many $
371351 let
372− (anyMany, builders) = linesMap (fromField nextLevel) fields
352+ deeperIndent =
353+ deeper indent
354+
355+ (anyMany, builders) =
356+ linesMap (fromField deeperIndent) fields
373357 in
374− if anyMany then
375− "{\n"
376− <> deeperIndent
377− <> commaNewlineSep level builders
378− <> "\n" <> indent <> "}"
379− else
380− "{" <> commaSep builders <> "}"
358+ if anyMany then
359+ "{\n"
360+ <> deeperIndent
361+ <> commaNewlineSep indent builders
362+ <> "\n" <> indent <> "}"
363+
364+ else
365+ "{" <> commaSep builders <> "}"
381366
382367 Ref name ->
383− ( One, Name.toBuilder name )
368+ (One, Name.toBuilder name)
384369
385370 Access expr field ->
386− makeDot level expr field
371+ makeDot indent expr field
387372
388373 Index expr bracketedExpr ->
389− makeBracketed level expr bracketedExpr
374+ makeBracketed indent expr bracketedExpr
390375
391376 Prefix op expr ->
392377 let
393− (lines, builder) = fromExpr level Atomic expr
378+ (lines, builder) =
379+ fromExpr indent Atomic expr
394380 in
395− ( lines
396− , parensFor grouping (fromPrefix op <> builder)
397− )
381+ ( lines
382+ , parensFor grouping (fromPrefix op <> builder)
383+ )
398384
399385 Infix op leftExpr rightExpr ->
400386 let
401− (leftLines , left ) = fromExpr level Atomic leftExpr
402− (rightLines, right) = fromExpr level Atomic rightExpr
387+ (leftLines, left) =
388+ fromExpr indent Atomic leftExpr
389+
390+ (rightLines, right) =
391+ fromExpr indent Atomic rightExpr
403392 in
404− ( merge leftLines rightLines
405− , parensFor grouping (left <> fromInfix op <> right)
406− )
393+ ( merge leftLines rightLines
394+ , parensFor grouping (left <> fromInfix op <> right)
395+ )
407396
408397 If condExpr thenExpr elseExpr ->
409398 let
410− condB = snd (fromExpr level Atomic condExpr)
411− thenB = snd (fromExpr level Atomic thenExpr)
412− elseB = snd (fromExpr level Atomic elseExpr)
399+ condB = snd (fromExpr indent Atomic condExpr)
400+ thenB = snd (fromExpr indent Atomic thenExpr)
401+ elseB = snd (fromExpr indent Atomic elseExpr)
413402 in
414− ( Many
415− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
416− )
403+ ( Many
404+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
405+ )
417406
418407 Assign lValue expr ->
419408 let
420− (leftLines , left ) = fromLValue level lValue
421− (rightLines, right) = fromExpr level Whatever expr
409+ (leftLines, left) =
410+ fromLValue indent lValue
411+
412+ (rightLines, right) =
413+ fromExpr indent Whatever expr
422414 in
423− ( merge leftLines rightLines
424− , parensFor grouping (left <> " = " <> right)
425− )
415+ ( merge leftLines rightLines
416+ , parensFor grouping (left <> " = " <> right)
417+ )
426418
427419 Call function args ->
428420 (,) Many $
429421 let
430− (_ , funcB) = fromExpr level Atomic function
431− (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
422+ deeperIndent =
423+ deeper indent
424+
425+ funcB =
426+ snd (fromExpr indent Atomic function)
427+
428+ (anyMany, argsB) =
429+ linesMap (fromExpr deeperIndent Whatever) args
432430 in
433− if anyMany then
434− funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
435− else
436− funcB <> "(" <> commaSep argsB <> ")"
431+ if anyMany then
432+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
433+
434+ else
435+ funcB <> "(" <> commaSep argsB <> ")"
437436
438437 Function maybeName args stmts ->
439438 (,) Many $
440439 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
441440 <>
442− fromStmtBlock nextLevel stmts
441+ fromStmtBlock (deeper indent) stmts
443442 <>
444443 indent <> "}"
445444
@@ -448,50 +447,55 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi
448447-- FIELDS
449448
450449
451−fromField :: Level -> (Name, Expr) -> (Lines, Builder)
452−fromField level (field, expr) =
450+fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
451+fromField indent (field, expr) =
453452 let
454− (lines, builder) = fromExpr level Whatever expr
453+ (lines, builder) =
454+ fromExpr indent Whatever expr
455455 in
456− ( lines
457− , Name.toBuilder field <> ": " <> builder
458− )
456+ ( lines
457+ , Name.toBuilder field <> ": " <> builder
458+ )
459459
460460
461461
462462-- VALUES
463463
464464
465−fromLValue :: Level -> LValue -> (Lines, Builder)
466−fromLValue level lValue =
465+fromLValue :: Builder -> LValue -> (Lines, Builder)
466+fromLValue indent lValue =
467467 case lValue of
468468 LRef name ->
469469 (One, Name.toBuilder name)
470470
471471 LDot expr field ->
472− makeDot level expr field
472+ makeDot indent expr field
473473
474474 LBracket expr bracketedExpr ->
475− makeBracketed level expr bracketedExpr
475+ makeBracketed indent expr bracketedExpr
476476
477477
478−makeDot :: Level -> Expr -> Name -> (Lines, Builder)
479−makeDot level expr field =
478+makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
479+makeDot indent expr field =
480480 let
481− (lines, builder) = fromExpr level Atomic expr
481+ (lines, builder) =
482+ fromExpr indent Atomic expr
482483 in
483− (lines, builder <> "." <> Name.toBuilder field)
484+ (lines, builder <> "." <> Name.toBuilder field)
484485
485486
486−makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
487−makeBracketed level expr bracketedExpr =
487+makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
488+makeBracketed indent expr bracketedExpr =
488489 let
489− (lines , builder ) = fromExpr level Atomic expr
490− (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
490+ (lines, builder) =
491+ fromExpr indent Atomic expr
492+
493+ (bracketedLines, bracketedBuilder) =
494+ fromExpr indent Whatever bracketedExpr
491495 in
492− ( merge lines bracketedLines
493− , builder <> "[" <> bracketedBuilder <> "]"
494− )
496+ ( merge lines bracketedLines
497+ , builder <> "[" <> bracketedBuilder <> "]"
498+ )
495499
496500
497501
@@ -501,30 +505,36 @@ makeBracketed level expr bracketedExpr =
501505fromPrefix :: PrefixOp -> Builder
502506fromPrefix op =
503507 case op of
504− PrefixNot -> "!"
505− PrefixNegate -> "-"
506− PrefixComplement -> "~"
508+ PrefixLNot -> "!"
509+ PrefixBNot -> "~"
510+ PrefixPlus -> "+"
511+ PrefixMinus -> "-"
512+ PrefixTypeof -> "typeof "
507513
508514
509515fromInfix :: InfixOp -> Builder
510516fromInfix op =
511517 case op of
512− OpAdd -> " + "
513− OpSub -> " - "
518+ OpLT -> " < "
519+ OpLEq -> " <= "
520+ OpGT -> " > "
521+ OpGEq -> " >= "
522+ OpIn -> " in "
523+ OpInstanceof -> " instanceof "
524+ OpEq -> " == "
525+ OpNEq -> " != "
526+ OpStrictEq -> " === "
527+ OpStrictNEq -> " !== "
528+ OpLAnd -> " && "
529+ OpLOr -> " || "
514530 OpMul -> " * "
515531 OpDiv -> " / "
516532 OpMod -> " % "
517− OpEq -> " === "
518− OpNe -> " !== "
519− OpLt -> " < "
520− OpLe -> " <= "
521− OpGt -> " > "
522− OpGe -> " >= "
523− OpAnd -> " && "
524− OpOr -> " || "
525− OpBitwiseAnd -> " & "
526− OpBitwiseXor -> " ^ "
527− OpBitwiseOr -> " | "
533+ OpSub -> " - "
528534 OpLShift -> " << "
529535 OpSpRShift -> " >> "
530536 OpZfRShift -> " >>> "
537+ OpBAnd -> " & "
538+ OpBXor -> " ^ "
539+ OpBOr -> " | "
540+ OpAdd -> " + "
compiler/src/Generate/JavaScript/Expression.hs+45−46
@@ -22,7 +22,6 @@ import qualified Data.Utf8 as Utf8
2222
2323import qualified AST.Canonical as Can
2424import qualified AST.Optimized as Opt
25−import qualified AST.Utils.Shader as Shader
2625import qualified Data.Index as Index
2726import qualified Elm.Compiler.Type as Type
2827import qualified Elm.Compiler.Type.Extract as Extract
@@ -33,7 +32,6 @@ import qualified Generate.JavaScript.Builder as JS
3332import qualified Generate.JavaScript.Name as JsName
3433import qualified Generate.Mode as Mode
3534import qualified Json.Encode as Encode
36−import Json.Encode ((==>))
3735import qualified Optimize.DecisionTree as DT
3836import qualified Reporting.Annotation as A
3937
@@ -130,7 +128,8 @@ generate mode expression =
130128
131129 Opt.Destruct (Opt.Destructor name path) body ->
132130 let
133− pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
131+ pathExpr = generatePath mode path
132+ pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]
134133 in
135134 JsBlock $ pathDef : codeToStmtList (generate mode body)
136135
@@ -139,7 +138,7 @@ generate mode expression =
139138
140139 Opt.Accessor field ->
141140 JsExpr $ JS.Function Nothing [JsName.dollar]
142− [ JS.Return $
141+ [ JS.Return $ Just $
143142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
144143 ]
145144
@@ -191,7 +190,7 @@ generate mode expression =
191190 JS.Object (map toTranlation (Set.toList fields))
192191 in
193192 JsExpr $ JS.Object $
194− [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
193+ [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
195194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
196195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
197196 ]
@@ -212,7 +211,7 @@ codeToExpr code =
212211 JsExpr expr ->
213212 expr
214213
215− JsBlock [ JS.Return expr ] ->
214+ JsBlock [ JS.Return (Just expr) ] ->
216215 expr
217216
218217 JsBlock stmts ->
@@ -226,7 +225,7 @@ codeToStmtList code =
226225 stmts
227226
228227 JsExpr expr ->
229− [ JS.Return expr ]
228+ [ JS.Return (Just expr) ]
230229
231230 JsBlock stmts ->
232231 stmts
@@ -239,7 +238,7 @@ codeToStmt code =
239238 JS.Block stmts
240239
241240 JsExpr expr ->
242− JS.Return expr
241+ JS.Return (Just expr)
243242
244243 JsBlock [stmt] ->
245244 stmt
@@ -483,17 +482,17 @@ generateBitwiseCall home name args =
483482 case args of
484483 [arg] ->
485484 case name of
486− "complement" -> JS.Prefix JS.PrefixComplement arg
485+ "complement" -> JS.Prefix JS.PrefixBNot arg
487486 _ -> generateGlobalCall home name args
488487
489488 [left,right] ->
490489 case name of
491− "and" -> JS.Infix JS.OpBitwiseAnd left right
492− "or" -> JS.Infix JS.OpBitwiseOr left right
493− "xor" -> JS.Infix JS.OpBitwiseXor left right
494− "shiftLeftBy" -> JS.Infix JS.OpLShift right left
495− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
496− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
490+ "and" -> JS.Infix JS.OpBAnd left right
491+ "or" -> JS.Infix JS.OpBOr left right
492+ "xor" -> JS.Infix JS.OpBXor left right
493+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left
494+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
495+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
497496 _ -> generateGlobalCall home name args
498497
499498 _ ->
@@ -506,10 +505,10 @@ generateBasicsCall mode home name args =
506505 [elmArg] ->
507506 let arg = generateJsExpr mode elmArg in
508507 case name of
509− "not" -> JS.Prefix JS.PrefixNot arg
510− "negate" -> JS.Prefix JS.PrefixNegate arg
508+ "not" -> JS.Prefix JS.PrefixLNot arg
509+ "negate" -> JS.Prefix JS.PrefixMinus arg
511510 "toFloat" -> arg
512− "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
511+ "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
513512 _ -> generateGlobalCall home name [arg]
514513
515514 [elmLeft, elmRight] ->
@@ -529,16 +528,16 @@ generateBasicsCall mode home name args =
529528 "sub" -> JS.Infix JS.OpSub left right
530529 "mul" -> JS.Infix JS.OpMul left right
531530 "fdiv" -> JS.Infix JS.OpDiv left right
532− "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
531+ "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
533532 "eq" -> equal left right
534533 "neq" -> notEqual left right
535− "lt" -> cmp JS.OpLt JS.OpLt 0 left right
536− "gt" -> cmp JS.OpGt JS.OpGt 0 left right
537− "le" -> cmp JS.OpLe JS.OpLt 1 left right
538− "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
539− "or" -> JS.Infix JS.OpOr left right
540− "and" -> JS.Infix JS.OpAnd left right
541− "xor" -> JS.Infix JS.OpNe left right
534+ "lt" -> cmp JS.OpLT JS.OpLT 0 left right
535+ "gt" -> cmp JS.OpGT JS.OpGT 0 left right
536+ "le" -> cmp JS.OpLEq JS.OpLT 1 left right
537+ "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
538+ "or" -> JS.Infix JS.OpLOr left right
539+ "and" -> JS.Infix JS.OpLAnd left right
540+ "xor" -> JS.Infix JS.OpStrictNEq left right
542541 "remainderBy" -> JS.Infix JS.OpMod right left
543542 _ -> generateGlobalCall home name [left, right]
544543
@@ -559,7 +558,7 @@ notEqual left right =
559558 if isLiteral left || isLiteral right then
560559 strictNEq left right
561560 else
562− JS.Prefix JS.PrefixNot $
561+ JS.Prefix JS.PrefixLNot $
563562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
564563
565564
@@ -648,42 +647,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr
648647strictEq left right =
649648 case left of
650649 JS.Int 0 ->
651− JS.Prefix JS.PrefixNot right
650+ JS.Prefix JS.PrefixLNot right
652651
653652 JS.Bool bool ->
654− if bool then right else JS.Prefix JS.PrefixNot right
653+ if bool then right else JS.Prefix JS.PrefixLNot right
655654
656655 _ ->
657656 case right of
658657 JS.Int 0 ->
659− JS.Prefix JS.PrefixNot left
658+ JS.Prefix JS.PrefixLNot left
660659
661660 JS.Bool bool ->
662− if bool then left else JS.Prefix JS.PrefixNot left
661+ if bool then left else JS.Prefix JS.PrefixLNot left
663662
664663 _ ->
665− JS.Infix JS.OpEq left right
664+ JS.Infix JS.OpStrictEq left right
666665
667666
668667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
669668strictNEq left right =
670669 case left of
671670 JS.Int 0 ->
672− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
671+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)
673672
674673 JS.Bool bool ->
675− if bool then JS.Prefix JS.PrefixNot right else right
674+ if bool then JS.Prefix JS.PrefixLNot right else right
676675
677676 _ ->
678677 case right of
679678 JS.Int 0 ->
680− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
679+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)
681680
682681 JS.Bool bool ->
683− if bool then JS.Prefix JS.PrefixNot left else left
682+ if bool then JS.Prefix JS.PrefixLNot left else left
684683
685684 _ ->
686− JS.Infix JS.OpNe left right
685+ JS.Infix JS.OpStrictNEq left right
687686
688687
689688
@@ -696,13 +695,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm
696695generateTailCall mode name args =
697696 let
698697 toTempVars (argName, arg) =
699− ( JsName.makeTemp argName, generateJsExpr mode arg )
698+ ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )
700699
701700 toRealVars (argName, _) =
702701 JS.ExprStmt $
703702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
704703 in
705− JS.Vars (map toTempVars args)
704+ JS.Var (map toTempVars args)
706705 : map toRealVars args
707706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
708707
@@ -715,10 +714,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
715714generateDef mode def =
716715 case def of
717716 Opt.Def name body ->
718− JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
717+ JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]
719718
720719 Opt.TailDef name argNames body ->
721− JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
720+ JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
722721
723722
724723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
@@ -851,7 +850,7 @@ generateDecider mode label root decisionTree =
851850
852851 Opt.Chain testChain success failure ->
853852 [ JS.IfStmt
854− (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
853+ (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
855854 (JS.Block $ generateDecider mode label root success)
856855 (JS.Block $ generateDecider mode label root failure)
857856 ]
@@ -893,7 +892,7 @@ generateIfTest mode root (path, test) =
893892 value
894893
895894 DT.IsBool False ->
896− JS.Prefix JS.PrefixNot value
895+ JS.Prefix JS.PrefixLNot value
897896
898897 DT.IsInt int ->
899898 strictEq value (JS.Int int)
@@ -911,7 +910,7 @@ generateIfTest mode root (path, test) =
911910 JS.Access value (JsName.fromLocal "b")
912911
913912 DT.IsNil ->
914− JS.Prefix JS.PrefixNot $
913+ JS.Prefix JS.PrefixLNot $
915914 JS.Access value (JsName.fromLocal "b")
916915
917916 DT.IsTuple ->
@@ -1065,6 +1064,6 @@ toDebugMetadata mode msgType =
10651064
10661065 Mode.Dev (Just interfaces) ->
10671066 JS.Json $ Encode.object $
1068− [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1069− , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
1067+ [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1068+ , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
10701069 ]
compiler/src/Generate/JavaScript/Functions.hs+3−2
@@ -1,5 +1,6 @@
1−{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2−module Generate.JavaScript.Functions
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+module Generate.Functions
34 ( functions
45 )
56 where
compiler/src/Generate/JavaScript/Name.hs+12−22
@@ -62,13 +62,19 @@ fromLocal name =
6262
6363
6464fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
65−fromGlobal home name =
66− Name $ homeToBuilder home <> usd <> Name.toBuilder name
65+fromGlobal (ModuleName.Canonical (Pkg.Name author project) home) name =
66+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
67+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
68+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
69+ <> "$" <> Name.toBuilder name
6770
6871
6972fromCycle :: ModuleName.Canonical -> Name.Name -> Name
70−fromCycle home name =
71− Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name
73+fromCycle (ModuleName.Canonical (Pkg.Name author project) home) name =
74+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
75+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
76+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
77+ <> "$cyclic$" <> Name.toBuilder name
7278
7379
7480fromKernel :: Name.Name -> Name.Name -> Name
@@ -76,17 +82,6 @@ fromKernel home name =
7682 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
7783
7884
79−{-# INLINE homeToBuilder #-}
80−homeToBuilder :: ModuleName.Canonical -> B.Builder
81−homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =
82− usd <>
83− Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
84− <> usd <>
85− Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
86− <> usd <>
87− Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
88−
89−
9085
9186-- TEMPORARY NAMES
9287
@@ -103,7 +98,7 @@ makeA n =
10398
10499makeLabel :: Name.Name -> Int -> Name
105100makeLabel name index =
106− Name (Name.toBuilder name <> usd <> B.intDec index)
101+ Name (Name.toBuilder name <> "$" <> B.intDec index)
107102
108103
109104makeTemp :: Name.Name -> Name
@@ -113,12 +108,7 @@ makeTemp name =
113108
114109dollar :: Name
115110dollar =
116− Name usd
117−
118−
119−usd :: B.Builder
120−usd =
121− Name.toBuilder Name.dollar
111+ Name (Name.toBuilder Name.dollar)
122112
123113
124114
compiler/src/Generate/Mode.hs+3−2
@@ -41,14 +41,15 @@ type ShortFieldNames =
4141 Map.Map Name.Name JsName.Name
4242
4343
44−shortenFieldNames :: Opt.GlobalGraph -> ShortFieldNames
45−shortenFieldNames (Opt.GlobalGraph _ frequencies) =
44+shortenFieldNames :: Opt.Graph -> ShortFieldNames
45+shortenFieldNames (Opt.Graph _ _ frequencies) =
4646 Map.foldr addToShortNames Map.empty $
4747 Map.foldrWithKey addToBuckets Map.empty frequencies
4848
4949
5050addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
5151addToBuckets field frequency buckets =
52+ -- TODO try using an IntMap for buckets
5253 Map.insertWith (++) frequency [field] buckets
5354
5455
compiler/src/Json/Decode.hs+180−333
@@ -2,112 +2,69 @@
22{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
33module Json.Decode
44 ( fromByteString
5+ , fromFile
56 , Decoder
67 , string
7− , customString
88 , bool
99 , int
10− , list
11− , nonEmptyList
12− , pair
13− --
14− , KeyDecoder(..)
15− , dict
16− , pairs
17− , field
18− --
10+ , list, pair
11+ , dict, pairs, field
1912 , oneOf
2013 , failure
2114 , mapError
22− --
23− , Error(..)
24− , Problem(..)
25− , DecodeExpectation(..)
26− , ParseError(..)
27− , StringProblem(..)
2815 )
2916 where
3017
3118
32−import qualified Data.ByteString.Internal as B
19+import qualified Data.ByteString as B
20+import qualified Data.List as List
3321import qualified Data.Map as Map
34−import qualified Data.NonEmptyList as NE
35−import Data.Word (Word8)
22+import qualified Data.Utf8 as Utf8
23+import Data.Word (Word8, Word16)
3624import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
3825
39−import qualified Json.String as Json
4026import qualified Parse.Keyword as K
4127import qualified Parse.Primitives as P
42−import Parse.Primitives (Row, Col)
43−import qualified Reporting.Annotation as A
28+import qualified Reporting.Error.Json as E
4429
4530
4631
4732-- RUNNERS
4833
4934
50−fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
51−fromByteString (Decoder decode) src =
52− case P.fromByteString pFile BadEnd src of
53− Right ast ->
54− decode ast Right (Left . DecodeProblem src)
35+fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
36+fromByteString decoder src =
37+ fromAST decoder (P.fromByteString pFile src)
5538
56− Left problem ->
57− Left (ParseProblem src problem)
5839
40+fromFile :: Decoder e a -> FilePath -> IO (Either (E.Error e) a)
41+fromFile decoder path =
42+ fromAST decoder <$> P.fromFile pFile path
5943
6044
61−-- DECODERS
62−
63−
64−newtype Decoder x a =
65− Decoder
66− (
67− forall b.
68− AST
69− -> (a -> b)
70− -> (Problem x -> b)
71− -> b
72− )
73−
74−
75−
76−-- ERRORS
77−
78−
79−data Error x
80− = DecodeProblem B.ByteString (Problem x)
81− | ParseProblem B.ByteString ParseError
45+fromAST :: Decoder e a -> P.Result E.Context E.ParseExpectation AST -> Either (E.Error e) a
46+fromAST (Decoder decode) parserResult =
47+ case parserResult of
48+ P.Ok ast _ ->
49+ decode ast Right (Left . E.DecodeProblem)
8250
51+ P.Err row col ctx expectation ->
52+ Left (E.ParseProblem row col ctx expectation)
8353
8454
85−-- DECODE PROBLEMS
8655
87−
88−data Problem x
89− = Field B.ByteString (Problem x)
90− | Index Int (Problem x)
91− | OneOf (Problem x) [Problem x]
92− | Failure A.Region x
93− | Expecting A.Region DecodeExpectation
56+-- DECODERS
9457
9558
96−data DecodeExpectation
97− = TObject
98− | TArray
99− | TString
100− | TBool
101− | TInt
102− | TObjectWith B.ByteString
103− | TArrayPair Int
59+newtype Decoder e a =
60+ Decoder (forall b. AST -> (a -> b) -> (E.Problem e -> b) -> b)
10461
10562
10663
10764-- INSTANCES
10865
10966
110−instance Functor (Decoder x) where
67+instance Functor (Decoder e) where
11168 {-# INLINE fmap #-}
11269 fmap func (Decoder decodeA) =
11370 Decoder $ \ast ok err ->
@@ -117,7 +74,7 @@ instance Functor (Decoder x) where
11774 decodeA ast ok' err
11875
11976
120−instance Applicative (Decoder x) where
77+instance Applicative (Decoder e) where
12178 {-# INLINE pure #-}
12279 pure = return
12380
@@ -134,7 +91,7 @@ instance Applicative (Decoder x) where
13491 decodeFunc ast okF err
13592
13693
137−instance Monad (Decoder x) where
94+instance Monad (Decoder e) where
13895 {-# INLINE return #-}
13996 return a =
14097 Decoder $ \_ ok _ ->
@@ -155,37 +112,24 @@ instance Monad (Decoder x) where
155112-- STRINGS
156113
157114
158−string :: Decoder x Json.String
115+string :: Decoder e Utf8.String
159116string =
160− Decoder $ \(A.At region ast) ok err ->
161− case ast of
162− String snippet ->
163− ok (Json.fromSnippet snippet)
164−
165− _ ->
166− err (Expecting region TString)
167−
168−
169−customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
170−customString parser toBadEnd =
171− Decoder $ \(A.At region ast) ok err ->
117+ Decoder $ \ast ok err ->
172118 case ast of
173− String snippet ->
174− case P.fromSnippet parser toBadEnd snippet of
175− Right a -> ok a
176− Left x -> err (Failure region x)
119+ String bits ->
120+ ok bits
177121
178122 _ ->
179− err (Expecting region TString)
123+ err (E.Expecting E.TString)
180124
181125
182126
183127-- BOOL
184128
185129
186−bool :: Decoder x Bool
130+bool :: Decoder e Bool
187131bool =
188− Decoder $ \(A.At region ast) ok err ->
132+ Decoder $ \ast ok err ->
189133 case ast of
190134 TRUE ->
191135 ok True
@@ -194,40 +138,40 @@ bool =
194138 ok False
195139
196140 _ ->
197− err (Expecting region TBool)
141+ err (E.Expecting E.TBool)
198142
199143
200144
201145-- INT
202146
203147
204−int :: Decoder x Int
148+int :: Decoder e Int
205149int =
206− Decoder $ \(A.At region ast) ok err ->
150+ Decoder $ \ast ok err ->
207151 case ast of
208152 Int n ->
209153 ok n
210154
211155 _ ->
212− err (Expecting region TInt)
156+ err (E.Expecting E.TInt)
213157
214158
215159
216−-- LISTS
160+-- ARRAYS
217161
218162
219−list :: Decoder x a -> Decoder x [a]
163+list :: Decoder e a -> Decoder e [a]
220164list decoder =
221− Decoder $ \(A.At region ast) ok err ->
165+ Decoder $ \ast ok err ->
222166 case ast of
223167 Array asts ->
224168 listHelp decoder ok err 0 asts []
225169
226170 _ ->
227− err (Expecting region TArray)
171+ err (E.Expecting E.TArray)
228172
229173
230−listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
174+listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
231175listHelp decoder@(Decoder decodeA) ok err !i asts revs =
232176 case asts of
233177 [] ->
@@ -235,40 +179,24 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
235179
236180 ast:asts ->
237181 let
238− ok' value = listHelp decoder ok err (i+1) asts (value:revs)
239− err' prob = err (Index i prob)
182+ ok' a = listHelp decoder ok err (i+1) asts (a:revs)
183+ err' e = err (E.Index i e)
240184 in
241185 decodeA ast ok' err'
242186
243187
244−
245−-- NON-EMPTY LISTS
246−
247−
248−nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
249−nonEmptyList decoder x =
250− do values <- list decoder
251− case values of
252− v:vs -> return (NE.List v vs)
253− [] -> failure x
254−
255−
256−
257−-- PAIR
258−
259−
260−pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
188+pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
261189pair (Decoder decodeA) (Decoder decodeB) =
262− Decoder $ \(A.At region ast) ok err ->
190+ Decoder $ \ast ok err ->
263191 case ast of
264192 Array vs ->
265193 case vs of
266194 [astA,astB] ->
267195 let
268− err0 e = err (Index 0 e)
196+ err0 e = err (E.Index 0 e)
269197 ok0 a =
270198 let
271− err1 e = err (Index 1 e)
199+ err1 e = err (E.Index 1 e)
272200 ok1 b = ok (a,b)
273201 in
274202 decodeB astB ok1 err1
@@ -276,103 +204,70 @@ pair (Decoder decodeA) (Decoder decodeB) =
276204 decodeA astA ok0 err0
277205
278206 _ ->
279− err (Expecting region (TArrayPair (length vs)))
207+ err (E.Expecting (E.TArrayPair (length vs)))
280208
281209 _ ->
282− err (Expecting region TArray)
283−
284−
210+ err (E.Expecting E.TArray)
285211
286−-- OBJECTS
287212
288213
289−data KeyDecoder x a =
290− KeyDecoder (P.Parser x a) (Row -> Col -> x)
214+-- OBJECT
291215
292216
293−dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
294−dict keyDecoder valueDecoder =
295− Map.fromList <$> pairs keyDecoder valueDecoder
217+dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
218+dict decoder =
219+ Map.fromList <$> pairs decoder
296220
297221
298−pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
299−pairs keyDecoder valueDecoder =
300− Decoder $ \(A.At region ast) ok err ->
222+pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
223+pairs decoder =
224+ Decoder $ \ast ok err ->
301225 case ast of
302226 Object kvs ->
303− pairsHelp keyDecoder valueDecoder ok err kvs []
227+ pairsHelp decoder ok err kvs []
304228
305229 _ ->
306− err (Expecting region TObject)
230+ err (E.Expecting E.TObject)
307231
308232
309−pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
310−pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
233+pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
234+pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
311235 case kvs of
312236 [] ->
313237 ok (reverse revs)
314238
315− (snippet, ast) : kvs ->
316− case P.fromSnippet keyParser toBadEnd snippet of
317− Left x ->
318− err (Failure (snippetToRegion snippet) x)
319−
320− Right key ->
321− let
322− ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
323− err' prob =
324− let (P.Snippet fptr off len _ _) = snippet in
325− err (Field (B.PS fptr off len) prob)
326− in
327− decodeA ast ok' err'
328−
329−
330−snippetToRegion :: P.Snippet -> A.Region
331−snippetToRegion (P.Snippet _ _ len row col) =
332− A.Region (A.Position row col) (A.Position row (col + fromIntegral len))
333−
334−
335−
336−-- FIELDS
239+ (key, ast) : kvs ->
240+ let
241+ ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
242+ err' e = err (E.Field key e)
243+ in
244+ decodeA ast ok' err'
337245
338246
339−field :: B.ByteString -> Decoder x a -> Decoder x a
247+field :: Utf8.String -> Decoder e a -> Decoder e a
340248field key (Decoder decodeA) =
341− Decoder $ \(A.At region ast) ok err ->
249+ Decoder $ \ast ok err ->
342250 case ast of
343251 Object kvs ->
344− case findField key kvs of
345− Just value ->
252+ case List.lookup key kvs of
253+ Just v ->
346254 let
347− err' prob =
348− err (Field key prob)
255+ err' e = err (E.Field key e)
349256 in
350− decodeA value ok err'
257+ decodeA v ok err'
351258
352259 Nothing ->
353− err (Expecting region (TObjectWith key))
260+ err (E.Expecting (E.TObjectWith key))
354261
355262 _ ->
356− err (Expecting region TObject)
357−
358−
359−findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
360−findField key pairs =
361− case pairs of
362− [] ->
363− Nothing
364−
365− (P.Snippet fptr off len _ _, value) : remainingPairs ->
366− if key == B.PS fptr off len
367− then Just value
368− else findField key remainingPairs
263+ err (E.Expecting E.TObject)
369264
370265
371266
372267-- ONE OF
373268
374269
375−oneOf :: [Decoder x a] -> Decoder x a
270+oneOf :: [Decoder e a] -> Decoder e a
376271oneOf decoders =
377272 Decoder $ \ast ok err ->
378273 case decoders of
@@ -387,75 +282,71 @@ oneOf decoders =
387282 error "Ran into (Json.Decode.oneOf [])"
388283
389284
390−oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
391−oneOfHelp ast ok err decoders p ps =
285+oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
286+oneOfHelp ast ok err decoders e es =
392287 case decoders of
393288 Decoder decodeA : decoders ->
394289 let
395− err' p' =
396− oneOfHelp ast ok err decoders p' (p:ps)
290+ err' e' =
291+ oneOfHelp ast ok err decoders e' (e:es)
397292 in
398293 decodeA ast ok err'
399294
400295 [] ->
401− err (oneOfError [] p ps)
296+ err (oneOfError [] e es)
402297
403298
404−oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
405−oneOfError problems prob ps =
406− case ps of
299+oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
300+oneOfError errors err es =
301+ case es of
407302 [] ->
408− OneOf prob problems
303+ E.OneOf err errors
409304
410− p:ps ->
411− oneOfError (prob:problems) p ps
305+ e:es ->
306+ oneOfError (err:errors) e es
412307
413308
414309
415310-- FAILURE
416311
417312
418−failure :: x -> Decoder x a
419−failure x =
420− Decoder $ \(A.At region _) _ err ->
421− err (Failure region x)
313+failure :: e -> Decoder e a
314+failure e =
315+ Decoder $ \_ _ err ->
316+ err (E.Failure e)
422317
423318
424319
425320-- ERRORS
426321
427322
428−mapError :: (x -> y) -> Decoder x a -> Decoder y a
323+mapError :: (e -> e') -> Decoder e a -> Decoder e' a
429324mapError func (Decoder decodeA) =
430325 Decoder $ \ast ok err ->
431326 let
432− err' prob = err (mapErrorHelp func prob)
327+ err' e = err (mapErrorHelp func e)
433328 in
434329 decodeA ast ok err'
435330
436331
437−mapErrorHelp :: (x -> y) -> Problem x -> Problem y
438−mapErrorHelp func problem =
439− case problem of
440− Field k p -> Field k (mapErrorHelp func p)
441− Index i p -> Index i (mapErrorHelp func p)
442− OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
443− Failure r x -> Failure r (func x)
444− Expecting r e -> Expecting r e
332+mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
333+mapErrorHelp func err =
334+ case err of
335+ E.Field k e -> E.Field k (mapErrorHelp func e)
336+ E.Index i e -> E.Index i (mapErrorHelp func e)
337+ E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
338+ E.Failure e -> E.Failure (func e)
339+ E.Expecting e -> E.Expecting e
445340
446341
447342
448343-- AST
449344
450345
451−type AST =
452− A.Located AST_
453−
454−
455−data AST_
346+data AST
456347 = Array [AST]
457− | Object [(P.Snippet, AST)]
458− | String P.Snippet
348+ | Object [(Utf8.String, AST)]
349+ | String Utf8.String
459350 | Int Int
460351 | TRUE
461352 | FALSE
@@ -467,33 +358,7 @@ data AST_
467358
468359
469360type Parser a =
470− P.Parser ParseError a
471−
472−
473−data ParseError
474− = Start Row Col
475− | ObjectField Row Col
476− | ObjectColon Row Col
477− | ObjectEnd Row Col
478− | ArrayEnd Row Col
479− | StringProblem StringProblem Row Col
480− | NoLeadingZeros Row Col
481− | NoFloats Row Col
482− | BadEnd Row Col
483−
484−-- PIndex Int ParseError Row Col
485−-- PField Json.String ParseError Row Col
486−
487−
488−data StringProblem
489− = BadStringEnd
490− | BadStringControlChar
491− | BadStringEscapeChar
492− | BadStringEscapeHex
493−
494−
495−
496−-- PARSE AST
361+ P.Parser E.Context E.ParseExpectation a
497362
498363
499364pFile :: Parser AST
@@ -501,60 +366,69 @@ pFile =
501366 do spaces
502367 value <- pValue
503368 spaces
369+ endOfFile
504370 return value
505371
506372
507373pValue :: Parser AST
508374pValue =
509− P.addLocation $
510− P.oneOf Start
511− [ String <$> pString Start
375+ P.oneOf E.Value
376+ [ fmap String pString
512377 , pObject
513378 , pArray
514379 , pInt
515− , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
516− , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
517− , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
380+ , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
381+ , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
382+ , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
518383 ]
519384
520385
386+endOfFile :: Parser ()
387+endOfFile =
388+ P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->
389+ if pos < end then
390+ eerr row col ctx E.EndOfFile
391+ else
392+ eok () state
393+
394+
521395
522396-- OBJECT
523397
524398
525−pObject :: Parser AST_
399+pObject :: Parser AST
526400pObject =
527− do P.word1 0x7B {- { -} Start
401+ do P.word1 0x7B {- { -} E.ObjectStart
528402 spaces
529− P.oneOf ObjectField
403+ P.oneOf E.ObjectMore
530404 [ do entry <- pField
531405 spaces
532406 pObjectHelp [entry]
533− , do P.word1 0x7D {-}-} ObjectEnd
407+ , do P.word1 0x7D {-}-} E.ObjectEnd
534408 return (Object [])
535409 ]
536410
537411
538−pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
412+pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
539413pObjectHelp revEntries =
540− P.oneOf ObjectEnd
414+ P.oneOf E.ObjectMore
541415 [
542− do P.word1 0x2C {-,-} ObjectEnd
416+ do P.word1 0x2C {-,-} E.ObjectMore
543417 spaces
544418 entry <- pField
545419 spaces
546420 pObjectHelp (entry:revEntries)
547421 ,
548− do P.word1 0x7D {-}-} ObjectEnd
422+ do P.word1 0x7D {-}-} E.ObjectEnd
549423 return (Object (reverse revEntries))
550424 ]
551425
552426
553−pField :: Parser (P.Snippet, AST)
427+pField :: Parser (Utf8.String, AST)
554428pField =
555− do key <- pString ObjectField
429+ do key <- pString
556430 spaces
557− P.word1 0x3A {-:-} ObjectColon
431+ P.word1 0x3A {-:-} E.Colon
558432 spaces
559433 value <- pValue
560434 return (key, value)
@@ -564,30 +438,30 @@ pField =
564438-- ARRAY
565439
566440
567−pArray :: Parser AST_
441+pArray :: Parser AST
568442pArray =
569− do P.word1 0x5B {-[-} Start
443+ do P.word1 0x5B {-[-} E.ArrayStart
570444 spaces
571− P.oneOf Start
445+ P.oneOf E.ArrayMore
572446 [ do entry <- pValue
573447 spaces
574448 pArrayHelp 1 [entry]
575− , do P.word1 0x5D {-]-} ArrayEnd
449+ , do P.word1 0x5D {-]-} E.ArrayEnd
576450 return (Array [])
577451 ]
578452
579453
580−pArrayHelp :: Int -> [AST] -> Parser AST_
454+pArrayHelp :: Int -> [AST] -> Parser AST
581455pArrayHelp !len revEntries =
582− P.oneOf ArrayEnd
456+ P.oneOf E.ArrayMore
583457 [
584− do P.word1 0x2C {-,-} ArrayEnd
458+ do P.word1 0x2C {-,-} E.ArrayMore
585459 spaces
586460 entry <- pValue
587461 spaces
588462 pArrayHelp (len + 1) (entry:revEntries)
589463 ,
590− do P.word1 0x5D {-]-} ArrayEnd
464+ do P.word1 0x5D {-]-} E.ArrayEnd
591465 return (Array (reverse revEntries))
592466 ]
593467
@@ -596,44 +470,41 @@ pArrayHelp !len revEntries =
596470-- STRING
597471
598472
599−pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
600−pString start =
601− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
473+pString :: Parser Utf8.String
474+pString =
475+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
602476 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
603477
604478 let
605479 !pos1 = plusPtr pos 1
606− !col1 = col + 1
607480
608481 (# status, newPos, newRow, newCol #) =
609− pStringHelp pos1 end row col1
482+ pStringHelp pos1 end row (col + 1)
610483 in
611484 case status of
612485 GoodString ->
613486 let
614− !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
615− !len = minusPtr newPos pos1 - 1
616− !snp = P.Snippet src off len row col1
617− !newState = P.State src newPos end indent newRow newCol
487+ !newState = P.State newPos end indent newRow newCol ctx
488+ !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
618489 in
619− cok snp newState
490+ cok content newState
620491
621− BadString problem ->
622− cerr newRow newCol (StringProblem problem)
492+ BadStringEnd ->
493+ cerr newRow newCol ctx E.StringEnd
623494
624495 else
625− eerr row col start
496+ eerr row col ctx E.StringStart
626497
627498
628499data StringStatus
629500 = GoodString
630− | BadString StringProblem
501+ | BadStringEnd
631502
632503
633−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
504+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
634505pStringHelp pos end row col =
635506 if pos >= end then
636− (# BadString BadStringEnd, pos, row, col #)
507+ (# BadStringEnd, pos, row, col #)
637508
638509 else
639510 case P.unsafeIndex pos of
@@ -641,50 +512,26 @@ pStringHelp pos end row col =
641512 (# GoodString, plusPtr pos 1, row, col + 1 #)
642513
643514 0x0A {-\n-} ->
644− (# BadString BadStringEnd, pos, row, col #)
515+ (# BadStringEnd, pos, row, col #)
645516
646517 0x5C {-\-} ->
647− let !pos1 = plusPtr pos 1 in
648− if pos1 >= end then
649− (# BadString BadStringEnd, pos1, row + 1, col #)
650− else
651− case P.unsafeIndex pos1 of
652− 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
653− 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
654− 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
655− 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
656− 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
657− 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
658− 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
659− 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
660− 0x75 {-u-} ->
661− let !pos6 = plusPtr pos 6 in
662− if pos6 <= end
663− && isHex (P.unsafeIndex (plusPtr pos 2))
664− && isHex (P.unsafeIndex (plusPtr pos 3))
665− && isHex (P.unsafeIndex (plusPtr pos 4))
666− && isHex (P.unsafeIndex (plusPtr pos 5))
667− then
668− pStringHelp pos6 end row (col + 6)
669− else
670− (# BadString BadStringEscapeHex, pos, row, col #)
671−
672− _ ->
673− (# BadString BadStringEscapeChar, pos, row, col #)
518+ let
519+ !pos1 = plusPtr pos 1
520+ in
521+ if pos1 < end then
674522
675− word ->
676− if word < 0x20 then
677− (# BadString BadStringControlChar, pos, row, col #)
678− else
679− let !newPos = plusPtr pos (P.getCharWidth word) in
680− pStringHelp newPos end row (col + 1)
523+ let
524+ !word = P.unsafeIndex pos1
525+ !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
526+ in
527+ pStringHelp newPos end row (col + 2)
681528
529+ else
530+ (# BadStringEnd, pos1, row + 1, col #)
682531
683−isHex :: Word8 -> Bool
684−isHex word =
685− 0x30 {-0-} <= word && word <= 0x39 {-9-}
686− || 0x61 {-a-} <= word && word <= 0x66 {-f-}
687− || 0x41 {-A-} <= word && word <= 0x46 {-F-}
532+ word ->
533+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
534+ pStringHelp newPos end row (col + 1)
688535
689536
690537
@@ -693,7 +540,7 @@ isHex word =
693540
694541spaces :: Parser ()
695542spaces =
696− P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
543+ P.Parser $ \state@(P.State pos end indent row col ctx) cok eok _ _ ->
697544 let
698545 (# newPos, newRow, newCol #) =
699546 eatSpaces pos end row col
@@ -703,12 +550,12 @@ spaces =
703550 else
704551 let
705552 !newState =
706− P.State src newPos end indent newRow newCol
553+ P.State newPos end indent newRow newCol ctx
707554 in
708555 cok () newState
709556
710557
711−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
558+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
712559eatSpaces pos end row col =
713560 if pos >= end then
714561 (# pos, row, col #)
@@ -727,29 +574,29 @@ eatSpaces pos end row col =
727574-- INTS
728575
729576
730−pInt :: Parser AST_
577+pInt :: Parser AST
731578pInt =
732− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
579+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
733580 if pos >= end then
734− eerr row col Start
581+ eerr row col ctx E.IntStart
735582
736583 else
737584 let !word = P.unsafeIndex pos in
738585 if not (isDecimalDigit word) then
739− eerr row col Start
586+ eerr row col ctx E.IntStart
740587
741588 else if word == 0x30 {-0-} then
742589
743590 let
744591 !pos1 = plusPtr pos 1
745− !newState = P.State src pos1 end indent row (col + 1)
592+ !newState = P.State pos1 end indent row (col + 1) ctx
746593 in
747594 if pos1 < end then
748595 let !word1 = P.unsafeIndex pos1 in
749596 if isDecimalDigit word1 then
750− cerr row (col + 1) NoLeadingZeros
597+ cerr row (col + 1) ctx E.NoLeadingZeros
751598 else if word1 == 0x2E {-.-} then
752− cerr row (col + 1) NoFloats
599+ cerr row (col + 1) ctx E.NoFloats
753600 else
754601 cok (Int 0) newState
755602 else
@@ -766,12 +613,12 @@ pInt =
766613 GoodInt ->
767614 let
768615 !newState =
769− P.State src newPos end indent row (col + len)
616+ P.State newPos end indent row (col + len) ctx
770617 in
771618 cok (Int n) newState
772619
773620 BadIntEnd ->
774− cerr row (col + len) NoFloats
621+ cerr row (col + len) ctx E.NoFloats
775622
776623
777624data IntStatus = GoodInt | BadIntEnd
compiler/src/Json/Encode.hs+21−37
@@ -10,7 +10,6 @@ module Json.Encode
1010 , object
1111 , string
1212 , name
13− , chars
1413 , bool
1514 , int
1615 , number
@@ -33,7 +32,6 @@ import qualified Data.Name as Name
3332import qualified Data.Utf8 as Utf8
3433
3534import qualified File
36−import qualified Json.String as Json
3735
3836
3937
@@ -42,7 +40,7 @@ import qualified Json.String as Json
4240
4341data Value
4442 = Array [Value]
45− | Object [(Json.String, Value)]
43+ | Object [(Utf8.String, Value)]
4644 | String B.Builder
4745 | Boolean Bool
4846 | Integer Int
@@ -55,14 +53,14 @@ array =
5553 Array
5654
5755
58−object :: [(Json.String, Value)] -> Value
56+object :: [(Utf8.String,Value)] -> Value
5957object =
6058 Object
6159
6260
63−string :: Json.String -> Value
61+string :: Utf8.String -> Value
6462string str =
65− String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')
63+ String (encodeUtf8 str)
6664
6765
6866name :: Name.Name -> Value
@@ -90,7 +88,7 @@ null =
9088 Null
9189
9290
93−dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value
91+dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value
9492dict encodeKey encodeValue pairs =
9593 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
9694
@@ -101,35 +99,12 @@ list encodeEntry entries =
10199
102100
103101
104−-- CHARS
105−
106−
107−chars :: [Char] -> Value -- PERF can this be done better? Look for examples.
108−chars chrs =
109− String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')
110−
111−
112−escape :: [Char] -> [Char]
113−escape chrs =
114− case chrs of
115− [] ->
116− []
117−
118− c:cs
119− | c == '\r' -> '\\' : 'r' : escape cs
120− | c == '\n' -> '\\' : 'n' : escape cs
121− | c == '\"' -> '\\' : '"' : escape cs
122− | c == '\\' -> '\\' : '\\' : escape cs
123− | otherwise -> c : escape cs
124−
125−
126−
127102-- HELPERS
128103
129104
130−(==>) :: [Char] -> value -> (Json.String, value)
131−(==>) key value =
132− (Json.fromChars key, value)
105+(==>) :: a -> b -> (a, b)
106+(==>) a b =
107+ (a, b)
133108
134109
135110
@@ -169,7 +144,7 @@ encodeUgly value =
169144 Object (first : rest) ->
170145 let
171146 encodeEntry char (key, entry) =
172− B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry
147+ B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry
173148 in
174149 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
175150
@@ -230,6 +205,15 @@ encodeHelp indent value =
230205
231206
232207
208+-- ENCODE UTF-8
209+
210+
211+encodeUtf8 :: Utf8.String -> B.Builder
212+encodeUtf8 str =
213+ B.char7 '"' <> Utf8.toBuilder str <> B.char7 '"'
214+
215+
216+
233217-- ENCODE ARRAY
234218
235219
@@ -252,7 +236,7 @@ arrayClose =
252236-- ENCODE OBJECT
253237
254238
255−encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder
239+encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder
256240encodeObject =
257241 encodeSequence objectOpen objectClose encodeField
258242
@@ -267,9 +251,9 @@ objectClose =
267251 B.char7 '}'
268252
269253
270−encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder
254+encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder
271255encodeField indent (key, value) =
272− B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value
256+ encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value
273257
274258
275259
compiler/src/Json/String.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
3−module Json.String
4− ( String
5− , isEmpty
6− --
7− , fromPtr
8− , fromName
9− , fromChars
10− , fromSnippet
11− , fromComment
12− --
13− , toChars
14− , toBuilder
15− )
16− where
17−
18−
19−import Prelude hiding (String)
20−import qualified Data.ByteString.Builder as B
21−import qualified Data.Coerce as Coerce
22−import qualified Data.Name as Name
23−import qualified Data.Utf8 as Utf8
24−import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
25−import Data.Word (Word8)
26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
27−import Foreign.ForeignPtr (withForeignPtr)
28−import GHC.Exts (RealWorld)
29−import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)
30−import GHC.ST (ST)
31−
32−import qualified Parse.Primitives as P
33−
34−
35−
36−-- JSON STRINGS
37−
38−
39−-- INVARIANT: any Json.String is appropriately escaped already
40−-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
41−--
42−type String =
43− Utf8.Utf8 JSON_STRING
44−
45−
46−data JSON_STRING
47−
48−
49−isEmpty :: String -> Bool
50−isEmpty =
51− Utf8.isEmpty
52−
53−
54−
55−-- FROM
56−
57−
58−fromPtr :: Ptr Word8 -> Ptr Word8 -> String
59−fromPtr =
60− Utf8.fromPtr
61−
62−
63−fromChars :: [Char] -> String
64−fromChars =
65− Utf8.fromChars
66−
67−
68−fromSnippet :: P.Snippet -> String
69−fromSnippet =
70− Utf8.fromSnippet
71−
72−
73−fromName :: Name.Name -> String
74−fromName =
75− Coerce.coerce
76−
77−
78−
79−-- TO
80−
81−
82−toChars :: String -> [Char]
83−toChars =
84− Utf8.toChars
85−
86−
87−{-# INLINE toBuilder #-}
88−toBuilder :: String -> B.Builder
89−toBuilder =
90− Utf8.toBuilder
91−
92−
93−
94−-- FROM COMMENT
95−
96−
97−fromComment :: P.Snippet -> String
98−fromComment (P.Snippet fptr off len _ _) =
99− unsafePerformIO $ withForeignPtr fptr $ \ptr ->
100− let
101− !pos = plusPtr ptr off
102− !end = plusPtr pos len
103− !str = fromChunks (chompChunks pos end pos [])
104− in
105− return str
106−
107−
108−chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
109−chompChunks pos end start revChunks =
110− if pos >= end then
111− reverse (addSlice start end revChunks)
112− else
113− let
114− !word = P.unsafeIndex pos
115− in
116− case word of
117− 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
118− 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
119− 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
120− 0x0D {-\r-} ->
121− let
122− !newPos = plusPtr pos 1
123− in
124− chompChunks newPos end newPos (addSlice start pos revChunks)
125−
126− _ ->
127− let
128− !width = P.getCharWidth word
129− !newPos = plusPtr pos width
130− in
131− chompChunks newPos end start revChunks
132−
133−
134−chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
135−chompEscape escape pos end start revChunks =
136− let
137− !pos1 = plusPtr pos 1
138− in
139− chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)
140−
141−
142−addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
143−addSlice start end revChunks =
144− if start == end
145− then revChunks
146− else Slice start (minusPtr end start) : revChunks
147−
148−
149−
150−-- FROM CHUNKS
151−
152−
153−data Chunk
154− = Slice (Ptr Word8) Int
155− | Escape Word8
156−
157−
158−fromChunks :: [Chunk] -> String
159−fromChunks chunks =
160− unsafeDupablePerformIO (stToIO (
161− do let !len = sum (map chunkToWidth chunks)
162− mba <- newByteArray len
163− writeChunks mba 0 chunks
164− freeze mba
165− ))
166−
167−
168−chunkToWidth :: Chunk -> Int
169−chunkToWidth chunk =
170− case chunk of
171− Slice _ len -> len
172− Escape _ -> 2
173−
174−
175−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
176−writeChunks mba offset chunks =
177− case chunks of
178− [] ->
179− return ()
180−
181− chunk : chunks ->
182− case chunk of
183− Slice ptr len ->
184− do copyFromPtr ptr mba offset len
185− let !newOffset = offset + len
186− writeChunks mba newOffset chunks
187−
188− Escape word ->
189− do writeWord8 mba offset 0x5C {- \ -}
190− writeWord8 mba (offset + 1) word
191− let !newOffset = offset + 2
192− writeChunks mba newOffset chunks
compiler/src/Nitpick/Debug.hs+18−6
@@ -1,21 +1,33 @@
11module Nitpick.Debug
2− ( hasDebugUses
2+ ( findDebugUses
33 )
44 where
55
66
7−import qualified Data.Map.Utils as Map
7+import qualified Data.Map as Map
8+import qualified Data.Name as Name
9+import qualified Data.Set as Set
810
911import qualified AST.Optimized as Opt
12+import qualified Elm.ModuleName as ModuleName
13+import qualified Elm.Package as Pkg
1014
1115
1216
13−-- HAS DEBUG USES
17+-- FIND DEBUG USES
1418
1519
16−hasDebugUses :: Opt.LocalGraph -> Bool
17−hasDebugUses (Opt.LocalGraph _ graph _) =
18− Map.any nodeHasDebug graph
20+findDebugUses :: Pkg.Name -> Opt.Graph -> [Name.Name]
21+findDebugUses pkg (Opt.Graph _ graph _) =
22+ Set.toList $ Map.foldrWithKey (addDebugUses pkg) Set.empty graph
23+
24+
25+addDebugUses :: Pkg.Name -> Opt.Global -> Opt.Node -> Set.Set Name.Name -> Set.Set Name.Name
26+addDebugUses here (Opt.Global (ModuleName.Canonical pkg home) _) node uses =
27+ if pkg == here && nodeHasDebug node then
28+ Set.insert home uses
29+ else
30+ uses
1931
2032
2133nodeHasDebug :: Opt.Node -> Bool
compiler/src/Nitpick/PatternMatches.hs+9−10
@@ -21,12 +21,11 @@ import qualified Data.List as List
2121import qualified Data.Map as Map
2222import qualified Data.Maybe as Maybe
2323import qualified Data.Name as Name
24−import qualified Data.NonEmptyList as NE
24+import qualified Data.Utf8 as Utf8
2525
2626import qualified AST.Canonical as Can
2727import qualified Data.Index as Index
2828import qualified Elm.ModuleName as ModuleName
29−import qualified Elm.String as ES
3029import qualified Reporting.Annotation as A
3130
3231
@@ -41,8 +40,8 @@ data Pattern
4140
4241
4342data Literal
44− = Chr ES.String
45− | Str ES.String
43+ = Chr Utf8.String
44+ | Str Utf8.String
4645 | Int Int
4746 deriving (Eq)
4847
@@ -203,14 +202,14 @@ data Context
203202-- CHECK
204203
205204
206−check :: Can.Module -> Either (NE.List Error) ()
207−check (Can.Module _ _ _ decls _ _ _ _) =
205+check :: Can.Module -> Either [Error] ()
206+check (Can.Module _ _ decls _ _ _ _) =
208207 case checkDecls decls [] of
209208 [] ->
210209 Right ()
211210
212− e:es ->
213− Left (NE.List e es)
211+ errors ->
212+ Left errors
214213
215214
216215
@@ -223,8 +222,8 @@ checkDecls decls errors =
223222 Can.Declare def subDecls ->
224223 checkDef def $ checkDecls subDecls errors
225224
226− Can.DeclareRec def defs subDecls ->
227− checkDef def (foldr checkDef (checkDecls subDecls errors) defs)
225+ Can.DeclareRec defs subDecls ->
226+ foldr checkDef (checkDecls subDecls errors) defs
228227
229228 Can.SaveTheEnvironment ->
230229 errors
compiler/src/Optimize/DecisionTree.hs+5−5
@@ -27,11 +27,11 @@ import qualified Data.List as List
2727import qualified Data.Maybe as Maybe
2828import qualified Data.Name as Name
2929import qualified Data.Set as Set
30+import qualified Data.Utf8 as Utf8
3031
3132import qualified AST.Canonical as Can
3233import qualified Data.Index as Index
3334import qualified Elm.ModuleName as ModuleName
34−import qualified Elm.String as ES
3535import qualified Reporting.Annotation as A
3636
3737
@@ -77,8 +77,8 @@ data Test
7777 | IsNil
7878 | IsTuple
7979 | IsInt Int
80− | IsChr ES.String
81− | IsStr ES.String
80+ | IsChr Utf8.String
81+ | IsStr Utf8.String
8282 | IsBool Bool
8383 deriving (Eq, Ord)
8484
@@ -618,7 +618,7 @@ instance Binary Test where
618618 5 -> liftM IsStr get
619619 6 -> liftM IsInt get
620620 7 -> liftM IsBool get
621− _ -> fail "problem getting DecisionTree.Test binary"
621+ _ -> error "problem getting DecisionTree.Test binary"
622622
623623
624624instance Binary Path where
@@ -634,4 +634,4 @@ instance Binary Path where
634634 0 -> liftM2 Index get get
635635 1 -> liftM Unbox get
636636 2 -> pure Empty
637− _ -> fail "problem getting DecisionTree.Path binary"
637+ _ -> error "problem getting DecisionTree.Path binary"
compiler/src/Optimize/Module.hs+38−35
@@ -40,13 +40,13 @@ type Annotations =
4040 Map.Map Name.Name Can.Annotation
4141
4242
43−optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
44−optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =
43+optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.Graph
44+optimize annotations (Can.Module home _ decls unions aliases _ effects) =
4545 addDecls home annotations decls $
4646 addEffects home effects $
4747 addUnions home unions $
4848 addAliases home aliases $
49− Opt.LocalGraph Nothing Map.empty Map.empty
49+ Opt.Graph Map.empty Map.empty Map.empty
5050
5151
5252
@@ -57,9 +57,9 @@ type Nodes =
5757 Map.Map Opt.Global Opt.Node
5858
5959
60−addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph
61−addUnions home unions (Opt.LocalGraph main nodes fields) =
62− Opt.LocalGraph main (Map.foldr (addUnion home) nodes unions) fields
60+addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.Graph -> Opt.Graph
61+addUnions home unions (Opt.Graph mains nodes fields) =
62+ Opt.Graph mains (Map.foldr (addUnion home) nodes unions) fields
6363
6464
6565addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
@@ -83,13 +83,13 @@ addCtorNode home opts nodes (Can.Ctor name index numArgs _) =
8383-- ALIAS
8484
8585
86−addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
86+addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.Graph -> Opt.Graph
8787addAliases home aliases graph =
8888 Map.foldrWithKey (addAlias home) graph aliases
8989
9090
91−addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
92−addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCounts) =
91+addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
92+addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains nodes fieldCounts) =
9393 case tipe of
9494 Can.TRecord fields Nothing ->
9595 let
@@ -100,8 +100,8 @@ addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCoun
100100 node =
101101 Opt.Define function Set.empty
102102 in
103− Opt.LocalGraph
104− main
103+ Opt.Graph
104+ mains
105105 (Map.insert (Opt.Global home name) node nodes)
106106 (Map.foldrWithKey addRecordCtorField fieldCounts fields)
107107
@@ -118,8 +118,8 @@ addRecordCtorField name _ fields =
118118-- ADD EFFECTS
119119
120120
121−addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.LocalGraph -> Opt.LocalGraph
122−addEffects home effects graph@(Opt.LocalGraph main nodes fields) =
121+addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
122+addEffects home effects graph@(Opt.Graph mains nodes fields) =
123123 case effects of
124124 Can.NoEffects ->
125125 graph
@@ -148,10 +148,10 @@ addEffects home effects graph@(Opt.LocalGraph main nodes fields) =
148148 Map.insert sub link $
149149 Map.insert fx (Opt.Manager Opt.Fx) nodes
150150 in
151− Opt.LocalGraph main newNodes fields
151+ Opt.Graph mains newNodes fields
152152
153153
154−addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph
154+addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.Graph -> Opt.Graph
155155addPort home name port_ graph =
156156 case port_ of
157157 Can.Incoming _ payloadType _ ->
@@ -173,10 +173,10 @@ addPort home name port_ graph =
173173-- HELPER
174174
175175
176−addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph
177−addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
178− Opt.LocalGraph
179− main
176+addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.Graph -> Opt.Graph
177+addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
178+ Opt.Graph
179+ mains
180180 (Map.insert name node nodes)
181181 (Map.unionWith (+) fields fieldCounts)
182182
@@ -185,20 +185,19 @@ addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
185185-- ADD DECLS
186186
187187
188−addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
188+addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph
189189addDecls home annotations decls graph =
190190 case decls of
191191 Can.Declare def subDecls ->
192192 addDecls home annotations subDecls =<< addDef home annotations def graph
193193
194− Can.DeclareRec d ds subDecls ->
195− let defs = d:ds in
194+ Can.DeclareRec defs subDecls ->
196195 case findMain defs of
197196 Nothing ->
198197 addDecls home annotations subDecls (addRecDefs home defs graph)
199198
200199 Just region ->
201− Result.throw $ E.BadCycle region (defToName d) (map defToName ds)
200+ Result.throw $ E.BadCycle region (map defToName defs)
202201
203202 Can.SaveTheEnvironment ->
204203 Result.ok graph
@@ -213,10 +212,10 @@ findMain defs =
213212 def:rest ->
214213 case def of
215214 Can.Def (A.At region name) _ _ ->
216− if name == Name._main then Just region else findMain rest
215+ if name == Name.main then Just region else findMain rest
217216
218217 Can.TypedDef (A.At region name) _ _ _ _ ->
219− if name == Name._main then Just region else findMain rest
218+ if name == Name.main then Just region else findMain rest
220219
221220
222221defToName :: Can.Def -> Name.Name
@@ -230,7 +229,7 @@ defToName def =
230229-- ADD DEFS
231230
232231
233−addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
232+addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph
234233addDef home annotations def graph =
235234 case def of
236235 Can.Def (A.At region name) args body ->
@@ -242,17 +241,21 @@ addDef home annotations def graph =
242241 addDefHelp region annotations home name (map fst typedArgs) body graph
243242
244243
245−addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
246−addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
247− if name /= Name._main then
244+addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph
245+addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =
246+ if name /= Name.main then
248247 Result.ok (addDefNode home name args body Set.empty graph)
249248 else
250249 let
251250 (Can.Forall _ tipe) = annotations ! name
252251
253252 addMain (deps, fields, main) =
253+ let
254+ newMains = Map.insert home main mains
255+ newFields = Map.unionWith (+) fields fieldCounts
256+ in
254257 addDefNode home name args body deps $
255− Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts)
258+ Opt.Graph newMains nodes newFields
256259 in
257260 case Type.deepDealias tipe of
258261 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
@@ -272,7 +275,7 @@ addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes
272275 Result.throw (E.BadType region tipe)
273276
274277
275−addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph
278+addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph
276279addDefNode home name args body mainDeps graph =
277280 let
278281 (deps, fields, def) =
@@ -301,8 +304,8 @@ data State =
301304 }
302305
303306
304−addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.LocalGraph -> Opt.LocalGraph
305−addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =
307+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
308+addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =
306309 let
307310 names = reverse (map toName defs)
308311 cycleName = Opt.Global home (Name.fromManyNames names)
@@ -313,8 +316,8 @@ addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =
313316 Names.run $
314317 foldM (addRecDef cycle) (State [] []) defs
315318 in
316− Opt.LocalGraph
317− main
319+ Opt.Graph
320+ mains
318321 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
319322 (Map.unionWith (+) fields fieldCounts)
320323
compiler/src/Optimize/Names.hs+7−1
@@ -24,6 +24,7 @@ import qualified AST.Canonical as Can
2424import qualified AST.Optimized as Opt
2525import qualified Data.Index as Index
2626import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Package as Pkg
2728import qualified Reporting.Annotation as A
2829
2930
@@ -57,7 +58,12 @@ generate =
5758registerKernel :: Name.Name -> a -> Tracker a
5859registerKernel home value =
5960 Tracker $ \uid deps fields ok ->
60− ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value
61+ ok uid (Set.insert (toKernelGlobal home) deps) fields value
62+
63+
64+toKernelGlobal :: Name.Name -> Opt.Global
65+toKernelGlobal home =
66+ Opt.Global (ModuleName.Canonical Pkg.kernel home) Name.dollar
6167
6268
6369registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr
compiler/src/Optimize/Port.hs+3−3
@@ -58,7 +58,7 @@ toEncoder tipe =
5858 | name == Name.array -> encodeArray arg
5959
6060 _ ->
61− error "toEncoder: bad custom type"
61+ error "toEncoder: bad union type"
6262
6363 Can.TRecord _ (Just _) ->
6464 error "toEncoder: bad record"
@@ -68,7 +68,7 @@ toEncoder tipe =
6868 encodeField (name, Can.FieldType _ fieldType) =
6969 do encoder <- toEncoder fieldType
7070 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
71− return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing
71+ return $ Opt.Tuple (Opt.Str (Name.toUtf8 name)) value Nothing
7272 in
7373 do object <- encode "object"
7474 keyValuePairs <- traverse encodeField (Map.toList fields)
@@ -309,7 +309,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) =
309309 return $
310310 Opt.Call andThen
311311 [ Opt.Function [key] decoder
312− , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]
312+ , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]
313313 ]
314314
315315
compiler/src/Parse/Declaration.hs+131−180
@@ -16,11 +16,11 @@ import qualified Parse.Expression as Expr
1616import qualified Parse.Pattern as Pattern
1717import qualified Parse.Keyword as Keyword
1818import qualified Parse.Number as Number
19−import qualified Parse.Space as Space
2019import qualified Parse.Symbol as Symbol
2120import qualified Parse.Type as Type
2221import qualified Parse.Variable as Var
23−import Parse.Primitives hiding (State)
22+import Parse.Utils
23+import Parse.Primitives hiding (Parser, State)
2424import qualified Parse.Primitives as P
2525import qualified Reporting.Annotation as A
2626import qualified Reporting.Error.Syntax as E
@@ -31,182 +31,141 @@ import qualified Reporting.Error.Syntax as E
3131
3232
3333data Decl
34− = Value (Maybe Src.Comment) (A.Located Src.Value)
35− | Union (Maybe Src.Comment) (A.Located Src.Union)
36− | Alias (Maybe Src.Comment) (A.Located Src.Alias)
37− | Port (Maybe Src.Comment) Src.Port
34+ = Value (A.Located Src.Value)
35+ | Union (A.Located Src.Union)
36+ | Alias (A.Located Src.Alias)
37+ | Port Src.Port
3838
3939
40−declaration :: Space.Parser E.Decl Decl
40+declaration :: SParser Decl
4141declaration =
42− do maybeDocs <- chompDocComment
43− start <- getPosition
44− oneOf E.DeclStart
45− [ typeDecl maybeDocs start
46− , portDecl maybeDocs
47− , valueDecl maybeDocs start
42+ do start <- getPosition
43+ oneOf E.XXX
44+ [ typeDecl start
45+ , portDecl
46+ , valueDecl start
4847 ]
4948
5049
5150
52−-- DOC COMMENT
53−
54−
55−chompDocComment :: Parser E.Decl (Maybe Src.Comment)
56−chompDocComment =
57− oneOfWithFallback
58− [
59− do docComment <- Space.docComment E.DeclStart E.DeclSpace
60− Space.chomp E.DeclSpace
61− Space.checkFreshLine E.DeclFreshLineAfterDocComment
62− return (Just docComment)
63− ]
64− Nothing
65−
66−
67−
6851-- DEFINITION and ANNOTATION
6952
7053
7154{-# INLINE valueDecl #-}
72−valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
73−valueDecl maybeDocs start =
74− do name <- Var.lower E.DeclStart
55+valueDecl :: A.Position -> SParser Decl
56+valueDecl start =
57+ do name <- Var.lower
7558 end <- getPosition
76− specialize (E.DeclDef name) $
77− do Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
78− oneOf E.DeclDefEquals
79− [
80− do word1 0x3A {-:-} E.DeclDefEquals
81− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
82− (tipe, _) <- specialize E.DeclDefType Type.expression
83− Space.checkFreshLine E.DeclDefNameRepeat
84− defName <- chompMatchingName name
85− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
86− chompDefArgsAndBody maybeDocs start defName (Just tipe) []
87− ,
88− chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing []
89− ]
90−
91−
92−chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
93−chompDefArgsAndBody maybeDocs start name tipe revArgs =
94− oneOf E.DeclDefEquals
95− [ do arg <- specialize E.DeclDefArg Pattern.term
96− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
97− chompDefArgsAndBody maybeDocs start name tipe (arg : revArgs)
98− , do word1 0x3D {-=-} E.DeclDefEquals
99− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody
100− (body, end) <- specialize E.DeclDefBody Expr.expression
101− let value = Src.Value name (reverse revArgs) body tipe
102− let avalue = A.at start end value
103− return (Value maybeDocs avalue, end)
59+ spaces
60+ oneOf E.XXX
61+ [
62+ do word1 0x3A {-:-} E.XXX
63+ pushContext start (E.Annotation name)
64+ spaces
65+ (tipe, _, space) <- Type.expression
66+ popContext ()
67+ checkAligned space
68+ defName <- matchingName name
69+ let (A.At (A.Region defStart _) _) = defName
70+ pushContext defStart (E.Definition name)
71+ spaces
72+ decl <- valueHelp start defName (Just tipe) []
73+ popContext decl
74+ ,
75+ do pushContext start (E.Definition name)
76+ decl <- valueHelp start (A.at start end name) Nothing []
77+ popContext decl
78+ ]
79+
80+
81+valueHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser Decl
82+valueHelp start name tipe revArgs =
83+ oneOf E.XXX
84+ [ do arg <- Pattern.term
85+ spaces
86+ valueHelp start name tipe (arg : revArgs)
87+ , do word1 0x3D {-=-} E.XXX
88+ spaces
89+ (body, end, space) <- Expr.expression
90+ let value = A.at start end (Src.Value name (reverse revArgs) body tipe)
91+ return ( Value value, end, space )
10492 ]
10593
10694
107−chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
108−chompMatchingName expectedName =
109− let
110− (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
111− in
112− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
95+matchingName :: Name.Name -> Parser (A.Located Name.Name)
96+matchingName expectedName =
97+ let (P.Parser parserL) = Var.lower in
98+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->
11399 let
114− cokL name newState@(P.State _ _ _ _ er ec) =
100+ cokL name newState@(P.State _ _ _ er ec _) =
115101 if expectedName == name
116102 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
117− else cerr sr sc (E.DeclDefNameMatch name)
103+ else cerr sr sc ctx (E.MatchingName expectedName)
118104
119− eokL name newState@(P.State _ _ _ _ er ec) =
105+ eokL name newState@(P.State _ _ _ er ec _) =
120106 if expectedName == name
121107 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
122− else eerr sr sc (E.DeclDefNameMatch name)
108+ else eerr sr sc ctx (E.MatchingName expectedName)
123109 in
124110 parserL state cokL eokL cerr eerr
125111
126112
127113
128−-- TYPE DECLARATIONS
114+-- TYPE ALIAS and UNION TYPES
129115
130116
131117{-# INLINE typeDecl #-}
132−typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
133−typeDecl maybeDocs start =
134− inContext E.DeclType (Keyword.type_ E.DeclStart) $
135− do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
136− oneOf E.DT_Name
137− [
138− inContext E.DT_Alias (Keyword.alias_ E.DT_Name) $
139− do Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
140− (name, args) <- chompAliasNameToEquals
141− (tipe, end) <- specialize E.AliasBody Type.expression
142− let alias = A.at start end (Src.Alias name args tipe)
143− return (Alias maybeDocs alias, end)
144− ,
145− specialize E.DT_Union $
146− do (name, args) <- chompCustomNameToEquals
147− (firstVariant, firstEnd) <- Type.variant
148− (variants, end) <- chompVariants [firstVariant] firstEnd
149− let union = A.at start end (Src.Union name args variants)
150− return (Union maybeDocs union, end)
151− ]
152−
153−
154−
155−-- TYPE ALIASES
156−
157−
158−chompAliasNameToEquals :: Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])
159−chompAliasNameToEquals =
160− do name <- addLocation (Var.upper E.AliasName)
161− Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
162− chompAliasNameToEqualsHelp name []
163−
164−
165−chompAliasNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])
166−chompAliasNameToEqualsHelp name args =
167− oneOf E.AliasEquals
168− [ do arg <- addLocation (Var.lower E.AliasEquals)
169− Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
170− chompAliasNameToEqualsHelp name (arg:args)
171− , do word1 0x3D {-=-} E.AliasEquals
172− Space.chompAndCheckIndent E.AliasSpace E.AliasIndentBody
173− return ( name, reverse args )
174− ]
175−
176−
177−
178−-- CUSTOM TYPES
118+typeDecl :: A.Position -> SParser Decl
119+typeDecl start =
120+ do Keyword.type_
121+ spaces
122+ oneOf E.XXX
123+ [
124+ inContext E.TypeAlias Keyword.alias_ $
125+ do spaces
126+ (name, args) <- nameArgsEquals
127+ (tipe, end, pos) <- Type.expression
128+ let alias = A.at start end (Src.Alias name args tipe)
129+ return (Alias alias, end, pos)
130+ ,
131+ do pushContext start E.TypeUnion
132+ (name, args) <- nameArgsEquals
133+ (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
134+ (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace
135+ let union = A.at start end (Src.Union name args ctors)
136+ popContext (Union union, end, pos)
137+ ]
179138
180139
181−chompCustomNameToEquals :: Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
182−chompCustomNameToEquals =
183− do name <- addLocation (Var.upper E.CT_Name)
184− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
185− chompCustomNameToEqualsHelp name []
140+nameArgsEquals :: Parser (A.Located Name.Name, [A.Located Name.Name])
141+nameArgsEquals =
142+ do name <- addLocation Var.upper
143+ spaces
144+ nameArgsEqualsHelp name []
186145
187146
188−chompCustomNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
189−chompCustomNameToEqualsHelp name args =
190− oneOf E.CT_Equals
191− [ do arg <- addLocation (Var.lower E.CT_Equals)
192− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
193− chompCustomNameToEqualsHelp name (arg:args)
194− , do word1 0x3D {-=-} E.CT_Equals
195− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals
147+nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])
148+nameArgsEqualsHelp name args =
149+ oneOf E.XXX
150+ [ do arg <- addLocation Var.lower
151+ spaces
152+ nameArgsEqualsHelp name (arg:args)
153+ , do word1 0x3D {-=-} E.XXX
154+ spaces
196155 return ( name, reverse args )
197156 ]
198157
199158
200−chompVariants :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> Space.Parser E.CustomType [(A.Located Name.Name, [Src.Type])]
201−chompVariants variants end =
202− oneOfWithFallback
203− [ do Space.checkIndent end E.CT_IndentBar
204− word1 0x7C {-|-} E.CT_Bar
205− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar
206− (variant, newEnd) <- Type.variant
207− chompVariants (variant:variants) newEnd
159+chompConstructors :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> SPos -> SParser [(A.Located Name.Name, [Src.Type])]
160+chompConstructors ctors end pos =
161+ oneOf E.XXX
162+ [ do checkSpace pos
163+ word1 0x7C {-|-} E.XXX
164+ spaces
165+ (ctor, newEnd, newSpace) <- Type.unionConstructor
166+ chompConstructors (ctor:ctors) newEnd newSpace
167+ , return ( reverse ctors, end, pos )
208168 ]
209− (reverse variants, end)
210169
211170
212171
@@ -214,19 +173,16 @@ chompVariants variants end =
214173
215174
216175{-# INLINE portDecl #-}
217−portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl
218−portDecl maybeDocs =
219− inContext E.Port (Keyword.port_ E.DeclStart) $
220− do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
221− name <- addLocation (Var.lower E.PortName)
222− Space.chompAndCheckIndent E.PortSpace E.PortIndentColon
223− word1 0x3A {-:-} E.PortColon
224− Space.chompAndCheckIndent E.PortSpace E.PortIndentType
225− (tipe, end) <- specialize E.PortType Type.expression
226− return
227− ( Port maybeDocs (Src.Port name tipe)
228− , end
229− )
176+portDecl :: SParser Decl
177+portDecl =
178+ inContext E.Port Keyword.port_ $
179+ do spaces
180+ name <- addLocation Var.lower
181+ spaces
182+ word1 0x3A {-:-} E.XXX
183+ spaces
184+ (tipe, end, pos) <- Type.expression
185+ return ( Port (Src.Port name tipe), end, pos )
230186
231187
232188
@@ -235,32 +191,27 @@ portDecl maybeDocs =
235191
236192-- INVARIANT: always chomps to a freshline
237193--
238−infix_ :: Parser E.Module (A.Located Src.Infix)
194+infix_ :: Parser (A.Located Src.Binop)
239195infix_ =
240− let
241− err = E.Infix
242− _err = \_ -> E.Infix
243− in
244196 do start <- getPosition
245− Keyword.infix_ err
246− Space.chompAndCheckIndent _err err
247− associativity <-
248− oneOf err
249− [ Keyword.left_ err >> return Binop.Left
250− , Keyword.right_ err >> return Binop.Right
251− , Keyword.non_ err >> return Binop.Non
252− ]
253− Space.chompAndCheckIndent _err err
254− precedence <- Number.precedence err
255− Space.chompAndCheckIndent _err err
256− word1 0x28 {-(-} err
257− op <- Symbol.operator err _err
258− word1 0x29 {-)-} err
259− Space.chompAndCheckIndent _err err
260− word1 0x3D {-=-} err
261− Space.chompAndCheckIndent _err err
262− name <- Var.lower err
263− end <- getPosition
264− Space.chomp _err
265− Space.checkFreshLine err
266− return (A.at start end (Src.Infix op associativity precedence name))
197+ inContext E.Infix Keyword.infix_ $
198+ do spaces
199+ associativity <-
200+ oneOf E.XXX
201+ [ Keyword.left_ >> return Binop.Left
202+ , Keyword.right_ >> return Binop.Right
203+ , Keyword.non_ >> return Binop.Non
204+ ]
205+ spaces
206+ precedence <- Number.precedence
207+ spaces
208+ word1 0x28 {-(-} E.XXX
209+ op <- Symbol.binop
210+ word1 0x29 {-)-} E.XXX
211+ spaces
212+ word1 0x3D {-=-} E.XXX
213+ spaces
214+ name <- Var.lower
215+ end <- getPosition
216+ checkFreshLine =<< whitespace
217+ return (A.at start end (Src.Binop op associativity precedence name))
compiler/src/Parse/Docs.hsnew file+275
@@ -0,0 +1,275 @@
1+module Parse.Docs
2+ ( Docs(..)
3+ , parser
4+ )
5+ where
6+
7+
8+
9+-- DOCS
10+
11+
12+data Docs =
13+ Docs
14+ { _exposed :: [A.Located Name.Name]
15+ , _overview :: Utf8.String
16+ , _listed :: [A.Located Name.Name]
17+ , _comments :: Map.Map Name.Name Utf8.String
18+ }
19+
20+
21+
22+-- PARSER
23+
24+
25+parser :: Parser Docs
26+parser =
27+ error "TODO implement docs parser"
28+
29+
30+chompUntilDocs :: Parser Bool
31+chompUntilDocs =
32+ P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33+ let
34+ (# isStart, newOffset, newRow, newCol #) =
35+ eatDocs fp offset terminal row col
36+
37+ !newState =
38+ P.State fp newOffset terminal indent newRow newCol ctx
39+ in
40+ cok isStart newState
41+
42+
43+eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44+eatDocs fp offset terminal row col =
45+ if offset >= terminal then
46+ (# False, offset, row, col #)
47+
48+ else if isDocsStart fp offset terminal then
49+ (# True, offset + 5, row, col + 5 #)
50+
51+ else
52+ let !word = P.unsafeIndex fp offset in
53+ if word == 0x0A {- \n -} then
54+ eatDocs fp (offset + 1) terminal (row + 1) 1
55+
56+ else
57+ let !newOffset = offset + P.getCharWidth fp offset terminal word in
58+ eatDocs fp newOffset terminal row (col + 1)
59+
60+
61+isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62+isDocsStart =
63+ let (B.PS dfp doff dlen) = docsStart in
64+ P.isSubstring dfp doff dlen
65+
66+
67+{-# NOINLINE docsStart #-}
68+docsStart :: B.ByteString
69+docsStart =
70+ "@docs"
71+
72+
73+chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74+chompOverview names =
75+ do isDocs <- chompUntilDocs
76+ if isDocs
77+ then chompOverviewHelp names
78+ else return names
79+
80+
81+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82+chompOverviewHelp names =
83+ do pos <- getPosition
84+ (SPos spos) <- whitespace
85+ if pos == spos
86+ then chompOverview names
87+ else chompOverview =<< chompDocs names
88+
89+
90+chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91+chompDocs names =
92+ do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93+ spos <- whitespace
94+ oneOf SE.XXX
95+ [ do checkSpace spos
96+ word1 0x2C {-,-} SE.XXX
97+ spaces
98+ chompDocs (name:names)
99+ , return (name:names)
100+ ]
101+
102+
103+chompBinop :: Parser Name.Name
104+chompBinop =
105+ do word1 0x28 {-(-} SE.XXX
106+ name <- Symbol.binop
107+ word1 0x29 {-)-} SE.XXX
108+ return name
109+
110+
111+
112+
113+-- CHECK NAMES
114+
115+
116+type Result i w a =
117+ Result.Result i w E.Error a
118+
119+
120+type Dups =
121+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122+
123+
124+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125+checkNames exports names =
126+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127+ let overlap = Map.size (Map.intersection docs exports)
128+ if Map.size exports == overlap && overlap == Map.size docs
129+ then Result.ok ()
130+ else
131+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133+ Result.ok ()
134+
135+
136+addName :: Dups -> A.Located Name.Name -> Dups
137+addName dict (A.At region name) =
138+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139+
140+
141+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142+isUnique name regions =
143+ case regions of
144+ OneOrMore.One region ->
145+ Result.ok region
146+
147+ OneOrMore.More _ _ ->
148+ let (r1:r2:_) = OneOrMore.toList regions in
149+ Result.throw (E.Duplicate name r1 r2)
150+
151+
152+onlyInDocs :: Name.Name -> A.Region -> Result i w a
153+onlyInDocs name region =
154+ Result.throw $ E.OnlyInDocs name region
155+
156+
157+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158+onlyInExports name (A.At region _) =
159+ Result.throw $ E.OnlyInExports name region
160+
161+
162+
163+-- CHECK EXPORTS
164+
165+
166+data Info =
167+ Info
168+ { _iComments :: Map.Map Name.Name Comment
169+ , _iValues :: Types
170+ , _iUnions :: Map.Map Name.Name Can.Union
171+ , _iAliases :: Map.Map Name.Name Can.Alias
172+ , _iBinops :: Map.Map Name.Name Can.Binop
173+ , _iEffects :: Can.Effects
174+ }
175+
176+
177+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178+checkExport info name (A.At region export) =
179+ case export of
180+ Can.ExportValue ->
181+ do tipe <- getType name info
182+ comment <- getComment region name info
183+ Result.ok $ \m ->
184+ m { _values = Map.insert name (Value comment tipe) (_values m) }
185+
186+ Can.ExportBinop ->
187+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188+ tipe <- getType realName info
189+ comment <- getComment region realName info
190+ Result.ok $ \m ->
191+ m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192+
193+ Can.ExportAlias ->
194+ do let (Can.Alias tvars tipe) = _iAliases info ! name
195+ comment <- getComment region name info
196+ Result.ok $ \m ->
197+ m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198+
199+ Can.ExportUnionOpen ->
200+ do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201+ comment <- getComment region name info
202+ Result.ok $ \m ->
203+ m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204+
205+ Can.ExportUnionClosed ->
206+ do let (Can.Union tvars _ _ _) = _iUnions info ! name
207+ comment <- getComment region name info
208+ Result.ok $ \m ->
209+ m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210+
211+ Can.ExportPort ->
212+ do tipe <- getType name info
213+ comment <- getComment region name info
214+ Result.ok $ \m ->
215+ m { _values = Map.insert name (Value comment tipe) (_values m) }
216+
217+
218+getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219+getComment region name info =
220+ case Map.lookup name (_iComments info) of
221+ Nothing ->
222+ Result.throw (E.NoComment name region)
223+
224+ Just comment ->
225+ Result.ok comment
226+
227+
228+getType :: Name.Name -> Info -> Result i w Type.Type
229+getType name info =
230+ case _iValues info ! name of
231+ A.At defRegion Nothing ->
232+ Result.throw (E.NoAnnotation name defRegion)
233+
234+ A.At _ (Just tipe) ->
235+ Result.ok (Extract.fromType tipe)
236+
237+
238+dector :: Can.Ctor -> (Name.Name, [Type.Type])
239+dector (Can.Ctor name _ _ args) =
240+ ( name, map Extract.fromType args )
241+
242+
243+
244+-- GATHER TYPES
245+
246+
247+type Types =
248+ Map.Map Name.Name (A.Located (Maybe Can.Type))
249+
250+
251+gatherTypes :: Can.Decls -> Types -> Types
252+gatherTypes decls types =
253+ case decls of
254+ Can.Declare def subDecls ->
255+ gatherTypes subDecls (addDef types def)
256+
257+ Can.DeclareRec defs subDecls ->
258+ gatherTypes subDecls (List.foldl' addDef types defs)
259+
260+ Can.SaveTheEnvironment ->
261+ types
262+
263+
264+addDef :: Types -> Can.Def -> Types
265+addDef types def =
266+ case def of
267+ Can.Def (A.At region name) _ _ ->
268+ Map.insert name (A.At region Nothing) types
269+
270+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271+ let
272+ tipe =
273+ foldr Can.TLambda resultType (map snd typedArgs)
274+ in
275+ Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+341−330
@@ -7,18 +7,19 @@ module Parse.Expression
77
88
99import qualified Data.Name as Name
10+import Data.Word (Word16)
1011
1112import qualified AST.Source as Src
1213import qualified Parse.Keyword as Keyword
1314import qualified Parse.Number as Number
1415import qualified Parse.Pattern as Pattern
1516import qualified Parse.Shader as Shader
16−import qualified Parse.Space as Space
1717import qualified Parse.Symbol as Symbol
1818import qualified Parse.Type as Type
19−import qualified Parse.String as String
19+import qualified Parse.Utf8 as Utf8
2020import qualified Parse.Variable as Var
21−import Parse.Primitives hiding (State)
21+import Parse.Utils
22+import Parse.Primitives hiding (Parser, State)
2223import qualified Parse.Primitives as P
2324import qualified Reporting.Annotation as A
2425import qualified Reporting.Error.Syntax as E
@@ -28,10 +29,10 @@ import qualified Reporting.Error.Syntax as E
2829-- TERMS
2930
3031
31−term :: Parser E.Expr Src.Expr
32+term :: Parser Src.Expr
3233term =
3334 do start <- getPosition
34− oneOf E.Start
35+ oneOf E.XXX
3536 [ variable start >>= accessible start
3637 , string start
3738 , number start
@@ -44,80 +45,90 @@ term =
4445 ]
4546
4647
47−string :: A.Position -> Parser E.Expr Src.Expr
48+string :: A.Position -> Parser Src.Expr
4849string start =
49− do str <- String.string E.Start E.String
50− addEnd start (Src.Str str)
50+ do str <- Utf8.string
51+ end <- getPosition
52+ return (A.at start end (Src.Str str))
5153
5254
53−character :: A.Position -> Parser E.Expr Src.Expr
55+character :: A.Position -> Parser Src.Expr
5456character start =
55− do chr <- String.character E.Start E.Char
56− addEnd start (Src.Chr chr)
57+ do chr <- Utf8.character
58+ end <- getPosition
59+ return (A.at start end (Src.Chr chr))
5760
5861
59−number :: A.Position -> Parser E.Expr Src.Expr
62+number :: A.Position -> Parser Src.Expr
6063number start =
61− do nmbr <- Number.number E.Start E.Number
62− addEnd start $
64+ do nmbr <- Number.number
65+ end <- getPosition
66+ return $ A.at start end $
6367 case nmbr of
64− Number.Int int -> Src.Int int
65− Number.Float float -> Src.Float float
68+ Number.Int int ->
69+ Src.Int int
6670
71+ Number.Float float ->
72+ Src.Float float
6773
68−accessor :: A.Position -> Parser E.Expr Src.Expr
74+
75+accessor :: A.Position -> Parser Src.Expr
6976accessor start =
70− do word1 0x2E {-.-} E.Dot
71− field <- Var.lower E.Access
72− addEnd start (Src.Accessor field)
77+ do word1 0x2E {-.-} E.XXX
78+ field <- Var.lower
79+ end <- getPosition
80+ return (A.at start end (Src.Accessor field))
7381
7482
75−variable :: A.Position -> Parser E.Expr Src.Expr
83+variable :: A.Position -> Parser Src.Expr
7684variable start =
77− do var <- Var.foreignAlpha E.Start
78− addEnd start var
85+ do var <- Var.foreignAlpha
86+ end <- getPosition
87+ return (A.at start end var)
7988
8089
81−accessible :: A.Position -> Src.Expr -> Parser E.Expr Src.Expr
90+accessible :: A.Position -> Src.Expr -> Parser Src.Expr
8291accessible start expr =
83− oneOfWithFallback
84− [ do word1 0x2E {-.-} E.Dot
92+ oneOf E.XXX
93+ [ do word1 0x2E {-.-} E.XXX
8594 pos <- getPosition
86− field <- Var.lower E.Access
95+ field <- Var.lower
8796 end <- getPosition
88− accessible start $
89− A.at start end (Src.Access expr (A.at pos end field))
97+ let newExpr = A.at start end (Src.Access expr (A.at pos end field))
98+ accessible start newExpr
99+ , return expr
90100 ]
91− expr
92101
93102
94103
95104-- LISTS
96105
97106
98−list :: A.Position -> Parser E.Expr Src.Expr
107+list :: A.Position -> Parser Src.Expr
99108list start =
100− inContext E.List (word1 0x5B {-[-} E.Start) $
101− do Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen
102− oneOf E.ListOpen
103− [ do (entry, end) <- specialize E.ListExpr expression
104− Space.checkIndent end E.ListIndentEnd
105− chompListEnd start [entry]
106− , do word1 0x5D {-]-} E.ListOpen
107− addEnd start (Src.List [])
109+ inContext E.ExprList (word1 0x5B {-[-} E.XXX) $
110+ do spaces
111+ oneOf E.XXX
112+ [ do (entry, _, pos) <- expression
113+ checkSpace pos
114+ listHelp start [entry]
115+ , do word1 0x5D {-]-} E.XXX
116+ end <- getPosition
117+ return (A.at start end (Src.List []))
108118 ]
109119
110120
111−chompListEnd :: A.Position -> [Src.Expr] -> Parser E.List Src.Expr
112−chompListEnd start entries =
113− oneOf E.ListEnd
114− [ do word1 0x2C {-,-} E.ListEnd
115− Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr
116− (entry, end) <- specialize E.ListExpr expression
117− Space.checkIndent end E.ListIndentEnd
118− chompListEnd start (entry:entries)
119− , do word1 0x5D {-]-} E.ListEnd
120− addEnd start (Src.List (reverse entries))
121+listHelp :: A.Position -> [Src.Expr] -> Parser Src.Expr
122+listHelp start entries =
123+ oneOf E.XXX
124+ [ do word1 0x2C {-,-} E.XXX
125+ spaces
126+ (entry, _, pos) <- expression
127+ checkSpace pos
128+ listHelp start (entry:entries)
129+ , do word1 0x5D {-]-} E.XXX
130+ end <- getPosition
131+ return (A.at start end (Src.List (reverse entries)))
121132 ]
122133
123134
@@ -125,66 +136,52 @@ chompListEnd start entries =
125136-- TUPLES
126137
127138
128−tuple :: A.Position -> Parser E.Expr Src.Expr
129−tuple start@(A.Position row col) =
130− inContext E.Tuple (word1 0x28 {-(-} E.Start) $
131− do before <- getPosition
132− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
133− after <- getPosition
134− if before /= after
135− then
136− do (entry, end) <- specialize E.TupleExpr expression
137− Space.checkIndent end E.TupleIndentEnd
138− chompTupleEnd start entry []
139− else
140− oneOf E.TupleIndentExpr1
141− [
142− do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
143− if op == "-"
144− then
145− oneOf E.TupleOperatorClose
146− [
147− do word1 0x29 {-)-} E.TupleOperatorClose
148− addEnd start (Src.Op op)
149− ,
150− do (entry, end) <-
151− specialize E.TupleExpr $
152− do negatedExpr@(A.At (A.Region _ end) _) <- term
153− Space.chomp E.Space
154− let exprStart = A.Position row (col + 2)
155− let expr = A.at exprStart end (Src.Negate negatedExpr)
156− chompExprEnd exprStart (State [] expr [] end)
157− Space.checkIndent end E.TupleIndentEnd
158− chompTupleEnd start entry []
159− ]
160− else
161− do word1 0x29 {-)-} E.TupleOperatorClose
162− addEnd start (Src.Op op)
163− ,
164− do word1 0x29 {-)-} E.TupleIndentExpr1
165− addEnd start Src.Unit
166− ,
167− do (entry, end) <- specialize E.TupleExpr expression
168− Space.checkIndent end E.TupleIndentEnd
169− chompTupleEnd start entry []
170− ]
171−
172−
173−chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
174−chompTupleEnd start firstExpr revExprs =
175− oneOf E.TupleEnd
176− [ do word1 0x2C {-,-} E.TupleEnd
177− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN
178− (entry, end) <- specialize E.TupleExpr expression
179− Space.checkIndent end E.TupleIndentEnd
180− chompTupleEnd start firstExpr (entry : revExprs)
181− , do word1 0x29 {-)-} E.TupleEnd
139+tuple :: A.Position -> Parser Src.Expr
140+tuple start =
141+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $
142+ do pos <- getPosition
143+ spos <- whitespace
144+ oneOf E.XXX
145+ [ do noSpace pos spos
146+ word2 0x2D 0x29 {--)-} E.XXX
147+ end <- getPosition
148+ return $ A.at start end (Src.Op "-")
149+
150+ , do checkSpace spos
151+ (entry, _, spos2) <- expression
152+ checkSpace spos2
153+ tupleHelp start entry []
154+
155+ , do noSpace pos spos
156+ op <- Symbol.binop
157+ word1 0x29 {-)-} E.XXX
158+ end <- getPosition
159+ return $ A.at start end (Src.Op op)
160+
161+ , do noSpace pos spos
162+ word1 0x29 {-)-} E.XXX
163+ end <- getPosition
164+ return (A.at start end Src.Unit)
165+
166+ ]
167+
168+
169+tupleHelp :: A.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
170+tupleHelp start firstExpr revExprs =
171+ oneOf E.XXX
172+ [ do word1 0x2C {-,-} E.XXX
173+ spaces
174+ (entry, _, pos) <- expression
175+ checkSpace pos
176+ tupleHelp start firstExpr (entry : revExprs)
177+ , do word1 0x29 {-)-} E.XXX
178+ end <- getPosition
182179 case reverse revExprs of
183180 [] ->
184181 return firstExpr
185182
186− secondExpr : otherExprs ->
187− addEnd start (Src.Tuple firstExpr secondExpr otherExprs)
183+ secondExpr : others ->
184+ return (A.at start end (Src.Tuple firstExpr secondExpr others))
188185 ]
189186
190187
@@ -192,27 +189,30 @@ chompTupleEnd start firstExpr revExprs =
192189-- RECORDS
193190
194191
195−record :: A.Position -> Parser E.Expr Src.Expr
192+record :: A.Position -> Parser Src.Expr
196193record start =
197− inContext E.Record (word1 0x7B {- { -} E.Start) $
198− do Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen
199− oneOf E.RecordOpen
200− [ do word1 0x7D {-}-} E.RecordOpen
201− addEnd start (Src.Record [])
202− , do starter <- addLocation (Var.lower E.RecordField)
203− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
204− oneOf E.RecordEquals
205− [ do word1 0x7C {-|-} E.RecordEquals
206− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
194+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $
195+ do spaces
196+ oneOf E.XXX
197+ [ do word1 0x7D {-}-} E.XXX
198+ end <- getPosition
199+ return (A.at start end (Src.Record []))
200+ , do starter <- addLocation Var.lower
201+ spaces
202+ oneOf E.XXX
203+ [ do word1 0x7C {-|-} E.XXX
204+ spaces
207205 firstField <- chompField
208206 fields <- chompFields [firstField]
209− addEnd start (Src.Update starter fields)
210− , do word1 0x3D {-=-} E.RecordEquals
211− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
212− (value, end) <- specialize E.RecordExpr expression
213− Space.checkIndent end E.RecordIndentEnd
207+ end <- getPosition
208+ return (A.at start end (Src.Update starter fields))
209+ , do word1 0x3D {-=-} E.XXX
210+ spaces
211+ (value, _, nextPos) <- expression
212+ checkSpace nextPos
214213 fields <- chompFields [(starter, value)]
215− addEnd start (Src.Record fields)
214+ end <- getPosition
215+ return (A.at start end (Src.Record fields))
216216 ]
217217 ]
218218
@@ -220,26 +220,26 @@ record start =
220220type Field = ( A.Located Name.Name, Src.Expr )
221221
222222
223−chompFields :: [Field] -> Parser E.Record [Field]
223+chompFields :: [Field] -> Parser [Field]
224224chompFields fields =
225− oneOf E.RecordEnd
226− [ do word1 0x2C {-,-} E.RecordEnd
227− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
225+ oneOf E.XXX
226+ [ do word1 0x2C {-,-} E.XXX
227+ spaces
228228 f <- chompField
229229 chompFields (f : fields)
230− , do word1 0x7D {-}-} E.RecordEnd
230+ , do word1 0x7D {-}-} E.XXX
231231 return (reverse fields)
232232 ]
233233
234234
235−chompField :: Parser E.Record Field
235+chompField :: Parser Field
236236chompField =
237− do key <- addLocation (Var.lower E.RecordField)
238− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
239− word1 0x3D {-=-} E.RecordEquals
240− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
241− (value, end) <- specialize E.RecordExpr expression
242− Space.checkIndent end E.RecordIndentEnd
237+ do key <- addLocation Var.lower
238+ spaces
239+ word1 0x3D {-=-} E.XXX
240+ spaces
241+ (value, _, pos) <- expression
242+ checkSpace pos
243243 return (key, value)
244244
245245
@@ -247,18 +247,22 @@ chompField =
247247-- EXPRESSIONS
248248
249249
250−expression :: Space.Parser E.Expr Src.Expr
250+type ExprParser =
251+ SParser Src.Expr
252+
253+
254+expression :: ExprParser
251255expression =
252256 do start <- getPosition
253− oneOf E.Start
257+ oneOf E.XXX
254258 [ let_ start
255259 , if_ start
256260 , case_ start
257261 , function start
258262 , do expr <- possiblyNegativeTerm start
259263 end <- getPosition
260− Space.chomp E.Space
261− chompExprEnd start (State [] expr [] end)
264+ space <- whitespace
265+ exprHelp start (State [] expr [] end space)
262266 ]
263267
264268
@@ -268,77 +272,77 @@ data State =
268272 , _expr :: !Src.Expr
269273 , _args :: ![Src.Expr]
270274 , _end :: !A.Position
275+ , _pos :: !SPos
271276 }
272277
273278
274−chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr
275−chompExprEnd start (State ops expr args end) =
276− oneOfWithFallback
279+exprHelp :: A.Position -> State -> ExprParser
280+exprHelp start (State ops expr args end pos) =
281+ oneOf E.XXX
277282 [ -- argument
278− do Space.checkIndent end E.Start
283+ do checkSpace pos
279284 arg <- term
280285 newEnd <- getPosition
281− Space.chomp E.Space
282− chompExprEnd start (State ops expr (arg:args) newEnd)
283−
284− , -- operator
285− do Space.checkIndent end E.Start
286− op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
287− Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
286+ newPos <- whitespace
287+ exprHelp start (State ops expr (arg:args) newEnd newPos)
288+
289+ , -- infix operator
290+ do checkSpace pos
291+ opStart <- getPosition
292+ opName <- Symbol.binop
293+ opEnd <- getPosition
294+ let op = A.at opStart opEnd opName
295+ spos <- whitespace
296+ checkSpace spos
288297 newStart <- getPosition
289298 if "-" == opName && end /= opStart && opEnd == newStart
290299 then
291300 -- negative terms
292− do negatedExpr <- term
301+ do rawTerm <- term
293302 newEnd <- getPosition
294− Space.chomp E.Space
295− let arg = A.at opStart newEnd (Src.Negate negatedExpr)
296− chompExprEnd start (State ops expr (arg:args) newEnd)
303+ newPos <- whitespace
304+ let arg = A.at opStart newEnd (Src.Negate rawTerm)
305+ exprHelp start (State ops expr (arg:args) newEnd newPos)
297306 else
298− let err = E.OperatorRight opName in
299− oneOf err
307+ oneOf E.XXX
300308 [ -- term
301309 do newExpr <- possiblyNegativeTerm newStart
302310 newEnd <- getPosition
303− Space.chomp E.Space
311+ newPos <- whitespace
304312 let newOps = (toCall expr args, op) : ops
305− chompExprEnd start (State newOps newExpr [] newEnd)
313+ exprHelp start (State newOps newExpr [] newEnd newPos)
306314
307315 , -- final term
308− do (newLast, newEnd) <-
309− oneOf err
316+ do (newLast, newEnd, newPos) <-
317+ oneOf E.XXX
310318 [ let_ newStart
311319 , case_ newStart
312320 , if_ newStart
313321 , function newStart
314322 ]
315323 let newOps = (toCall expr args, op) : ops
316− let finalExpr = Src.Binops (reverse newOps) newLast
317− return ( A.at start newEnd finalExpr, newEnd )
324+ let finalExpr = A.at start newEnd (Src.Binops (reverse newOps) newLast)
325+ return ( finalExpr, newEnd, newPos )
318326 ]
319327
320− ]
321− -- done
322− (
328+ , -- done
329+ let finalExpr = toCall expr args in
323330 case ops of
324331 [] ->
325− ( toCall expr args
326− , end
327− )
332+ return ( finalExpr, end, pos )
328333
329334 _ ->
330− ( A.at start end (Src.Binops (reverse ops) (toCall expr args))
331− , end
332− )
333− )
335+ return ( A.at start end (Src.Binops (reverse ops) finalExpr), end, pos )
336+ ]
334337
335338
336−possiblyNegativeTerm :: A.Position -> Parser E.Expr Src.Expr
339+possiblyNegativeTerm :: A.Position -> Parser Src.Expr
337340possiblyNegativeTerm start =
338− oneOf E.Start
339− [ do word1 0x2D {---} E.Start
341+ oneOf E.XXX
342+ [ do word1 0x2D {---} E.XXX
340343 expr <- term
341− addEnd start (Src.Negate expr)
344+ end <- getPosition
345+ return (A.at start end (Src.Negate expr))
342346 , term
343347 ]
344348
@@ -357,32 +361,30 @@ toCall func revArgs =
357361-- IF EXPRESSION
358362
359363
360−if_ :: A.Position -> Space.Parser E.Expr Src.Expr
364+if_ :: A.Position -> ExprParser
361365if_ start =
362− inContext E.If (Keyword.if_ E.Start) $
363− chompIfEnd start []
364−
365−
366−chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If Src.Expr
367−chompIfEnd start branches =
368− do Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition
369− (condition, condEnd) <- specialize E.IfCondition expression
370− Space.checkIndent condEnd E.IfIndentThen
371− Keyword.then_ E.IfThen
372− Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch
373− (thenBranch, thenEnd) <- specialize E.IfThenBranch expression
374− Space.checkIndent thenEnd E.IfIndentElse
375− Keyword.else_ E.IfElse
376− Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch
366+ inContext E.ExprIf Keyword.if_ $
367+ ifHelp start []
368+
369+
370+ifHelp :: A.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
371+ifHelp start branches =
372+ do spaces
373+ (condition, _, condPos) <- expression
374+ checkSpace condPos
375+ Keyword.then_
376+ spaces
377+ (thenBranch, _, thenPos) <- expression
378+ checkSpace thenPos
379+ Keyword.else_
380+ spaces
377381 let newBranches = (condition, thenBranch) : branches
378− oneOf E.IfElseBranchStart
379− [
380− do Keyword.if_ E.IfElseBranchStart
381− chompIfEnd start newBranches
382− ,
383− do (elseBranch, elseEnd) <- specialize E.IfElseBranch expression
384− let ifExpr = Src.If (reverse newBranches) elseBranch
385− return ( A.at start elseEnd ifExpr, elseEnd )
382+ oneOf E.XXX
383+ [ do Keyword.if_
384+ ifHelp start newBranches
385+ , do (elseBranch, elseEnd, elseSpace) <- expression
386+ let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)
387+ return ( ifExpr, elseEnd, elseSpace )
386388 ]
387389
388390
@@ -390,27 +392,27 @@ chompIfEnd start branches =
390392-- LAMBDA EXPRESSION
391393
392394
393−function :: A.Position -> Space.Parser E.Expr Src.Expr
395+function :: A.Position -> ExprParser
394396function start =
395− inContext E.Func (word1 0x5C {-\-} E.Start) $
396− do Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg
397− arg <- specialize E.FuncArg Pattern.term
398− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow
399− revArgs <- chompArgs [arg]
400− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody
401− (body, end) <- specialize E.FuncBody expression
402− let funcExpr = Src.Lambda (reverse revArgs) body
403− return (A.at start end funcExpr, end)
404−
405−
406−chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern]
407−chompArgs revArgs =
408− oneOf E.FuncArrow
409− [ do arg <- specialize E.FuncArg Pattern.term
410− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow
411− chompArgs (arg:revArgs)
412− , do word2 0x2D 0x3E {-->-} E.FuncArrow
413− return revArgs
397+ inContext E.ExprFunc (word1 0x5C {-\-} E.XXX) $
398+ do spaces
399+ arg <- Pattern.term
400+ spaces
401+ revArgs <- gatherArgs [arg]
402+ spaces
403+ (body, end, space) <- expression
404+ let func = A.at start end (Src.Lambda (reverse revArgs) body)
405+ return ( func, end, space )
406+
407+
408+gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]
409+gatherArgs args =
410+ oneOf E.XXX
411+ [ do arg <- Pattern.term
412+ spaces
413+ gatherArgs (arg:args)
414+ , do word2 0x2D 0x3E {-->-} E.XXX
415+ return args
414416 ]
415417
416418
@@ -418,84 +420,90 @@ chompArgs revArgs =
418420-- CASE EXPRESSIONS
419421
420422
421−case_ :: A.Position -> Space.Parser E.Expr Src.Expr
423+case_ :: A.Position -> ExprParser
422424case_ start =
423− inContext E.Case (Keyword.case_ E.Start) $
424− do Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr
425− (expr, exprEnd) <- specialize E.CaseExpr expression
426− Space.checkIndent exprEnd E.CaseIndentOf
427− Keyword.of_ E.CaseOf
428− Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern
429− withIndent $
430− do (firstBranch, firstEnd) <- chompBranch
431− (branches, end) <- chompCaseEnd [firstBranch] firstEnd
432− return
433− ( A.at start end (Src.Case expr branches)
434− , end
435− )
436−
437−
438−chompBranch :: Space.Parser E.Case (Src.Pattern, Src.Expr)
439−chompBranch =
440− do (pattern, patternEnd) <- specialize E.CasePattern Pattern.expression
441− Space.checkIndent patternEnd E.CaseIndentArrow
442− word2 0x2D 0x3E {-->-} E.CaseArrow
443− Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch
444− (branchExpr, end) <- specialize E.CaseBranch expression
445− return ( (pattern, branchExpr), end )
446−
447−
448−chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)]
449−chompCaseEnd branches end =
450− oneOfWithFallback
451− [ do Space.checkAligned E.CasePatternAlignment
452− (branch, newEnd) <- chompBranch
453− chompCaseEnd (branch:branches) newEnd
425+ inContext E.ExprCase Keyword.case_ $
426+ do spaces
427+ (switcher, _, switcherPos) <- expression
428+ checkSpace switcherPos
429+ Keyword.of_
430+ spaces
431+ oldIndent <- getIndent
432+ newIndent <- getCol
433+ setIndent newIndent
434+ (firstBranch, firstEnd, firstPos) <- branchHelp
435+ (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
436+ setIndent oldIndent
437+ return
438+ ( A.at start end (Src.Case switcher branches)
439+ , end
440+ , pos
441+ )
442+
443+
444+branchHelp :: SParser (Src.Pattern, Src.Expr)
445+branchHelp =
446+ do (pattern, patternPos) <- Pattern.expression
447+ checkSpace patternPos
448+ word2 0x2D 0x3E {-->-} E.XXX
449+ spaces
450+ (branchExpr, end, pos) <- expression
451+ return ( (pattern, branchExpr), end, pos )
452+
453+
454+caseHelp :: [(Src.Pattern, Src.Expr)] -> A.Position -> SPos -> SParser [(Src.Pattern, Src.Expr)]
455+caseHelp branches end pos =
456+ oneOf E.XXX
457+ [ do checkAligned pos
458+ (branch, newEnd, newPos) <- branchHelp
459+ caseHelp (branch:branches) newEnd newPos
460+ , return ( reverse branches, end, pos )
454461 ]
455− (reverse branches, end)
456462
457463
458464
459465-- LET EXPRESSION
460466
461467
462−let_ :: A.Position -> Space.Parser E.Expr Src.Expr
468+let_ :: A.Position -> ExprParser
463469let_ start =
464− inContext E.Let (Keyword.let_ E.Start) $
465− do (defs, defsEnd) <-
466− withBacksetIndent 3 $
467− do Space.chompAndCheckIndent E.LetSpace E.LetIndentDef
468− withIndent $
469− do (def, end) <- chompLetDef
470− chompLetDefs [def] end
471−
472− Space.checkIndent defsEnd E.LetIndentIn
473− Keyword.in_ E.LetIn
474− Space.chompAndCheckIndent E.LetSpace E.LetIndentBody
475− (body, end) <- specialize E.LetBody expression
476− return
477− ( A.at start end (Src.Let defs body)
478− , end
479− )
480−
481−
482−chompLetDefs :: [A.Located Src.Def] -> A.Position -> Space.Parser E.Let [A.Located Src.Def]
483−chompLetDefs revDefs end =
484− oneOfWithFallback
485− [ do Space.checkAligned E.LetDefAlignment
486− (def, newEnd) <- chompLetDef
487− chompLetDefs (def:revDefs) newEnd
470+ do oldIndent <- getIndent
471+ letIndent <- getCol
472+ Keyword.let_
473+ pushContext start E.ExprLet
474+ setIndent letIndent
475+ spaces
476+ defIndent <- getCol
477+ setIndent defIndent
478+ (def, end, space) <- letDef
479+ letHelp start oldIndent [def] end space
480+
481+
482+letHelp :: A.Position -> Word16 -> [A.Located Src.Def] -> A.Position -> SPos -> ExprParser
483+letHelp start oldIndent revDefs end pos =
484+ oneOf E.XXX
485+ [ do checkAligned pos
486+ (def, newEnd, newPos) <- letDef
487+ letHelp start oldIndent (def:revDefs) newEnd newPos
488+
489+ , do setIndent oldIndent
490+ checkSpace pos
491+ Keyword.in_
492+ popContext ()
493+ spaces
494+ (body, newEnd, newPos) <- expression
495+ let letExpr = A.at start end (Src.Let (reverse revDefs) body)
496+ return ( letExpr, newEnd, newPos )
488497 ]
489− (reverse revDefs, end)
490498
491499
492500
493501-- LET DEFINITIONS
494502
495503
496−chompLetDef :: Space.Parser E.Let (A.Located Src.Def)
497−chompLetDef =
498− oneOf E.LetDefName
504+letDef :: SParser (A.Located Src.Def)
505+letDef =
506+ oneOf E.XXX
499507 [ definition
500508 , destructure
501509 ]
@@ -505,57 +513,61 @@ chompLetDef =
505513-- DEFINITION
506514
507515
508−definition :: Space.Parser E.Let (A.Located Src.Def)
516+definition :: SParser (A.Located Src.Def)
509517definition =
510− do aname@(A.At (A.Region start _) name) <- addLocation (Var.lower E.LetDefName)
511− specialize (E.LetDef name) $
512− do Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
513− oneOf E.DefEquals
514− [
515− do word1 0x3A {-:-} E.DefEquals
516− Space.chompAndCheckIndent E.DefSpace E.DefIndentType
517− (tipe, _) <- specialize E.DefType Type.expression
518− Space.checkAligned E.DefAlignment
519− defName <- chompMatchingName name
520− Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
521− chompDefArgsAndBody start defName (Just tipe) []
522− ,
523− chompDefArgsAndBody start aname Nothing []
524− ]
525−
526−
527−chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.Def (A.Located Src.Def)
528−chompDefArgsAndBody start name tipe revArgs =
529− oneOf E.DefEquals
530− [ do arg <- specialize E.DefArg Pattern.term
531− Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
532− chompDefArgsAndBody start name tipe (arg : revArgs)
533− , do word1 0x3D {-=-} E.DefEquals
534− Space.chompAndCheckIndent E.DefSpace E.DefIndentBody
535− (body, end) <- specialize E.DefBody expression
536− return
537− ( A.at start end (Src.Define name (reverse revArgs) body tipe)
538− , end
539− )
518+ do start <- getPosition
519+ name <- Var.lower
520+ end <- getPosition
521+ spaces
522+ oneOf E.XXX
523+ [
524+ do word1 0x3A {-:-} E.XXX
525+ pushContext start (E.Annotation name)
526+ spaces
527+ (tipe, _, space) <- Type.expression
528+ popContext ()
529+ checkAligned space
530+ defName <- matchingName name
531+ let (A.At (A.Region defStart _) _) = defName
532+ pushContext defStart (E.Definition name)
533+ spaces
534+ def <- definitionHelp start defName (Just tipe) []
535+ popContext def
536+ ,
537+ do pushContext start (E.Definition name)
538+ def <- definitionHelp start (A.at start end name) Nothing []
539+ popContext def
540+ ]
541+
542+
543+definitionHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser (A.Located Src.Def)
544+definitionHelp start name tipe revArgs =
545+ oneOf E.XXX
546+ [ do arg <- Pattern.term
547+ spaces
548+ definitionHelp start name tipe (arg : revArgs)
549+ , do word1 0x3D {-=-} E.XXX
550+ spaces
551+ (body, end, space) <- expression
552+ let def = A.at start end (Src.Define name (reverse revArgs) body tipe)
553+ return ( def, end, space )
540554 ]
541555
542556
543−chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
544−chompMatchingName expectedName =
545− let
546− (P.Parser parserL) = Var.lower E.DefNameRepeat
547− in
548− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
557+matchingName :: Name.Name -> Parser (A.Located Name.Name)
558+matchingName expectedName =
559+ let (P.Parser parserL) = Var.lower in
560+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->
549561 let
550− cokL name newState@(P.State _ _ _ _ er ec) =
562+ cokL name newState@(P.State _ _ _ er ec _) =
551563 if expectedName == name
552564 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
553− else cerr sr sc (E.DefNameMatch name)
565+ else cerr sr sc ctx (E.MatchingName expectedName)
554566
555− eokL name newState@(P.State _ _ _ _ er ec) =
567+ eokL name newState@(P.State _ _ _ er ec _) =
556568 if expectedName == name
557569 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
558− else eerr sr sc (E.DefNameMatch name)
570+ else eerr sr sc ctx (E.MatchingName expectedName)
559571 in
560572 parserL state cokL eokL cerr eerr
561573
@@ -565,13 +577,12 @@ chompMatchingName expectedName =
565577-- DESTRUCTURE
566578
567579
568−destructure :: Space.Parser E.Let (A.Located Src.Def)
580+destructure :: SParser (A.Located Src.Def)
569581destructure =
570− specialize E.LetDestruct $
571582 do start <- getPosition
572− pattern <- specialize E.DestructPattern Pattern.term
573− Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals
574− word1 0x3D {-=-} E.DestructEquals
575− Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody
576− (expr, end) <- specialize E.DestructBody expression
577− return ( A.at start end (Src.Destruct pattern expr), end )
583+ pattern <- Pattern.term
584+ spaces
585+ word1 0x3D {-=-} E.XXX
586+ spaces
587+ (expr, end, space) <- expression
588+ return ( A.at start end (Src.Destruct pattern expr), end, space )
compiler/src/Parse/Keyword.hs+84−83
@@ -16,111 +16,112 @@ module Parse.Keyword
1616import Foreign.Ptr (plusPtr)
1717import Data.Word (Word8)
1818
19−import Parse.Primitives (Parser, Row, Col)
19+import Parse.Utils (Parser)
2020import qualified Parse.Variable as Var
2121import qualified Parse.Primitives as P
22+import qualified Reporting.Error.Syntax as E
2223
2324
2425
2526-- DECLARATIONS
2627
2728
28−type_ :: (Row -> Col -> x) -> Parser x ()
29−type_ tx = k4 0x74 0x79 0x70 0x65 tx
29+type_ :: Parser ()
30+type_ = k4 0x74 0x79 0x70 0x65 E.KeywordType
3031
31−alias_ :: (Row -> Col -> x) -> Parser x ()
32−alias_ tx = k5 0x61 0x6C 0x69 0x61 0x73 tx
32+alias_ :: Parser ()
33+alias_ = k5 0x61 0x6C 0x69 0x61 0x73 E.KeywordAlias
3334
34−port_ :: (Row -> Col -> x) -> Parser x ()
35−port_ tx = k4 0x70 0x6F 0x72 0x74 tx
35+port_ :: Parser ()
36+port_ = k4 0x70 0x6F 0x72 0x74 E.KeywordPort
3637
3738
3839
3940-- IF EXPRESSIONS
4041
4142
42−if_ :: (Row -> Col -> x) -> Parser x ()
43−if_ tx = k2 0x69 0x66 tx
43+if_ :: Parser ()
44+if_ = k2 0x69 0x66 E.KeywordIf
4445
45−then_ :: (Row -> Col -> x) -> Parser x ()
46−then_ tx = k4 0x74 0x68 0x65 0x6E tx
46+then_ :: Parser ()
47+then_ = k4 0x74 0x68 0x65 0x6E E.KeywordThen
4748
48−else_ :: (Row -> Col -> x) -> Parser x ()
49−else_ tx = k4 0x65 0x6C 0x73 0x65 tx
49+else_ :: Parser ()
50+else_ = k4 0x65 0x6C 0x73 0x65 E.KeywordElse
5051
5152
5253
5354-- CASE EXPRESSIONS
5455
5556
56−case_ :: (Row -> Col -> x) -> Parser x ()
57−case_ tx = k4 0x63 0x61 0x73 0x65 tx
57+case_ :: Parser ()
58+case_ = k4 0x63 0x61 0x73 0x65 E.KeywordCase
5859
59−of_ :: (Row -> Col -> x) -> Parser x ()
60−of_ tx = k2 0x6F 0x66 tx
60+of_ :: Parser ()
61+of_ = k2 0x6F 0x66 E.KeywordOf
6162
6263
6364
6465-- LET EXPRESSIONS
6566
6667
67−let_ :: (Row -> Col -> x) -> Parser x ()
68−let_ tx = k3 0x6C 0x65 0x74 tx
68+let_ :: Parser ()
69+let_ = k3 0x6C 0x65 0x74 E.KeywordLet
6970
70−in_ :: (Row -> Col -> x) -> Parser x ()
71−in_ tx = k2 0x69 0x6E tx
71+in_ :: Parser ()
72+in_ = k2 0x69 0x6E E.KeywordIn
7273
7374
7475
7576-- INFIXES
7677
7778
78−infix_ :: (Row -> Col -> x) -> Parser x ()
79−infix_ tx = k5 0x69 0x6E 0x66 0x69 0x78 tx
79+infix_ :: Parser ()
80+infix_ = k5 0x69 0x6E 0x66 0x69 0x78 E.KeywordInfix
8081
81−left_ :: (Row -> Col -> x) -> Parser x ()
82−left_ tx = k4 0x6C 0x65 0x66 0x74 tx
82+left_ :: Parser ()
83+left_ = k4 0x6C 0x65 0x66 0x74 E.Associativity
8384
84−right_ :: (Row -> Col -> x) -> Parser x ()
85−right_ tx = k5 0x72 0x69 0x67 0x68 0x74 tx
85+right_ :: Parser ()
86+right_ = k5 0x72 0x69 0x67 0x68 0x74 E.Associativity
8687
87−non_ :: (Row -> Col -> x) -> Parser x ()
88−non_ tx = k3 0x6E 0x6F 0x6E tx
88+non_ :: Parser ()
89+non_ = k3 0x6E 0x6F 0x6E E.Associativity
8990
9091
9192
9293-- IMPORTS
9394
9495
95−module_ :: (Row -> Col -> x) -> Parser x ()
96−module_ tx = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 tx
96+module_ :: Parser ()
97+module_ = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 E.KeywordModule
9798
98−import_ :: (Row -> Col -> x) -> Parser x ()
99−import_ tx = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 tx
99+import_ :: Parser ()
100+import_ = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 E.KeywordImport
100101
101−exposing_ :: (Row -> Col -> x) -> Parser x ()
102−exposing_ tx = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 tx
102+exposing_ :: Parser ()
103+exposing_ = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 E.KeywordExposing
103104
104−as_ :: (Row -> Col -> x) -> Parser x ()
105−as_ tx = k2 0x61 0x73 tx
105+as_ :: Parser ()
106+as_ = k2 0x61 0x73 E.KeywordAs
106107
107108
108109
109110-- EFFECTS
110111
111112
112−effect_ :: (Row -> Col -> x) -> Parser x ()
113−effect_ tx = k6 0x65 0x66 0x66 0x65 0x63 0x74 tx
113+effect_ :: Parser ()
114+effect_ = k6 0x65 0x66 0x66 0x65 0x63 0x74 E.EffectStuff
114115
115−where_ :: (Row -> Col -> x) -> Parser x ()
116−where_ tx = k5 0x77 0x68 0x65 0x72 0x65 tx
116+where_ :: Parser ()
117+where_ = k5 0x77 0x68 0x65 0x72 0x65 E.EffectStuff
117118
118−command_ :: (Row -> Col -> x) -> Parser x ()
119−command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx
119+command_ :: Parser ()
120+command_ = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 E.EffectStuff
120121
121−subscription_ :: (Row -> Col -> x) -> Parser x ()
122−subscription_ toError =
123− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
122+subscription_ :: Parser ()
123+subscription_ =
124+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
124125 let !pos12 = plusPtr pos 12 in
125126 if pos12 <= end
126127 && P.unsafeIndex ( pos ) == 0x73
@@ -137,32 +138,32 @@ subscription_ toError =
137138 && P.unsafeIndex (plusPtr pos 11) == 0x6E
138139 && Var.getInnerWidth pos12 end == 0
139140 then
140− let !s = P.State src pos12 end indent row (col + 12) in cok () s
141+ let !s = P.State pos12 end indent row (col + 12) ctx in cok () s
141142 else
142− eerr row col toError
143+ eerr row col ctx E.EffectStuff
143144
144145
145146
146147-- KEYWORDS
147148
148149
149−k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
150−k2 w1 w2 toError =
151− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
150+k2 :: Word8 -> Word8 -> x -> P.Parser c x ()
151+k2 w1 w2 x =
152+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
152153 let !pos2 = plusPtr pos 2 in
153154 if pos2 <= end
154155 && P.unsafeIndex ( pos ) == w1
155156 && P.unsafeIndex (plusPtr pos 1) == w2
156157 && Var.getInnerWidth pos2 end == 0
157158 then
158− let !s = P.State src pos2 end indent row (col + 2) in cok () s
159+ let !s = P.State pos2 end indent row (col + 2) ctx in cok () s
159160 else
160− eerr row col toError
161+ eerr row col ctx x
161162
162163
163−k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
164−k3 w1 w2 w3 toError =
165− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
164+k3 :: Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
165+k3 w1 w2 w3 x =
166+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
166167 let !pos3 = plusPtr pos 3 in
167168 if pos3 <= end
168169 && P.unsafeIndex ( pos ) == w1
@@ -170,14 +171,14 @@ k3 w1 w2 w3 toError =
170171 && P.unsafeIndex (plusPtr pos 2) == w3
171172 && Var.getInnerWidth pos3 end == 0
172173 then
173− let !s = P.State src pos3 end indent row (col + 3) in cok () s
174+ let !s = P.State pos3 end indent row (col + 3) ctx in cok () s
174175 else
175− eerr row col toError
176+ eerr row col ctx x
176177
177178
178−k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
179−k4 w1 w2 w3 w4 toError =
180− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
179+k4 :: Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
180+k4 w1 w2 w3 w4 x =
181+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
181182 let !pos4 = plusPtr pos 4 in
182183 if pos4 <= end
183184 && P.unsafeIndex ( pos ) == w1
@@ -186,14 +187,14 @@ k4 w1 w2 w3 w4 toError =
186187 && P.unsafeIndex (plusPtr pos 3) == w4
187188 && Var.getInnerWidth pos4 end == 0
188189 then
189− let !s = P.State src pos4 end indent row (col + 4) in cok () s
190+ let !s = P.State pos4 end indent row (col + 4) ctx in cok () s
190191 else
191− eerr row col toError
192+ eerr row col ctx x
192193
193194
194−k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
195−k5 w1 w2 w3 w4 w5 toError =
196− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
195+k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
196+k5 w1 w2 w3 w4 w5 x =
197+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
197198 let !pos5 = plusPtr pos 5 in
198199 if pos5 <= end
199200 && P.unsafeIndex ( pos ) == w1
@@ -203,14 +204,14 @@ k5 w1 w2 w3 w4 w5 toError =
203204 && P.unsafeIndex (plusPtr pos 4) == w5
204205 && Var.getInnerWidth pos5 end == 0
205206 then
206− let !s = P.State src pos5 end indent row (col + 5) in cok () s
207+ let !s = P.State pos5 end indent row (col + 5) ctx in cok () s
207208 else
208− eerr row col toError
209+ eerr row col ctx x
209210
210211
211−k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
212−k6 w1 w2 w3 w4 w5 w6 toError =
213− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
212+k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
213+k6 w1 w2 w3 w4 w5 w6 x =
214+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
214215 let !pos6 = plusPtr pos 6 in
215216 if pos6 <= end
216217 && P.unsafeIndex ( pos ) == w1
@@ -221,14 +222,14 @@ k6 w1 w2 w3 w4 w5 w6 toError =
221222 && P.unsafeIndex (plusPtr pos 5) == w6
222223 && Var.getInnerWidth pos6 end == 0
223224 then
224− let !s = P.State src pos6 end indent row (col + 6) in cok () s
225+ let !s = P.State pos6 end indent row (col + 6) ctx in cok () s
225226 else
226− eerr row col toError
227+ eerr row col ctx x
227228
228229
229−k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
230−k7 w1 w2 w3 w4 w5 w6 w7 toError =
231− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
230+k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
231+k7 w1 w2 w3 w4 w5 w6 w7 x =
232+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
232233 let !pos7 = plusPtr pos 7 in
233234 if pos7 <= end
234235 && P.unsafeIndex ( pos ) == w1
@@ -240,14 +241,14 @@ k7 w1 w2 w3 w4 w5 w6 w7 toError =
240241 && P.unsafeIndex (plusPtr pos 6) == w7
241242 && Var.getInnerWidth pos7 end == 0
242243 then
243− let !s = P.State src pos7 end indent row (col + 7) in cok () s
244+ let !s = P.State pos7 end indent row (col + 7) ctx in cok () s
244245 else
245− eerr row col toError
246+ eerr row col ctx x
246247
247248
248−k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
249−k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
250− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
249+k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
250+k8 w1 w2 w3 w4 w5 w6 w7 w8 x =
251+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
251252 let !pos8 = plusPtr pos 8 in
252253 if pos8 <= end
253254 && P.unsafeIndex ( pos ) == w1
@@ -260,6 +261,6 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
260261 && P.unsafeIndex (plusPtr pos 7) == w8
261262 && Var.getInnerWidth pos8 end == 0
262263 then
263− let !s = P.State src pos8 end indent row (col + 8) in cok () s
264+ let !s = P.State pos8 end indent row (col + 8) ctx in cok () s
264265 else
265− eerr row col toError
266+ eerr row col ctx x
compiler/src/Parse/Module.hs+259−330

This diff is too big to show here.

compiler/src/Parse/Number.hs+34−37

This diff is too big to show here.

compiler/src/Parse/Pattern.hs+130−138

This diff is too big to show here.

compiler/src/Parse/Primitives.hs+123−199

This diff is too big to show here.

compiler/src/Parse/Repl.hsnew file+117

This diff is too big to show here.

compiler/src/Parse/Shader.hs+24−25

This diff is too big to show here.

compiler/src/Parse/Space.hsdeleted−273

This diff is too big to show here.

compiler/src/Parse/Symbol.hs+37−22

This diff is too big to show here.

compiler/src/Parse/Type.hs+103−101

This diff is too big to show here.

compiler/src/Parse/String.hs → compiler/src/Parse/Utf8.hsrenamed+94−104

This diff is too big to show here.

compiler/src/Parse/Utils.hsnew file+259

This diff is too big to show here.

compiler/src/Parse/Variable.hs+49−54

This diff is too big to show here.

compiler/src/Reporting/Annotation.hs+1−1

This diff is too big to show here.

compiler/src/Reporting/Doc.hs+54−96

This diff is too big to show here.

compiler/src/Reporting/Error.hs+22−175

This diff is too big to show here.

compiler/src/Reporting/Error/Canonicalize.hs+127−115

This diff is too big to show here.

compiler/src/Reporting/Error/Docs.hs+23−132

This diff is too big to show here.

compiler/src/Reporting/Error/Import.hsdeleted−162

This diff is too big to show here.

compiler/src/Reporting/Error/Json.hs+270−280

This diff is too big to show here.

compiler/src/Reporting/Error/Main.hs+6−6

This diff is too big to show here.

compiler/src/Reporting/Error/Pattern.hs+8−9

This diff is too big to show here.

compiler/src/Reporting/Error/Syntax.hs+626−5687

This diff is too big to show here.

compiler/src/Reporting/Error/Type.hs+32−53

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hs+10−154

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+27−7

This diff is too big to show here.

compiler/src/Reporting/Report.hs+63

This diff is too big to show here.

compiler/src/Reporting/Result.hs+2−12

This diff is too big to show here.

compiler/src/Reporting/Warning.hs+3−3

This diff is too big to show here.

compiler/src/Type/Constrain/Module.hs+3−3

This diff is too big to show here.

compiler/src/Type/Error.hs+123−14

This diff is too big to show here.

compiler/src/Type/Solve.hs+3−11

This diff is too big to show here.

compiler/src/Type/Unify.hs+10−12

This diff is too big to show here.

docs/elm.json/application.md+2−2

This diff is too big to show here.

docs/elm.json/package.md+1−1

This diff is too big to show here.

docs/upgrade-instructions/0.19.1.mddeleted−60

This diff is too big to show here.

elm.cabal+98−69

This diff is too big to show here.

hints/bad-recursion.mddeleted−133

This diff is too big to show here.

hints/comparing-custom-types.mddeleted−98

This diff is too big to show here.

hints/comparing-records.mddeleted−85

This diff is too big to show here.

hints/implicit-casts.mddeleted−50

This diff is too big to show here.

hints/import-cycles.mddeleted−184

This diff is too big to show here.

hints/imports.mddeleted−126

This diff is too big to show here.

hints/infinite-type.mddeleted−42

This diff is too big to show here.

hints/init.mddeleted−55

This diff is too big to show here.

hints/missing-patterns.mddeleted−139

This diff is too big to show here.

hints/optimize.mddeleted−59

This diff is too big to show here.

hints/port-modules.mddeleted−32

This diff is too big to show here.

hints/recursive-alias.mddeleted−162

This diff is too big to show here.

hints/repl.mddeleted−73

This diff is too big to show here.

hints/shadowing.mddeleted−70

This diff is too big to show here.

hints/tuples.mddeleted−19

This diff is too big to show here.

hints/type-annotations.mddeleted−60

This diff is too big to show here.

installers/README.mddeleted−32

This diff is too big to show here.

installers/linux/Dockerfiledeleted−39

This diff is too big to show here.

installers/linux/README.mddeleted−93

This diff is too big to show here.

installers/mac/Distribution.xml+3−5

This diff is too big to show here.

installers/mac/README.mddeleted−93

This diff is too big to show here.

installers/mac/Resources/en.lproj/background.pngnew file

Binary file not shown.

installers/mac/Resources/en.lproj/conclusion.rtf+6−13

This diff is too big to show here.

installers/mac/Resources/en.lproj/welcome.rtf+4−9

This diff is too big to show here.

installers/mac/helper-scripts/elm-startup.sh+1−1

This diff is too big to show here.

installers/mac/make-installer.sh+3−30

This diff is too big to show here.

installers/npm/PUBLISHING.md+141−29

This diff is too big to show here.

installers/npm/README.md+23−30

This diff is too big to show here.

installers/npm/bin/elmmode 100755 → 100644+41−47

This diff is too big to show here.

installers/npm/download.jsdeleted−114

This diff is too big to show here.

installers/npm/index.jsnew file+21

This diff is too big to show here.

installers/npm/install.jsdeleted−4

This diff is too big to show here.

installers/npm/package.json+15−13

This diff is too big to show here.

installers/npm/troubleshooting.mddeleted−76

This diff is too big to show here.

installers/win/Nsisfile.nsi+16−16

This diff is too big to show here.

installers/win/README.md+3−18

This diff is too big to show here.

installers/win/file.iconew file

Binary file not shown.

installers/win/inst.dat+2−1

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+2−1

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifnew file

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+15−20

This diff is too big to show here.

reactor/src/Index/Navigator.elm+1−1

This diff is too big to show here.

roadmap.mddeleted−29

This diff is too big to show here.

terminal/impl/Terminal/Helpers.hsdeleted−148

This diff is too big to show here.

terminal/src/Bump.hs+8−158

This diff is too big to show here.

terminal/src/Develop.hs+77−70

This diff is too big to show here.

terminal/src/Develop/Generate/Index.hs+74−149

This diff is too big to show here.

terminal/src/Develop/StaticFiles.hs+7−1

This diff is too big to show here.

terminal/src/Develop/StaticFiles/Build.hs+29−46

This diff is too big to show here.

terminal/src/Diff.hs+6−348

This diff is too big to show here.

terminal/src/Init.hs+36−40

This diff is too big to show here.

terminal/src/Install.hs+14−401

This diff is too big to show here.

terminal/src/Main.hs+36−32

This diff is too big to show here.

terminal/src/Make.hs+32−257

This diff is too big to show here.

terminal/src/Publish.hs+8−529

This diff is too big to show here.

terminal/src/Repl.hs+197−522

This diff is too big to show here.

terminal/impl/Terminal.hs → terminal/src/Terminal/Args.hsrenamed+27−33

This diff is too big to show here.

terminal/impl/Terminal/Chomp.hs → terminal/src/Terminal/Args/Chomp.hsrenamed+5−4

This diff is too big to show here.

terminal/impl/Terminal/Error.hs → terminal/src/Terminal/Args/Error.hsrenamed+18−28

This diff is too big to show here.

terminal/src/Terminal/Args/Helpers.hsnew file+125

This diff is too big to show here.

terminal/impl/Terminal/Internal.hs → terminal/src/Terminal/Args/Internal.hsrenamed+8−8

This diff is too big to show here.

docs/upgrade-instructions/0.16.md → upgrade-docs/0.16.mdrenamed

The content is the same.

docs/upgrade-instructions/0.17.md → upgrade-docs/0.17.mdrenamed

The content is the same.

docs/upgrade-instructions/0.18.md → upgrade-docs/0.18.mdrenamed

The content is the same.

docs/upgrade-instructions/0.19.0.md → upgrade-docs/0.19.mdrenamed

The content is the same.

docs/upgrade-instructions/earlier.md → upgrade-docs/earlier.mdrenamed

The content is the same.

worker/elm.cabaldeleted−210

This diff is too big to show here.

worker/elm.jsondeleted−26

This diff is too big to show here.

worker/nginx.confdeleted−22

This diff is too big to show here.

worker/outlines/compile/elm.jsondeleted−32

This diff is too big to show here.

worker/outlines/repl/elm.jsondeleted−19

This diff is too big to show here.

worker/src/Artifacts.hsdeleted−155

This diff is too big to show here.

worker/src/Cors.hsdeleted−48

This diff is too big to show here.

worker/src/Endpoint/Compile.hsdeleted−323

This diff is too big to show here.

worker/src/Endpoint/Quotes.hsdeleted−114

This diff is too big to show here.

worker/src/Endpoint/Repl.hsdeleted−244

This diff is too big to show here.

worker/src/Errors.elmdeleted−217

This diff is too big to show here.

worker/src/Main.hsdeleted−73

This diff is too big to show here.