on af7a6b4 help sign in
302 files changed+19901−32732
since splitsnapshots
unifiedsplit
.github/CONTRIBUTING.md+20−18 .github/ISSUE_TEMPLATE.md+9−14 .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+60−80 builder/src/Deps/Explorer.hs+118 builder/src/Deps/Get.hs+211 builder/src/Deps/Plan.hs+64 builder/src/Deps/Registry.hs−213 builder/src/Deps/Solver.hs+58−399 builder/src/Deps/Verify.hs+365 builder/src/Deps/Website.hs+333−14 builder/src/Elm/Bump.hs+139 builder/src/Elm/Details.hs−833 builder/src/Elm/Diff.hs+279 builder/src/Elm/Install.hs+357 builder/src/Elm/Outline.hs−407 builder/src/Elm/PerUserCache.hs+47 builder/src/Elm/Project.hs+98 builder/src/Elm/Project/Constraint.hs+234 builder/src/Elm/Project/Json.hs+423 compiler/src/Elm/Licenses.hs → builder/src/Elm/Project/Licenses.hs+59−65 builder/src/Elm/Project/Root.hs+94 builder/src/Elm/Project/Summary.hs+105 builder/src/Elm/Publish.hs+255 builder/src/File.hs−231 builder/src/File/Args.hs+40 builder/src/File/Artifacts.hs+138 builder/src/File/Compile.hs+192 builder/src/File/Crawl.hs+297 builder/src/File/Find.hs+109 builder/src/File/Hash.hs+110 builder/src/File/Header.hs+191 builder/src/File/IO.hs+251 builder/src/File/Plan.hs+205 builder/src/File/Watcher.hs+76 builder/src/Generate.hs−211 compiler/src/Generate/JavaScript/Functions.hs → builder/src/Generate/Functions.hs+3−6 builder/src/Generate/Html.hs+53 compiler/src/Nitpick/Debug.hs → builder/src/Generate/Nitpick.hs+22−10 builder/src/Generate/Output.hs+281 builder/src/Http.hs−244 builder/src/Reporting.hs−474 builder/src/Reporting/Exit.hs+72−2018 builder/src/Reporting/Exit/Assets.hs+231 builder/src/Reporting/Exit/Bump.hs+51 builder/src/Reporting/Exit/Compile.hs+105 builder/src/Reporting/Exit/Crawl.hs+326 builder/src/Reporting/Exit/Deps.hs+106 builder/src/Reporting/Exit/Diff.hs+66 builder/src/Reporting/Exit/Help.hs+18−18 builder/src/Reporting/Exit/Http.hs+101 builder/src/Reporting/Exit/Install.hs+82 builder/src/Reporting/Exit/Make.hs+75 builder/src/Reporting/Exit/Publish.hs+241 builder/src/Reporting/Progress.hs+106 builder/src/Reporting/Progress/Bar.hs+43 builder/src/Reporting/Progress/Json.hs+31 builder/src/Reporting/Progress/Repl.hs+27 builder/src/Reporting/Progress/Terminal.hs+360 builder/src/Reporting/Task.hs+165−76 builder/src/Reporting/Task/Http.hs+195 builder/src/Stuff.hs−179 builder/src/Stuff/Paths.hs+99 builder/src/Stuff/Verify.hs+96 cabal.config−2 compiler/src/AST/Canonical.hs+73−68 compiler/src/AST/Module/Name.hs+208 compiler/src/AST/Optimized.hs+104−141 compiler/src/AST/Source.hs+72−88 compiler/src/AST/Utils/Binop.hs+6−5 compiler/src/AST/Utils/Shader.hs+10−65 compiler/src/AST/Utils/Type.hs+5−4 compiler/src/AST/Valid.hs+124 compiler/src/Canonicalize/Effects.hs+37−36 compiler/src/Canonicalize/Environment.hs+42−72 compiler/src/Canonicalize/Environment/Dups.hs+16−18 compiler/src/Canonicalize/Environment/Foreign.hs+92−90 compiler/src/Canonicalize/Environment/Local.hs+54−52 compiler/src/Canonicalize/Expression.hs+73−71 compiler/src/Canonicalize/Module.hs+74−65 compiler/src/Canonicalize/Pattern.hs+12−16 compiler/src/Canonicalize/Type.hs+7−6 compiler/src/Compile.hs+76−41 compiler/src/Data/Bag.hs+11 compiler/src/Data/Map/Utils.hs−43 compiler/src/Data/Name.hs−610 compiler/src/Data/NonEmptyList.hs−78 compiler/src/Data/OneOrMore.hs+16−51 compiler/src/Data/Utf8.hs−618 compiler/src/Elm/Compiler.hs+97 compiler/src/Elm/Compiler/Imports.hs+36−24 compiler/src/Elm/Compiler/Module.hs+96 compiler/src/Elm/Compiler/Objects.hs+108 compiler/src/Elm/Compiler/Type.hs+42−40 compiler/src/Elm/Compiler/Type/Extract.hs+27−79 compiler/src/Elm/Compiler/Version.hs+27 compiler/src/Elm/Constraint.hs−260 compiler/src/Elm/Docs.hs+189−243 compiler/src/Elm/Float.hs−51 compiler/src/Elm/Header.hs+73 compiler/src/Elm/Interface.hs+73−101 compiler/src/Elm/Kernel.hs+151−268 compiler/src/Elm/Magnitude.hs−24 compiler/src/Elm/ModuleName.hs−283 compiler/src/Elm/Name.hs+337 compiler/src/Elm/Package.hs+262−208 compiler/src/Elm/String.hs−133 compiler/src/Elm/Version.hs−196 compiler/src/Generate/Html.hs−54 compiler/src/Generate/JavaScript.hs+165−222 compiler/src/Generate/JavaScript/Builder.hs+219−209 compiler/src/Generate/JavaScript/Expression.hs+213−218 compiler/src/Generate/JavaScript/Mode.hs+106 compiler/src/Generate/JavaScript/Name.hs+44−50 compiler/src/Generate/Mode.hs−63 compiler/src/Json/Decode.hs+209−698 compiler/src/Json/Decode/Error.hs+266 compiler/src/Json/Decode/Internals.hs+368 compiler/src/Json/Encode.hs+58−46 compiler/src/Json/String.hs−192 compiler/src/Nitpick/PatternMatches.hs+30−33 compiler/src/Optimize/Case.hs+2−2 compiler/src/Optimize/DecisionTree.hs+8−29 compiler/src/Optimize/Expression.hs+32−46 compiler/src/Optimize/Module.hs+91−86 compiler/src/Optimize/Names.hs+24−18 compiler/src/Optimize/Port.hs+36−36 compiler/src/Parse/Declaration.hs+131−200 compiler/src/Parse/Expression.hs+363−375 compiler/src/Parse/Keyword.hs−265 compiler/src/Parse/Module.hs+220−411 compiler/src/Parse/Number.hs−305 compiler/src/Parse/Parse.hs+65 compiler/src/Parse/Pattern.hs+159−165 compiler/src/Parse/Primitives.hs+142−318 compiler/src/Parse/Primitives/Internals.hs+251 compiler/src/Parse/Primitives/Kernel.hs+116 compiler/src/Parse/Primitives/Keyword.hs+235 compiler/src/Parse/Primitives/Number.hs+297 compiler/src/Parse/Primitives/Shader.hs+69 compiler/src/Parse/Primitives/Symbol.hs+259 compiler/src/Parse/Primitives/Utf8.hs+471 compiler/src/Parse/Primitives/Variable.hs+376 compiler/src/Parse/Primitives/Whitespace.hs+223 compiler/src/Parse/Repl.hs+128 compiler/src/Parse/Shader.hs+31−111 compiler/src/Parse/Space.hs−273 compiler/src/Parse/String.hs−343 compiler/src/Parse/Symbol.hs−79 compiler/src/Parse/Type.hs+152−127 compiler/src/Parse/Variable.hs−387 compiler/src/Reporting/Annotation.hs+24−67 compiler/src/Reporting/Doc.hs+63−101 compiler/src/Reporting/Error.hs+22−175 compiler/src/Reporting/Error/Canonicalize.hs+249−237 compiler/src/Reporting/Error/Docs.hs+36−146 compiler/src/Reporting/Error/Import.hs−162 compiler/src/Reporting/Error/Json.hs−344 compiler/src/Reporting/Error/Main.hs+12−13 compiler/src/Reporting/Error/Pattern.hs+8−9 compiler/src/Reporting/Error/Syntax.hs+627−5688 compiler/src/Reporting/Error/Type.hs+140−155 compiler/src/Reporting/Region.hs+93 compiler/src/Reporting/Render/Code.hs+44−181 compiler/src/Reporting/Render/Type.hs+6−5 compiler/src/Reporting/Render/Type/Localizer.hs+42−29 compiler/src/Reporting/Report.hs+65−2 compiler/src/Reporting/Result.hs+2−12 compiler/src/Reporting/Suggest.hs−17 compiler/src/Reporting/Warning.hs+14−14 compiler/src/Type/Constrain/Expression.hs+36−35 compiler/src/Type/Constrain/Module.hs+22−21 compiler/src/Type/Constrain/Pattern.hs+11−15 compiler/src/Type/Error.hs+183−107 compiler/src/Type/Instantiate.hs+4−4 compiler/src/Type/Solve.hs+16−24 compiler/src/Type/Type.hs+49−42 compiler/src/Type/Unify.hs+22−24 compiler/src/Validate.hs+334 docs/elm.json/application.md+12−18 docs/elm.json/package.md+5−5 docs/repl.md+66 docs/upgrade-instructions/0.19.0.md−164 docs/upgrade-instructions/0.19.1.md−60 elm.cabal+175−149 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−59 installers/npm/README.md+23−30 installers/npm/UPLOADING.md+8 installers/npm/bin/elm−54 installers/npm/binaries/elm+1 installers/npm/binaries/elm-make+1 installers/npm/binaries/elm-package+1 installers/npm/binaries/elm-reactor+1 installers/npm/binaries/elm-repl+1 installers/npm/download.js−114 installers/npm/install.js+32−2 installers/npm/package.json+24−16 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/elm.json−31 reactor/src/Deps.elm−1210 reactor/src/mock.txt−33 roadmap.md−29 terminal/impl/Terminal/Helpers.hs−148 terminal/src/Bump.hs−169 terminal/src/Develop/Generate/Index.hs−213 terminal/src/Develop/StaticFiles/Build.hs−73 terminal/src/Diff.hs−359 terminal/src/Init.hs−104 terminal/src/Install.hs−425 terminal/src/Make.hs−319 terminal/src/Publish.hs−540 terminal/src/Repl.hs−726 reactor/assets/favicon.ico → ui/browser/assets/favicon.ico reactor/assets/source-code-pro.ttf → ui/browser/assets/source-code-pro.ttf reactor/assets/source-sans-pro.ttf → ui/browser/assets/source-sans-pro.ttf reactor/assets/styles.css → ui/browser/assets/styles.css+90−1 ui/browser/assets/waiting.gif reactor/check.py → ui/browser/check.py ui/browser/elm.json+25 reactor/src/Errors.elm → ui/browser/src/Errors.elm+10−19 reactor/src/Index.elm → ui/browser/src/Index.elm+31−52 reactor/src/Index/Icon.elm → ui/browser/src/Index/Icon.elm reactor/src/Index/Navigator.elm → ui/browser/src/Index/Navigator.elm+1−1 reactor/src/Index/Skeleton.elm → ui/browser/src/Index/Skeleton.elm reactor/src/NotFound.elm → ui/browser/src/NotFound.elm+2−2 ui/terminal/src/Bump.hs+19 terminal/src/Develop.hs → ui/terminal/src/Develop.hs+78−70 terminal/src/Develop/Generate/Help.hs → ui/terminal/src/Develop/Generate/Help.hs+4−6 ui/terminal/src/Develop/Generate/Index.hs+134 terminal/src/Develop/Socket.hs → ui/terminal/src/Develop/Socket.hs terminal/src/Develop/StaticFiles.hs → ui/terminal/src/Develop/StaticFiles.hs+7−1 ui/terminal/src/Develop/StaticFiles/Build.hs+56 ui/terminal/src/Diff.hs+17 ui/terminal/src/Install.hs+38 terminal/src/Main.hs → ui/terminal/src/Main.hs+52−64 ui/terminal/src/Make.hs+94 ui/terminal/src/Publish.hs+19 ui/terminal/src/Repl.hs+401 terminal/impl/Terminal.hs → ui/terminal/src/Terminal/Args.hs+41−42 terminal/impl/Terminal/Chomp.hs → ui/terminal/src/Terminal/Args/Chomp.hs+5−4 terminal/impl/Terminal/Error.hs → ui/terminal/src/Terminal/Args/Error.hs+19−32 ui/terminal/src/Terminal/Args/Helpers.hs+125 terminal/impl/Terminal/Internal.hs → ui/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/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/ISSUE_TEMPLATE.md+9−14
@@ -1,18 +1,13 @@
1+BEFORE DELETING THIS:
12
2−**Quick Summary:** ???
3+- Runtime error? https://github.com/elm-lang/elm-compiler/issues/1591
4+- Type annotations? https://github.com/elm-lang/elm-compiler/issues/1214
5+- Core libraries? https://github.com/elm-lang/core/issues
6+- Bad error message? https://github.com/elm-lang/error-message-catalog/issues
7+- Compiler hangs? https://github.com/elm-lang/elm-compiler/issues/1240
8+- Parser / code gen problem? https://github.com/elm-lang/elm-compiler/labels/meta
39
410
5−## SSCCE
11+If none of that applies, write up a report that satisfies this checklist:
612
7−```elm
8−
9−```
10−
11−- **Elm:** ???
12−- **Browser:** ???
13−- **Operating System:** ???
14−
15−
16−## Additional Details
17−
18−???
13+ https://github.com/process-bot/contribution-checklist/blob/master/issues.md
.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+60−80
@@ -4,10 +4,11 @@ module Deps.Diff
44 , PackageChanges(..)
55 , ModuleChanges(..)
66 , Changes(..)
7+ , Magnitude(..)
78 , moduleChangeMagnitude
9+ , magnitudeToString
810 , toMagnitude
911 , bump
10− , getDocs
1112 )
1213 where
1314
@@ -16,23 +17,14 @@ import Control.Monad (zipWithM)
1617import Data.Function (on)
1718import qualified Data.List as List
1819import qualified Data.Map as Map
19−import qualified Data.Name as Name
2020import qualified Data.Set as Set
21−import qualified System.Directory as Dir
22−import System.FilePath ((</>))
21+import qualified Data.Text as Text
2322
24−import qualified Deps.Website as Website
23+import qualified Elm.Compiler.Module as Module
2524import qualified Elm.Compiler.Type as Type
2625import qualified Elm.Docs as Docs
27−import qualified Elm.Magnitude as M
28−import qualified Elm.ModuleName as ModuleName
26+import qualified Elm.Name as N
2927import qualified Elm.Package as Pkg
30−import qualified Elm.Version as V
31−import qualified File
32−import qualified Http
33−import qualified Json.Decode as D
34−import qualified Reporting.Exit as Exit
35−import qualified Stuff
3628
3729
3830
@@ -41,18 +33,18 @@ import qualified Stuff
4133
4234data PackageChanges =
4335 PackageChanges
44− { _modules_added :: [ModuleName.Raw]
45− , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
46− , _modules_removed :: [ModuleName.Raw]
36+ { _modules_added :: [Module.Raw]
37+ , _modules_changed :: Map.Map Module.Raw ModuleChanges
38+ , _modules_removed :: [Module.Raw]
4739 }
4840
4941
5042data ModuleChanges =
5143 ModuleChanges
52− { _unions :: Changes Name.Name Docs.Union
53− , _aliases :: Changes Name.Name Docs.Alias
54− , _values :: Changes Name.Name Docs.Value
55− , _binops :: Changes Name.Name Docs.Binop
44+ { _unions :: Changes N.Name Docs.Union
45+ , _aliases :: Changes N.Name Docs.Alias
46+ , _values :: Changes N.Name Docs.Value
47+ , _binops :: Changes N.Name Docs.Binop
5648 }
5749
5850
@@ -81,7 +73,7 @@ diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
8173diff oldDocs newDocs =
8274 let
8375 filterOutPatches chngs =
84− Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
76+ Map.filter (\chng -> moduleChangeMagnitude chng /= PATCH) chngs
8577
8678 (Changes added changed removed) =
8779 getChanges (\_ _ -> False) oldDocs newDocs
@@ -152,7 +144,7 @@ isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
152144-- DIFF TYPES
153145
154146
155−diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
147+diffType :: Type.Type -> Type.Type -> Maybe [(N.Name,N.Name)]
156148diffType oldType newType =
157149 case (oldType, newType) of
158150 (Type.Var oldName, Type.Var newName) ->
@@ -200,11 +192,11 @@ diffType oldType newType =
200192
201193
202194-- handle very old docs that do not use qualified names
203−isSameName :: Name.Name -> Name.Name -> Bool
195+isSameName :: N.Name -> N.Name -> Bool
204196isSameName oldFullName newFullName =
205197 let
206198 dedot name =
207− reverse (Name.splitDots name)
199+ reverse (Text.splitOn "." (N.toText name))
208200 in
209201 case ( dedot oldFullName, dedot newFullName ) of
210202 (oldName:[], newName:_) ->
@@ -217,7 +209,7 @@ isSameName oldFullName newFullName =
217209 oldFullName == newFullName
218210
219211
220−diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
212+diffFields :: [(N.Name, Type.Type)] -> [(N.Name, Type.Type)] -> Maybe [(N.Name,N.Name)]
221213diffFields oldRawFields newRawFields =
222214 let
223215 sort = List.sortBy (compare `on` fst)
@@ -238,7 +230,7 @@ diffFields oldRawFields newRawFields =
238230-- TYPE VARIABLES
239231
240232
241−isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
233+isEquivalentRenaming :: [(N.Name,N.Name)] -> Bool
242234isEquivalentRenaming varPairs =
243235 let
244236 renamings =
@@ -271,7 +263,7 @@ isEquivalentRenaming varPairs =
271263 allUnique (map snd verifiedRenamings)
272264
273265
274−compatibleVars :: (Name.Name, Name.Name) -> Bool
266+compatibleVars :: (N.Name, N.Name) -> Bool
275267compatibleVars (old, new) =
276268 case (categorizeVar old, categorizeVar new) of
277269 (CompAppend, CompAppend) -> True
@@ -293,43 +285,63 @@ data TypeVarCategory
293285 | Var
294286
295287
296−categorizeVar :: Name.Name -> TypeVarCategory
288+categorizeVar :: N.Name -> TypeVarCategory
297289categorizeVar name
298− | Name.isCompappendType name = CompAppend
299− | Name.isComparableType name = Comparable
300− | Name.isAppendableType name = Appendable
301− | Name.isNumberType name = Number
302− | otherwise = Var
290+ | N.startsWith "compappend" name = CompAppend
291+ | N.startsWith "comparable" name = Comparable
292+ | N.startsWith "appendable" name = Appendable
293+ | N.startsWith "number" name = Number
294+ | otherwise = Var
303295
304296
305297
306298-- MAGNITUDE
307299
308300
309−bump :: PackageChanges -> V.Version -> V.Version
301+data Magnitude
302+ = PATCH
303+ | MINOR
304+ | MAJOR
305+ deriving (Eq, Ord)
306+
307+
308+magnitudeToString :: Magnitude -> String
309+magnitudeToString magnitude =
310+ case magnitude of
311+ PATCH ->
312+ "PATCH"
313+
314+ MINOR ->
315+ "MINOR"
316+
317+ MAJOR ->
318+ "MAJOR"
319+
320+
321+bump :: PackageChanges -> Pkg.Version -> Pkg.Version
310322bump changes version =
311323 case toMagnitude changes of
312− M.PATCH ->
313− V.bumpPatch version
324+ PATCH ->
325+ Pkg.bumpPatch version
314326
315− M.MINOR ->
316− V.bumpMinor version
327+ MINOR ->
328+ Pkg.bumpMinor version
317329
318− M.MAJOR ->
319− V.bumpMajor version
330+ MAJOR ->
331+ Pkg.bumpMajor version
320332
321333
322−toMagnitude :: PackageChanges -> M.Magnitude
334+toMagnitude :: PackageChanges -> Magnitude
323335toMagnitude (PackageChanges added changed removed) =
324336 let
325− addMag = if null added then M.PATCH else M.MINOR
326− removeMag = if null removed then M.PATCH else M.MAJOR
337+ addMag = if null added then PATCH else MINOR
338+ removeMag = if null removed then PATCH else MAJOR
327339 changeMags = map moduleChangeMagnitude (Map.elems changed)
328340 in
329341 maximum (addMag : removeMag : changeMags)
330342
331343
332−moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
344+moduleChangeMagnitude :: ModuleChanges -> Magnitude
333345moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
334346 maximum
335347 [ changeMagnitude unions
@@ -339,45 +351,13 @@ moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
339351 ]
340352
341353
342−changeMagnitude :: Changes k v -> M.Magnitude
354+changeMagnitude :: Changes k v -> Magnitude
343355changeMagnitude (Changes added changed removed) =
344356 if Map.size removed > 0 || Map.size changed > 0 then
345− M.MAJOR
357+ MAJOR
346358
347359 else if Map.size added > 0 then
348− M.MINOR
360+ MINOR
349361
350362 else
351− M.PATCH
352−
353−
354−
355−-- GET DOCS
356−
357−
358−getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359−getDocs cache manager name version =
360− do let home = Stuff.package cache name version
361− let path = home </> "docs.json"
362− exists <- File.exists path
363− if exists
364− then
365− do bytes <- File.readUtf8 path
366− case D.fromByteString Docs.decoder bytes of
367− Right docs ->
368− return $ Right docs
369−
370− Left _ ->
371− do File.remove path
372− return $ Left Exit.DP_Cache
373− else
374− do let url = Website.metadata name version "docs.json"
375− Http.get manager url [] Exit.DP_Http $ \body ->
376− case D.fromByteString Docs.decoder body of
377− Right docs ->
378− do Dir.createDirectoryIfMissing True home
379− File.writeUtf8 path body
380− return $ Right docs
381−
382− Left _ ->
383− return $ Left $ Exit.DP_Data url body
363+ PATCH
builder/src/Deps/Explorer.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Deps.Explorer
3+ ( Explorer
4+ , Metadata
5+ , Info(..)
6+ , run
7+ , exists
8+ , getVersions
9+ , getConstraints
10+ )
11+ where
12+
13+{-| It is expensive to load ALL package metadata. You would need to:
14+
15+ 1. Know all the packages and all their versions.
16+ 2. Download or read the elm.json file for each version.
17+
18+The goal of this module is to only pay for (1) and pay for (2) as needed.
19+-}
20+
21+
22+import Control.Monad.Except (liftIO, lift, throwError)
23+import Control.Monad.State (StateT, evalStateT, gets, modify)
24+import Data.Map (Map)
25+import qualified Data.Map as Map
26+
27+import Elm.Package (Name, Version)
28+
29+import qualified Deps.Get as Get
30+import qualified Elm.PerUserCache as PerUserCache
31+import qualified Elm.Project.Json as Project
32+import Elm.Project.Constraint (Constraint)
33+import qualified Reporting.Exit as Exit
34+import qualified Reporting.Exit.Deps as E
35+import qualified Reporting.Task as Task
36+
37+
38+
39+-- EXPLORER
40+
41+
42+type Explorer =
43+ StateT Metadata Task.Task
44+
45+
46+data Metadata =
47+ Metadata
48+ { _vsns :: Get.AllPackages
49+ , _info :: Map (Name, Version) Info
50+ }
51+
52+
53+data Info =
54+ Info
55+ { _elm :: Constraint
56+ , _pkgs :: Map Name Constraint
57+ }
58+
59+
60+run :: Explorer a -> Task.Task a
61+run explorer =
62+ do versions <- Get.all Get.AllowOffline
63+ evalStateT explorer (Metadata versions Map.empty)
64+
65+
66+
67+-- EXISTS
68+
69+
70+exists :: Name -> Explorer ()
71+exists name =
72+ do pkgs <- gets _vsns
73+ case Get.versions name pkgs of
74+ Right _ ->
75+ return ()
76+
77+ Left suggestions ->
78+ throwError (Exit.Deps (E.PackageNotFound name suggestions))
79+
80+
81+
82+-- VERSIONS
83+
84+
85+getVersions :: Name -> Explorer [Version]
86+getVersions name =
87+ do pkgs <- gets _vsns
88+ case Get.versions name pkgs of
89+ Right versions ->
90+ return versions
91+
92+ Left _suggestions ->
93+ do elmHome <- liftIO PerUserCache.getElmHome
94+ throwError (Exit.Deps (E.CorruptVersionCache elmHome name))
95+
96+
97+
98+-- CONSTRAINTS
99+
100+
101+getConstraints :: Name -> Version -> Explorer Info
102+getConstraints name version =
103+ do allInfo <- gets _info
104+ case Map.lookup (name, version) allInfo of
105+ Just info ->
106+ return info
107+
108+ Nothing ->
109+ do pkgInfo <- lift $ Get.info name version
110+
111+ let elm = Project._pkg_elm_version pkgInfo
112+ let pkgs = Project._pkg_deps pkgInfo
113+ let info = Info elm pkgs
114+
115+ modify $ \(Metadata vsns infos) ->
116+ Metadata vsns $ Map.insert (name, version) info infos
117+
118+ return info
builder/src/Deps/Get.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Deps.Get
4+ ( all
5+ , AllPackages
6+ , Mode(..)
7+ , versions
8+ , info
9+ , docs
10+ )
11+ where
12+
13+
14+import Prelude hiding (all)
15+import Control.Monad.Except (catchError, liftIO)
16+import qualified Data.ByteString as BS
17+import Data.Function (on)
18+import qualified Data.List as List
19+import qualified Data.Map as Map
20+import Data.Map (Map)
21+import qualified Data.Text as Text
22+import qualified System.Directory as Dir
23+import System.FilePath ((</>))
24+
25+import qualified Elm.Docs as Docs
26+import qualified Elm.Package as Pkg
27+
28+import qualified Deps.Website as Website
29+import qualified Elm.Project.Json as Project
30+import qualified File.IO as IO
31+import qualified Json.Decode as Decode
32+import qualified Reporting.Doc as D
33+import qualified Reporting.Exit as Exit
34+import qualified Reporting.Exit.Assets as E
35+import qualified Reporting.Progress as Progress
36+import qualified Reporting.Suggest as Suggest
37+import qualified Reporting.Task as Task
38+
39+
40+
41+-- ALL VERSIONS
42+
43+
44+data Mode = RequireLatest | AllowOffline
45+
46+
47+newtype AllPackages = AllPackages (Map Pkg.Name [Pkg.Version])
48+
49+
50+all :: Mode -> Task.Task AllPackages
51+all mode =
52+ do dir <- Task.getPackageCacheDir
53+ let versionsFile = dir </> "versions.dat"
54+ exists <- liftIO $ Dir.doesFileExist versionsFile
55+ if exists
56+ then fetchNew versionsFile mode
57+ else fetchAll versionsFile
58+
59+
60+fetchAll :: FilePath -> Task.Task AllPackages
61+fetchAll versionsFile =
62+ do packages <- Website.getAllPackages
63+ let size = Map.foldr ((+) . length) 0 packages
64+ IO.writeBinary versionsFile (size, packages)
65+ return (AllPackages packages)
66+
67+
68+fetchNew :: FilePath -> Mode -> Task.Task AllPackages
69+fetchNew versionsFile mode =
70+ do (size, packages) <- IO.readBinary versionsFile
71+
72+ news <-
73+ case mode of
74+ RequireLatest ->
75+ Website.getNewPackages size
76+
77+ AllowOffline ->
78+ Website.getNewPackages size `catchError` \_ ->
79+ do Task.report Progress.UnableToLoadLatestPackages
80+ return []
81+
82+ if null news
83+ then return (AllPackages packages)
84+ else
85+ do let newAllPkgs = List.foldl' addNew packages news
86+ IO.writeBinary versionsFile (size + length news, newAllPkgs)
87+ return (AllPackages newAllPkgs)
88+
89+
90+addNew :: Map Pkg.Name [Pkg.Version] -> (Pkg.Name, Pkg.Version) -> Map Pkg.Name [Pkg.Version]
91+addNew packages (name, version) =
92+ Map.insertWith (++) name [version] packages
93+
94+
95+
96+-- VERSIONS
97+
98+
99+versions :: Pkg.Name -> AllPackages -> Either [Pkg.Name] [Pkg.Version]
100+versions name (AllPackages pkgs) =
101+ case Map.lookup name pkgs of
102+ Just vsns ->
103+ Right vsns
104+
105+ Nothing ->
106+ Left (nearbyNames name (Map.keys pkgs))
107+
108+
109+nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
110+nearbyNames (Pkg.Name author1 project1) possibleNames =
111+ let
112+ authorDist = authorDistance (Text.unpack author1)
113+ projectDist = projectDistance (Text.unpack project1)
114+
115+ addDistance name@(Pkg.Name author2 project2) =
116+ ( authorDist author2 + projectDist project2, name )
117+ in
118+ map snd $ take 4 $
119+ List.sortBy (compare `on` fst) $
120+ map addDistance possibleNames
121+
122+
123+authorDistance :: String -> Text.Text -> Int
124+authorDistance bad possibility =
125+ abs (Suggest.distance bad (Text.unpack possibility))
126+
127+
128+projectDistance :: String -> Text.Text -> Int
129+projectDistance bad possibility =
130+ if possibility == "elm-lang" || possibility == "elm-explorations" then
131+ 0
132+ else
133+ abs (Suggest.distance bad (Text.unpack possibility))
134+
135+
136+
137+-- PACKAGE INFO
138+
139+
140+info :: Pkg.Name -> Pkg.Version -> Task.Task Project.PkgInfo
141+info name version =
142+ do dir <- Task.getPackageCacheDirFor name version
143+ let elmJson = dir </> "elm.json"
144+
145+ exists <- liftIO $ Dir.doesFileExist elmJson
146+
147+ json <-
148+ if exists
149+ then liftIO (BS.readFile elmJson)
150+ else
151+ do bits <- Website.getElmJson name version
152+ liftIO (BS.writeFile elmJson bits)
153+ return bits
154+
155+ case Decode.parse "project" E.badContentToDocs Project.pkgDecoder json of
156+ Right pkgInfo ->
157+ return pkgInfo
158+
159+ Left _ ->
160+ do IO.remove elmJson
161+ Task.throw $ Exit.Assets $ E.CorruptElmJson name version
162+
163+
164+
165+-- DOCS
166+
167+
168+docs :: Pkg.Name -> Pkg.Version -> Task.Task Docs.Documentation
169+docs name version =
170+ do dir <- Task.getPackageCacheDirFor name version
171+ let docsJson = dir </> "docs.json"
172+
173+ exists <- liftIO $ Dir.doesFileExist docsJson
174+
175+ json <-
176+ if exists
177+ then liftIO (BS.readFile docsJson)
178+ else
179+ do bits <- Website.getDocs name version
180+ liftIO (BS.writeFile docsJson bits)
181+ return bits
182+
183+ case Decode.parse "docs" errorToDocs (Docs.toDict <$> Decode.list Docs.decoder) json of
184+ Right pkgInfo ->
185+ return pkgInfo
186+
187+ Left _ ->
188+ do IO.remove docsJson
189+ Task.throw $ Exit.Assets $ E.CorruptDocumentation name version
190+
191+
192+errorToDocs :: Docs.Error -> [D.Doc]
193+errorToDocs err =
194+ let
195+ details =
196+ case err of
197+ Docs.BadAssociativity txt ->
198+ ["Binary","operators","cannot","have",D.red (D.fromString (show txt)),"as","their","associativity."]
199+
200+ Docs.BadName ->
201+ ["It","is","not","a","valid","module","name."]
202+
203+ Docs.BadType ->
204+ ["It","is","not","a","valid","Elm","type."]
205+ in
206+ details
207+ ++
208+ ["This","should","not","happen","in","general,","so","please","report","this","at"
209+ ,"<https://github.com/elm-lang/package.elm-lang.org/issues>"
210+ ,"if","you","think","it","is","on","the","Elm","side!"
211+ ]
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.hsdeleted−213
@@ -1,213 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3−module Deps.Registry
4− ( Registry(..)
5− , KnownVersions(..)
6− , read
7− , fetch
8− , update
9− , latest
10− , getVersions
11− , getVersions'
12− )
13− where
14−
15−
16−import Prelude hiding (read)
17−import Control.Monad (liftM2)
18−import Data.Binary (Binary, get, put)
19−import qualified Data.List as List
20−import qualified Data.Map.Strict as Map
21−
22−import qualified Deps.Website as Website
23−import qualified Elm.Package as Pkg
24−import qualified Elm.Version as V
25−import qualified File
26−import qualified Http
27−import qualified Json.Decode as D
28−import qualified Parse.Primitives as P
29−import qualified Reporting.Exit as Exit
30−import qualified Stuff
31−
32−
33−
34−-- REGISTRY
35−
36−
37−data Registry =
38− Registry
39− { _count :: !Int
40− , _versions :: !(Map.Map Pkg.Name KnownVersions)
41− }
42−
43−
44−data KnownVersions =
45− KnownVersions
46− { _newest :: V.Version
47− , _previous :: ![V.Version]
48− }
49−
50−
51−
52−-- READ
53−
54−
55−read :: Stuff.PackageCache -> IO (Maybe Registry)
56−read cache =
57− File.readBinary (Stuff.registry cache)
58−
59−
60−
61−-- FETCH
62−
63−
64−fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
65−fetch manager cache =
66− post manager "/all-packages" allPkgsDecoder $
67− \versions ->
68− do let size = Map.foldr' addEntry 0 versions
69− let registry = Registry size versions
70− let path = Stuff.registry cache
71− File.writeBinary path registry
72− return registry
73−
74−
75−addEntry :: KnownVersions -> Int -> Int
76−addEntry (KnownVersions _ vs) count =
77− count + 1 + length vs
78−
79−
80−allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
81−allPkgsDecoder =
82− let
83− keyDecoder =
84− Pkg.keyDecoder bail
85−
86− versionsDecoder =
87− D.list (D.mapError (\_ -> ()) V.decoder)
88−
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)
95−
96−
97−
98−-- UPDATE
99−
100−
101−update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)
102−update manager cache oldRegistry@(Registry size packages) =
103− post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
104− \news ->
105− case news of
106− [] ->
107− return oldRegistry
108−
109− _:_ ->
110− let
111− newSize = size + length news
112− newPkgs = foldr addNew packages news
113− newRegistry = Registry newSize newPkgs
114− in
115− do File.writeBinary (Stuff.registry cache) newRegistry
116− return newRegistry
117−
118−
119−addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions
120−addNew (name, version) versions =
121− let
122− add maybeKnowns =
123− case maybeKnowns of
124− Just (KnownVersions v vs) ->
125− KnownVersions version (v:vs)
126−
127− Nothing ->
128− KnownVersions version []
129− in
130− Map.alter (Just . add) name versions
131−
132−
133−
134−-- NEW PACKAGE DECODER
135−
136−
137−newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
138−newPkgDecoder =
139− D.customString newPkgParser bail
140−
141−
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)
148−
149−
150−bail :: row -> col -> ()
151−bail _ _ =
152− ()
153−
154−
155−
156−-- LATEST
157−
158−
159−latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
160−latest manager cache =
161− do maybeOldRegistry <- read cache
162− case maybeOldRegistry of
163− Just oldRegistry ->
164− update manager cache oldRegistry
165−
166− Nothing ->
167− fetch manager cache
168−
169−
170−
171−-- GET VERSIONS
172−
173−
174−getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions
175−getVersions name (Registry _ versions) =
176− Map.lookup name versions
177−
178−
179−getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
180−getVersions' name (Registry _ versions) =
181− case Map.lookup name versions of
182− Just kvs -> Right kvs
183− Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
184−
185−
186−
187−-- POST
188−
189−
190−post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
191−post manager path decoder callback =
192− let
193− url = Website.route path []
194− in
195− Http.post manager url [] Exit.RP_Http $
196− \body ->
197− case D.fromByteString decoder body of
198− Right a -> Right <$> callback a
199− Left _ -> return $ Left $ Exit.RP_Data url body
200−
201−
202−
203−-- BINARY
204−
205−
206−instance Binary Registry where
207− get = liftM2 Registry get get
208− put (Registry a b) = put a >> put b
209−
210−
211−instance Binary KnownVersions where
212− get = liftM2 KnownVersions get get
213− put (KnownVersions a b) = put a >> put b
builder/src/Deps/Solver.hs+58−399
@@ -1,243 +1,89 @@
1−{-# LANGUAGE OverloadedStrings, Rank2Types #-}
21module Deps.Solver
32 ( Solver
4− , Result(..)
5− , Connection(..)
6− --
7− , Details(..)
8− , verify
9− --
10− , AppSolution(..)
11− , addToApp
12− --
13− , Env(..)
14− , initEnv
3+ , run
4+ , solve
155 )
166 where
177
188
19−import Control.Monad (foldM)
20−import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
9+import Control.Monad (foldM, guard, mzero, msum)
10+import Control.Monad.Logic (LogicT, runLogicT, lift)
11+import qualified Data.List as List
2112import qualified Data.Map as Map
22−import Data.Map ((!))
23−import qualified System.Directory as Dir
24−import System.FilePath ((</>))
13+import Data.Map (Map)
2514
26−import qualified Deps.Registry as Registry
27−import qualified Deps.Website as Website
28−import qualified Elm.Constraint as C
29−import qualified Elm.Package as Pkg
30−import qualified Elm.Outline as Outline
31−import qualified Elm.Version as V
32−import qualified File
33−import qualified Http
34−import qualified Json.Decode as D
35−import qualified Reporting.Exit as Exit
36−import qualified Stuff
15+import Elm.Package (Name, Version)
3716
17+import Deps.Explorer (Explorer)
18+import qualified Deps.Explorer as Explorer
19+import Elm.Project.Constraint (Constraint)
20+import qualified Elm.Project.Constraint as Con
3821
3922
40−-- SOLVER
41−
42−
43−newtype Solver a =
44− Solver
45− (
46− forall b.
47− State
48− -> (State -> a -> (State -> IO b) -> IO b)
49− -> (State -> IO b)
50− -> (Exit.Solver -> IO b)
51− -> IO b
52− )
53−
54−
55−data State =
56− State
57− { _cache :: Stuff.PackageCache
58− , _connection :: Connection
59− , _registry :: Registry.Registry
60− , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
61− }
62−
63−
64−data Constraints =
65− Constraints
66− { _elm :: C.Constraint
67− , _deps :: Map.Map Pkg.Name C.Constraint
68− }
6923
24+-- SOLVE
7025
71−data Connection
72− = Online Http.Manager
73− | Offline
7426
27+solve :: Map Name Constraint -> Solver (Map Name Version)
28+solve cons =
29+ mkSolver (State Map.empty cons)
7530
7631
77−-- RESULT
32+type Solver a =
33+ LogicT Explorer a
7834
7935
80−data Result a
81− = Ok a
82− | NoSolution
83− | NoOfflineSolution
84− | Err Exit.Solver
36+run :: Solver a -> Explorer (Maybe a)
37+run solver =
38+ runLogicT solver (const . return . Just) (return Nothing)
8539
8640
8741
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
42+-- SOLVER
12243
12344
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
45+data State =
46+ State
47+ { _solution :: Map Name Version
48+ , _unsolved :: Map Name Constraint
12949 }
13050
13151
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)
196−
197−
198−
199−-- EXPLORE GOALS
200−
52+mkSolver :: State -> Solver (Map Name Version)
53+mkSolver (State solution unsolved) =
54+ case Map.minViewWithKey unsolved of
55+ Nothing ->
56+ return solution
20157
202−data Goals =
203− Goals
204− { _pending :: Map.Map Pkg.Name C.Constraint
205− , _solved :: Map.Map Pkg.Name V.Version
206− }
58+ Just ((name, constraint), otherUnsolved) ->
59+ do allVersions <- lift $ Explorer.getVersions name
60+ let versions =
61+ reverse $ List.sort $
62+ filter (Con.satisfies constraint) allVersions
20763
64+ let state1 = State solution otherUnsolved
65+ state2 <- msum (map (addVersion state1 name) versions)
66+ mkSolver state2
20867
209−exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)
210−exploreGoals (Goals pending solved) =
211− case Map.minViewWithKey pending of
212− Nothing ->
213− return solved
21468
215− Just ((name, constraint), otherPending) ->
216− do let goals1 = Goals otherPending solved
217− let addVsn = addVersion goals1 name
218− (v,vs) <- getRelevantVersions name constraint
219− goals2 <- oneOf (addVsn v) (map addVsn vs)
220− exploreGoals goals2
69+addVersion :: State -> Name -> Version -> Solver State
70+addVersion (State solution unsolved) name version =
71+ do (Explorer.Info elm cons) <-
72+ lift $ Explorer.getConstraints name version
22173
74+ guard (Con.goodElm elm)
75+ newUnsolved <- foldM (addConstraint solution) unsolved (Map.toList cons)
76+ return (State (Map.insert name version solution) newUnsolved)
22277
223−addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals
224−addVersion (Goals pending solved) name version =
225− do (Constraints elm deps) <- getConstraints name version
226− if C.goodElm elm
227− then
228− do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
229− return (Goals newPending (Map.insert name version solved))
230− else
231− backtrack
23278
233−
234−addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
235−addConstraint solved unsolved (name, newConstraint) =
236− case Map.lookup name solved of
79+addConstraint :: Map Name Version -> Map Name Constraint -> (Name, Constraint) -> Solver (Map Name Constraint)
80+addConstraint solution unsolved (name, newConstraint) =
81+ case Map.lookup name solution of
23782 Just version ->
238− if C.satisfies newConstraint version
239− then return unsolved
240− else backtrack
83+ if Con.satisfies newConstraint version then
84+ return unsolved
85+ else
86+ mzero
24187
24288 Nothing ->
24389 case Map.lookup name unsolved of
@@ -245,200 +91,13 @@ addConstraint solved unsolved (name, newConstraint) =
24591 return $ Map.insert name newConstraint unsolved
24692
24793 Just oldConstraint ->
248− case C.intersect oldConstraint newConstraint of
94+ case Con.intersect oldConstraint newConstraint of
24995 Nothing ->
250− backtrack
96+ mzero
25197
25298 Just mergedConstraint ->
253− if oldConstraint == mergedConstraint
254− then return unsolved
255− else return (Map.insert name mergedConstraint unsolved)
256−
257−
258−
259−-- GET RELEVANT VERSIONS
260−
261−
262−getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
263−getRelevantVersions name constraint =
264− Solver $ \state@(State _ _ registry _) ok back _ ->
265− case Registry.getVersions name registry of
266− Just (Registry.KnownVersions newest previous) ->
267− case filter (C.satisfies constraint) (newest:previous) of
268− [] -> back state
269− v:vs -> ok state (v,vs) back
270−
271− Nothing ->
272− back state
273−
274−
275−
276−-- GET CONSTRAINTS
277−
278−
279−getConstraints :: 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)
283− case Map.lookup key cDict of
284− Just cs ->
285− ok state cs back
286−
287− 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)
331−
332−
333−constraintsDecoder :: D.Decoder () Constraints
334−constraintsDecoder =
335− do outline <- D.mapError (const ()) Outline.decoder
336− case outline of
337− Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) ->
338− return (Constraints elmConstraint deps)
339−
340− Outline.App _ ->
341− D.failure ()
342−
343−
344−
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−
382−-- INSTANCES
383−
384−
385−instance Functor Solver where
386− fmap func (Solver solver) =
387− Solver $ \state ok back err ->
388− let
389− okA stateA arg backA = ok stateA (func arg) backA
390− in
391− solver state okA back err
392−
393−
394−instance Applicative Solver where
395− pure a =
396− Solver $ \state ok back _ -> ok state a back
397−
398− (<*>) (Solver solverFunc) (Solver solverArg) =
399− Solver $ \state ok back err ->
400− let
401− okF stateF func backF =
402− let
403− okA stateA arg backA = ok stateA (func arg) backA
404− in
405− solverArg stateF okA backF err
406− in
407− solverFunc state okF back err
408−
409−
410−instance Monad Solver where
411− return a =
412− Solver $ \state ok back _ -> ok state a back
413−
414− (>>=) (Solver solverA) callback =
415− Solver $ \state ok back err ->
416− let
417− okA stateA a backA =
418− case callback a of
419− Solver solverB -> solverB stateA ok backA err
420− in
421− solverA state okA back err
422−
423−
424−oneOf :: Solver a -> [Solver a] -> Solver a
425−oneOf solver@(Solver solverHead) solvers =
426− case solvers of
427− [] ->
428− solver
429−
430− 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−
99+ if oldConstraint == mergedConstraint then
100+ return unsolved
101+ else
102+ return (Map.insert name mergedConstraint unsolved)
441103
442−backtrack :: Solver a
443−backtrack =
444− Solver $ \state _ back _ -> back state
builder/src/Deps/Verify.hsnew file+365
@@ -0,0 +1,365 @@
1+module Deps.Verify
2+ ( verify
3+ )
4+ where
5+
6+
7+import Control.Concurrent (forkIO)
8+import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, putMVar, readMVar, takeMVar)
9+import Control.Monad (filterM, void)
10+import Control.Monad.Trans (liftIO)
11+import qualified Data.Map as Map
12+import qualified Data.Set as Set
13+import Data.Map (Map)
14+import Data.Set (Set)
15+import System.Directory (doesDirectoryExist)
16+import System.FilePath ((</>))
17+
18+import qualified Elm.Compiler.Module as Module
19+import qualified Elm.Compiler.Objects as Obj
20+import qualified Elm.Docs as Docs
21+import Elm.Package (Name, Version)
22+import qualified Elm.PerUserCache as PerUserCache
23+import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..))
24+import qualified Json.Encode as Encode
25+
26+import qualified Deps.Explorer as Explorer
27+import qualified Deps.Get as Get
28+import qualified Deps.Solver as Solver
29+import qualified Deps.Website as Website
30+import qualified Elm.Compiler as Compiler
31+import qualified Elm.Project.Json as Project
32+import qualified Elm.Project.Constraint as Con
33+import qualified Elm.Project.Summary as Summary
34+import qualified File.Args as Args
35+import qualified File.Artifacts as Artifacts
36+import qualified File.Compile as Compile
37+import qualified File.Crawl as Crawl
38+import qualified File.IO as IO
39+import qualified File.Plan as Plan
40+import qualified Reporting.Exit as Exit
41+import qualified Reporting.Exit.Deps as E
42+import qualified Reporting.Progress as Progress
43+import qualified Reporting.Task as Task
44+import qualified Stuff.Paths as Paths
45+
46+
47+
48+-- VERIFY
49+
50+
51+verify :: FilePath -> Project -> Task.Task (Map Name Version, Summary.Summary)
52+verify root project =
53+ do solution <- Project.get verifyApp verifyPkg project
54+ (RawInfo infos ifaces) <- verifyArtifacts solution
55+ let summary = Summary.init root project infos ifaces
56+ return (solution, summary)
57+
58+
59+throw :: E.Exit -> Task.Task a
60+throw exit =
61+ Task.throw (Exit.Deps exit)
62+
63+
64+
65+-- VERIFY SOLUTION
66+
67+
68+verifyApp :: AppInfo -> Task.Task (Map Name Version)
69+verifyApp info =
70+ if _app_elm_version info /= Compiler.version then
71+ throw (E.AppBadElm (_app_elm_version info))
72+
73+ else
74+ do let oldSolution = Project.appSolution info
75+ let solver = Solver.solve (Map.map Con.exactly oldSolution)
76+ maybeSolution <- Explorer.run (Solver.run solver)
77+ case maybeSolution of
78+ Nothing ->
79+ throw E.BadDeps
80+
81+ Just solution ->
82+ return solution
83+
84+
85+verifyPkg :: PkgInfo -> Task.Task (Map Name Version)
86+verifyPkg info =
87+ if not (Con.goodElm (_pkg_elm_version info)) then
88+ throw (E.PkgBadElm (_pkg_elm_version info))
89+
90+ else
91+ do let deps = Map.union (_pkg_deps info) (_pkg_test_deps info)
92+ let solver = Solver.solve deps
93+ maybeSolution <- Explorer.run (Solver.run solver)
94+ case maybeSolution of
95+ Nothing ->
96+ throw E.BadDeps
97+
98+ Just solution ->
99+ return solution
100+
101+
102+
103+-- VERIFY ARTIFACTS
104+
105+
106+verifyArtifacts :: Map Name Version -> Task.Task RawInfo
107+verifyArtifacts solution =
108+ do Website.download =<< filterM noSrc (Map.toList solution)
109+ verifyBuildArtifacts solution
110+
111+
112+noSrc :: (Name, Version) -> Task.Task Bool
113+noSrc (name, version) =
114+ do root <- Task.getPackageCacheDirFor name version
115+ liftIO $ not <$> doesDirectoryExist (root </> "src")
116+
117+
118+
119+-- VERIFY BUILD ARTIFACTS
120+
121+
122+verifyBuildArtifacts :: Map Name Version -> Task.Task RawInfo
123+verifyBuildArtifacts solution =
124+ do Task.report (Progress.BuildDepsStart (Map.size solution))
125+ startMVar <- liftIO newEmptyMVar
126+ ifacesMVar <- liftIO $ newMVar Map.empty
127+ pkgInfoMVars <- Map.traverseWithKey (verifyBuild startMVar ifacesMVar) solution
128+ liftIO $ putMVar startMVar pkgInfoMVars
129+ answers <- liftIO $ traverse readMVar pkgInfoMVars
130+ Task.report Progress.BuildDepsEnd
131+ RawInfo
132+ <$> Map.traverseMaybeWithKey toInfo answers
133+ <*> liftIO (readMVar ifacesMVar)
134+
135+
136+data RawInfo =
137+ RawInfo (Map Name PkgInfo) Module.Interfaces
138+
139+
140+verifyBuild
141+ :: MVar (Map Name (MVar Answer))
142+ -> MVar Module.Interfaces
143+ -> Name
144+ -> Version
145+ -> Task.Task (MVar Answer)
146+verifyBuild pkgInfoMVar ifacesMVar name version =
147+ do mvar <- liftIO newEmptyMVar
148+ info <- Get.info name version
149+ report <- Task.getReporter
150+ runner <- Task.getSilentRunner
151+
152+ liftIO $ void $ forkIO $
153+ do allMVars <- readMVar pkgInfoMVar
154+ let deps = Project._pkg_deps info
155+ let depsMVars = Map.intersection allMVars deps
156+ depAnswers <- traverse readMVar depsMVars
157+
158+ answer <- ifNotBlocked depAnswers $ \infos ->
159+ do ifacesBefore <- readMVar ifacesMVar
160+ result <- runner (getIface name version info infos ifacesBefore)
161+ case result of
162+ Right ifaces ->
163+ do ifacesNow <- takeMVar ifacesMVar
164+ putMVar ifacesMVar (Map.union ifacesNow ifaces)
165+ return (Ok info)
166+
167+ Left _ ->
168+ return (Err name version)
169+
170+ report Progress.BuildDepsProgress
171+ putMVar mvar answer
172+
173+ return mvar
174+
175+
176+
177+-- ANSWERS
178+
179+
180+data Answer
181+ = Ok PkgInfo
182+ | Blocked
183+ | Err Name Version
184+
185+
186+toInfo :: Name -> Answer -> Task.Task (Maybe PkgInfo)
187+toInfo _ answer =
188+ case answer of
189+ Ok info ->
190+ return (Just info)
191+
192+ Blocked ->
193+ return Nothing
194+
195+ Err name version ->
196+ do elmHome <- liftIO PerUserCache.getElmHome
197+ throw (E.BuildFailure elmHome name version)
198+
199+
200+ifNotBlocked :: Map Name Answer -> (Map Name PkgInfo -> IO Answer) -> IO Answer
201+ifNotBlocked answers callback =
202+ case traverse isOk answers of
203+ Nothing ->
204+ return Blocked
205+
206+ Just infos ->
207+ callback infos
208+
209+
210+isOk :: Answer -> Maybe PkgInfo
211+isOk answer =
212+ case answer of
213+ Ok info -> Just info
214+ Blocked -> Nothing
215+ Err _ _ -> Nothing
216+
217+
218+
219+-- GET INTERFACE
220+
221+
222+getIface
223+ :: Name
224+ -> Version
225+ -> PkgInfo
226+ -> Map Name PkgInfo
227+ -> Module.Interfaces
228+ -> Task.Task Module.Interfaces
229+getIface name version info infos depIfaces =
230+ do root <- Task.getPackageCacheDirFor name version
231+ let solution = Map.map _pkg_version infos
232+
233+ cached <- isCached root solution
234+
235+ if cached
236+ then IO.readBinary (root </> "ifaces.dat")
237+ else
238+ do Paths.removeStuff root
239+ let docsPath = root </> "docs.json"
240+
241+ let summary = Summary.cheapInit root info infos depIfaces
242+ args <- Args.fromSummary summary
243+ graph <- Crawl.crawl summary args
244+ (dirty, cachedIfaces) <- Plan.plan (Just docsPath) summary graph
245+ answers <- Compile.compile (Pkg info) (Just docsPath) cachedIfaces dirty
246+ results <- Artifacts.ignore answers
247+ _ <- Artifacts.writeDocs results docsPath
248+
249+ Paths.removeStuff root
250+
251+ updateCache root name info solution graph results
252+
253+
254+
255+-- IS CACHED?
256+
257+
258+isCached :: FilePath -> Map Name Version -> Task.Task Bool
259+isCached root solution =
260+ IO.andM
261+ [ IO.exists (root </> "cached.dat")
262+ , IO.exists (root </> "ifaces.dat")
263+ , IO.exists (root </> "objs.dat")
264+ , IO.exists (root </> "documentation.json")
265+ , isCachedHelp solution <$> IO.readBinary (root </> "cached.dat")
266+ ]
267+
268+
269+isCachedHelp :: Map Name Version -> Map Name (Set Version) -> Bool
270+isCachedHelp solution cachedDeps =
271+ let
272+ matches =
273+ Map.intersectionWith Set.member solution cachedDeps
274+ in
275+ Map.size solution == Map.size matches
276+ && Map.foldr (&&) True matches
277+
278+
279+
280+-- UPDATE CACHE
281+
282+
283+updateCache
284+ :: FilePath
285+ -> Name
286+ -> PkgInfo
287+ -> Map Name Version
288+ -> Crawl.Result
289+ -> Map Module.Raw Compiler.Artifacts
290+ -> Task.Task Module.Interfaces
291+updateCache root name info solution graph results =
292+ do let path = root </> "cached.dat"
293+ let deps = Map.map Set.singleton solution
294+ let elmi = crush name info results
295+
296+ exists <- IO.exists path
297+
298+ if exists
299+ then
300+ do oldDeps <- IO.readBinary path
301+ IO.writeBinary path (Map.unionWith Set.union deps oldDeps)
302+ else
303+ do IO.writeBinary (root </> "ifaces.dat") elmi
304+
305+ IO.writeBinary path deps
306+
307+ IO.writeBinary (root </> "objs.dat") $
308+ Map.foldr addGraph (objGraphFromKernels graph) results
309+
310+ liftIO $ Encode.write (root </> "documentation.json") $
311+ Encode.list Docs.encode $
312+ Map.foldr addDocs [] results
313+
314+ return elmi
315+
316+
317+
318+-- CRUSH INTERFACES
319+
320+
321+crush :: Name -> PkgInfo -> Map Module.Raw Compiler.Artifacts -> Module.Interfaces
322+crush pkg info results =
323+ let
324+ exposed =
325+ Set.fromList (Project.getExposed info)
326+ in
327+ Map.mapKeys (Module.Canonical pkg) $
328+ Map.mapMaybeWithKey (crushHelp exposed) results
329+
330+
331+crushHelp :: Set Module.Raw -> Module.Raw -> Compiler.Artifacts -> Maybe Module.Interface
332+crushHelp exposed name (Compiler.Artifacts elmi _ _) =
333+ if Set.member name exposed then
334+ Just elmi
335+
336+ else
337+ Nothing
338+
339+
340+
341+-- DOCUMENTATION
342+
343+
344+addDocs :: Compiler.Artifacts -> [Docs.Module] -> [Docs.Module]
345+addDocs (Compiler.Artifacts _ _ maybeDocs) docsList =
346+ case maybeDocs of
347+ Nothing ->
348+ docsList
349+
350+ Just docs ->
351+ docs : docsList
352+
353+
354+
355+-- OBJECT GRAPH
356+
357+
358+addGraph :: Compiler.Artifacts -> Obj.Graph -> Obj.Graph
359+addGraph (Compiler.Artifacts _ elmo _) graph =
360+ Obj.union elmo graph
361+
362+
363+objGraphFromKernels :: Crawl.Result -> Obj.Graph
364+objGraphFromKernels (Crawl.Graph _ _ kernels _ _) =
365+ Obj.fromKernels kernels
builder/src/Deps/Website.hs+333−14
@@ -1,26 +1,345 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
13module Deps.Website
2− ( domain
3− , route
4− , metadata
4+ ( getElmJson
5+ , getDocs
6+ , getNewPackages
7+ , getAllPackages
8+ , download
9+ , githubCommit
10+ , githubDownload
11+ , Sha
12+ , register
513 )
614 where
715
816
17+import Prelude hiding (zip)
18+import qualified Codec.Archive.Zip as Zip
19+import Control.Monad (void)
20+import qualified Data.Binary as Binary
21+import qualified Data.Binary.Get as Binary
22+import qualified Data.ByteString.Char8 as BS
23+import qualified Data.ByteString.Lazy as LBS
24+import qualified Data.Digest.Pure.SHA as SHA
25+import qualified Data.HashMap.Lazy as HashMap
26+import qualified Data.Map as Map
27+import qualified Data.Text as Text
28+import qualified Network.HTTP.Client as Client
29+import qualified Network.HTTP.Client.MultipartFormData as Multi
30+import qualified Network.HTTP.Types as Http
31+import qualified System.Directory as Dir
32+import System.FilePath ((</>), splitFileName)
33+
34+import Elm.Package (Name, Version)
935import qualified Elm.Package as Pkg
10−import qualified Elm.Version as V
11−import qualified Http
36+import qualified Json.Decode as D
37+
38+import qualified Reporting.Doc as D
39+import qualified Reporting.Exit.Http as E
40+import qualified Reporting.Progress as Progress
41+import qualified Reporting.Task as Task
42+import qualified Reporting.Task.Http as Http
43+import qualified Stuff.Paths as Path
44+
45+
46+
47+-- GET PACKAGE INFO
48+
49+
50+getElmJson :: Name -> Version -> Task.Task BS.ByteString
51+getElmJson name version =
52+ Http.run $ fetchByteString $
53+ "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/elm.json"
54+
55+
56+getDocs :: Name -> Version -> Task.Task BS.ByteString
57+getDocs name version =
58+ Http.run $ fetchByteString $
59+ "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/docs.json"
60+
61+
62+
63+-- NEW PACKAGES
64+
65+
66+getNewPackages :: Int -> Task.Task [(Name, Version)]
67+getNewPackages index =
68+ Http.run $ fetchJson "packages" E.badJsonToDocs (D.list newPkgDecoder) ("all-packages/since/" ++ show index)
69+
70+
71+newPkgDecoder :: D.Decoder E.BadJson ( Name, Version )
72+newPkgDecoder =
73+ do txt <- D.text
74+ case Text.splitOn "@" txt of
75+ [key, value] ->
76+ case Pkg.fromText key of
77+ Right pkg ->
78+ case Pkg.versionFromText value of
79+ Just vsn ->
80+ D.succeed (pkg, vsn)
81+
82+ Nothing ->
83+ D.fail (E.BadNewPkg txt)
84+
85+ Left _ ->
86+ D.fail (E.BadNewPkg txt)
87+
88+ _ ->
89+ D.fail (E.BadNewPkg txt)
90+
91+
92+
93+-- ALL PACKAGES
94+
95+
96+getAllPackages :: Task.Task (Map.Map Name [Version])
97+getAllPackages =
98+ Http.run $ fetchJson "packages" E.badJsonToDocs allPkgsDecoder "all-packages"
99+
100+
101+allPkgsDecoder :: D.Decoder E.BadJson (Map.Map Name [Version])
102+allPkgsDecoder =
103+ let
104+ checkKeys pairs pkgs =
105+ case pairs of
106+ [] ->
107+ D.succeed pkgs
108+
109+ (key, versions) : rest ->
110+ case Pkg.fromText key of
111+ Left (msg, _) ->
112+ D.fail (E.BadAllPkg key msg)
113+
114+ Right pkg ->
115+ checkKeys rest (Map.insert pkg versions pkgs)
116+ in
117+ do dict <- D.dict (D.list (D.mapError E.BadAllVsn Pkg.versionDecoder))
118+ checkKeys (HashMap.toList dict) Map.empty
119+
120+
121+
122+-- HELPERS
123+
124+
125+fetchByteString :: String -> Http.Fetch BS.ByteString
126+fetchByteString path =
127+ Http.package path [] $ \request manager ->
128+ do response <- Client.httpLbs request manager
129+ return $ Right $ LBS.toStrict $ Client.responseBody response
130+
131+
132+fetchJson :: String -> (e -> [D.Doc]) -> D.Decoder e a -> String -> Http.Fetch a
133+fetchJson rootName errorToDocs decoder path =
134+ Http.package path [] $ \request manager ->
135+ do response <- Client.httpLbs request manager
136+ let bytes = LBS.toStrict (Client.responseBody response)
137+ case D.parse rootName errorToDocs decoder bytes of
138+ Right value ->
139+ return $ Right value
140+
141+ Left jsonProblem ->
142+ return $ Left $ E.BadJson path jsonProblem
143+
144+
145+
146+-- DOWNLOAD
147+
148+
149+download :: [(Name, Version)] -> Task.Task ()
150+download packages =
151+ case packages of
152+ [] ->
153+ Task.report Progress.DownloadSkip
154+
155+ _ ->
156+ do cache <- Task.getPackageCacheDir
157+
158+ let start = Progress.DownloadStart packages
159+ let toEnd = Progress.DownloadEnd
160+
161+ void $ Http.run $ Http.report start toEnd $
162+ Http.parallel $ map (downloadHelp cache) packages
163+
164+
165+downloadHelp :: FilePath -> (Name, Version) -> Http.Fetch ()
166+downloadHelp cache (name, version) =
167+ let
168+ endpointUrl =
169+ "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/endpoint.json"
170+ in
171+ Http.andThen (fetchJson "version" id endpointDecoder endpointUrl) $ \(endpoint, hash) ->
172+ let
173+ start = Progress.DownloadPkgStart name version
174+ toEnd = Progress.DownloadPkgEnd name version
175+ in
176+ Http.report start toEnd $
177+ Http.anything endpoint $ \request manager ->
178+ Client.withResponse request manager (downloadArchive cache name version hash)
179+
180+
181+endpointDecoder :: D.Decoder e (String, String)
182+endpointDecoder =
183+ D.map2 (,)
184+ (D.field "url" D.string)
185+ (D.field "hash" D.string)
186+
187+
188+
189+-- DOWNLOAD ZIP ARCHIVE
190+
191+
192+downloadArchive :: FilePath -> Name -> Version -> String -> Client.Response Client.BodyReader -> IO (Either E.Exit ())
193+downloadArchive cache name version expectedHash response =
194+ do result <- readArchive (Client.responseBody response) initialArchiveState
195+ case result of
196+ Left msg ->
197+ return (Left msg)
198+
199+ Right (sha, archive) ->
200+ if expectedHash == SHA.showDigest sha then
201+ Right <$> writeArchive archive (cache </> Pkg.toFilePath name) (Pkg.versionToString version)
202+ else
203+ return $ Left $ E.BadZipSha expectedHash (SHA.showDigest sha)
204+
205+
206+
207+-- READ ARCHIVE
208+
209+
210+data ArchiveState =
211+ AS
212+ { _len :: !Int
213+ , _sha :: !(Binary.Decoder SHA.SHA1State)
214+ , _zip :: !(Binary.Decoder Zip.Archive)
215+ }
216+
217+
218+initialArchiveState :: ArchiveState
219+initialArchiveState =
220+ AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
221+
222+
223+type Sha = SHA.Digest SHA.SHA1State
224+
225+
226+readArchive :: Client.BodyReader -> ArchiveState -> IO (Either E.Exit (Sha, Zip.Archive))
227+readArchive body (AS len sha zip) =
228+ case zip of
229+ Binary.Fail _ _ _ ->
230+ return $ Left E.BadZipData
231+
232+ Binary.Partial k ->
233+ do chunk <- Client.brRead body
234+ readArchive body $ AS
235+ { _len = len + BS.length chunk
236+ , _sha = Binary.pushChunk sha chunk
237+ , _zip = k (if BS.null chunk then Nothing else Just chunk)
238+ }
239+
240+ Binary.Done _ _ archive ->
241+ return $ Right ( SHA.completeSha1Incremental sha len, archive )
242+
243+
244+
245+-- WRITE ARCHIVE
246+
247+
248+writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()
249+writeArchive archive destination newRoot =
250+ do Dir.createDirectoryIfMissing True destination
251+ let opts = [Zip.OptDestination destination]
252+ mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)
253+
254+
255+replaceRoot :: String -> Zip.Entry -> Zip.Entry
256+replaceRoot root entry =
257+ let
258+ rootless =
259+ dropWhile (/='/') (Zip.eRelativePath entry)
260+ in
261+ entry { Zip.eRelativePath = root ++ rootless }
262+
263+
264+
265+-- FIND TAGGED COMMIT ON GITHUB
266+
267+
268+githubCommit :: Name -> Version -> Task.Task String
269+githubCommit name version =
270+ let
271+ endpoint =
272+ "https://api.github.com/repos/" ++ Pkg.toUrl name ++ "/git/refs/tags/alpha-" ++ Pkg.versionToString version
273+
274+ headers =
275+ [ ( Http.hUserAgent, "elm-cli" )
276+ , ( Http.hAccept, "application/json" )
277+ ]
278+
279+ decoder =
280+ D.at ["object","sha"] D.string
281+ in
282+ Http.run $ Http.anything endpoint $ \request manager ->
283+ do response <- Client.httpLbs (request { Client.requestHeaders = headers }) manager
284+ let bytes = LBS.toStrict (Client.responseBody response)
285+ case D.parse "github" id decoder bytes of
286+ Right value ->
287+ return $ Right value
288+
289+ Left jsonProblem ->
290+ return $ Left $ E.BadJson "github.json" jsonProblem
291+
292+
293+
294+-- DOWNLOAD FROM GITHUB
295+
296+
297+githubDownload :: Name -> Version -> FilePath -> Task.Task Sha
298+githubDownload name version dir =
299+ let
300+ endpoint =
301+ "https://github.com/" ++ Pkg.toUrl name ++ "/zipball/alpha-" ++ Pkg.versionToString version ++ "/"
302+ in
303+ Http.run $ Http.anything endpoint $ \request manager ->
304+ Client.withResponse request manager (githubDownloadHelp dir)
305+
306+
307+githubDownloadHelp :: FilePath -> Client.Response Client.BodyReader -> IO (Either E.Exit Sha)
308+githubDownloadHelp targetDir response =
309+ do result <- readArchive (Client.responseBody response) initialArchiveState
310+ case result of
311+ Left msg ->
312+ return (Left msg)
313+
314+ Right (sha, archive) ->
315+ do let (dir, root) = splitFileName targetDir
316+ writeArchive archive dir root
317+ return $ Right sha
12318
13319
14−domain :: String
15−domain =
16− "https://package.elm-lang.org"
17320
321+-- REGISTER PACKAGES
18322
19−route :: String -> [(String,String)] -> String
20−route path params =
21− Http.toUrl (domain ++ path) params
22323
324+register :: Name -> Version -> String -> Sha -> Task.Task ()
325+register name version commitHash digest =
326+ let
327+ params =
328+ [ ("name", Pkg.toString name)
329+ , ("version", Pkg.versionToString version)
330+ , ("commit-hash", commitHash)
331+ ]
23332
24−metadata :: Pkg.Name -> V.Version -> String -> String
25−metadata name version file =
26− domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file
333+ files =
334+ [ Multi.partFileSource "elm.json" "elm.json"
335+ , Multi.partFileSource "docs.json" Path.docs
336+ , Multi.partFileSource "README.md" "README.md"
337+ , Multi.partFileRequestBody "github-hash" "github-hash" $
338+ Client.RequestBodyBS (BS.pack (SHA.showDigest digest))
339+ ]
340+ in
341+ Http.run $ Http.package "register" params $ \rawRequest manager ->
342+ do requestWithBody <- Multi.formDataBody files rawRequest
343+ let request = requestWithBody { Client.responseTimeout = Client.responseTimeoutNone }
344+ void $ Client.httpLbs request manager
345+ return $ Right ()
builder/src/Elm/Bump.hsnew file+139
@@ -0,0 +1,139 @@
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.Diff as Diff
13+import qualified Deps.Get as Get
14+import qualified Elm.Package as Pkg
15+import qualified Elm.Project as Project
16+import qualified Elm.Project.Json as Project
17+import qualified Elm.Project.Summary as Summary
18+import Reporting.Doc ((<>), (<+>))
19+import qualified Reporting.Doc as D
20+import qualified Reporting.Exit as Exit
21+import qualified Reporting.Exit.Bump as E
22+import qualified Reporting.Exit.Help as Help
23+import qualified Reporting.Progress.Terminal as Terminal
24+import qualified Reporting.Task as Task
25+
26+
27+
28+-- BUMP
29+
30+
31+bump :: Summary.Summary -> Task.Task ()
32+bump summary@(Summary.Summary root project _ _ _) =
33+ case project of
34+ Project.App _ ->
35+ Task.throw (Exit.Bump E.Application)
36+
37+ Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->
38+ do pkgs <- Get.all Get.RequireLatest
39+ case Get.versions name pkgs of
40+ Left _suggestions ->
41+ checkNewPackage root info
42+
43+ Right publishedVersions ->
44+ let
45+ bumpableVersions =
46+ map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)
47+ in
48+ if elem version bumpableVersions then
49+ suggestVersion summary info
50+ else
51+ Task.throw $ Exit.Bump $ E.Unbumpable version $
52+ map head (List.group (List.sort bumpableVersions))
53+
54+
55+
56+-- VALID BUMPS
57+
58+
59+toPossibleBumps :: [Pkg.Version] -> [(Pkg.Version, Pkg.Version, Diff.Magnitude)]
60+toPossibleBumps publishedVersions =
61+ case publishedVersions of
62+ [] ->
63+ []
64+
65+ _ ->
66+ let
67+ patchPoints =
68+ Pkg.filterLatest Pkg.majorAndMinor publishedVersions
69+
70+ minorPoints =
71+ Pkg.filterLatest Pkg._major publishedVersions
72+
73+ majorPoint =
74+ maximum publishedVersions
75+ in
76+ (majorPoint, Pkg.bumpMajor majorPoint, Diff.MAJOR)
77+ : map (\v -> (v, Pkg.bumpMinor v, Diff.MINOR)) minorPoints
78+ ++ map (\v -> (v, Pkg.bumpPatch v, Diff.PATCH)) patchPoints
79+
80+
81+
82+-- CHECK NEW PACKAGE
83+
84+
85+checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()
86+checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =
87+ do liftIO $ putStrLn Terminal.newPackageOverview
88+ if version == Pkg.initialVersion
89+ then
90+ liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"
91+ else
92+ changeVersion root info Pkg.initialVersion $
93+ "It looks like the version in elm.json has been changed though!\n\
94+ \Would you like me to change it back to "
95+ <> D.fromText (Pkg.versionToText Pkg.initialVersion) <> "? [Y/n] "
96+
97+
98+
99+-- SUGGEST VERSION
100+
101+
102+suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()
103+suggestVersion summary@(Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =
104+ do oldDocs <- Get.docs name version
105+ newDocs <- Task.silently (Project.generateDocs summary)
106+ let changes = Diff.diff oldDocs newDocs
107+ let newVersion = Diff.bump changes version
108+ changeVersion root info newVersion $
109+ let
110+ old = D.fromText $ Pkg.versionToText version
111+ new = D.fromText $ Pkg.versionToText newVersion
112+ mag = D.fromString $ Diff.magnitudeToString (Diff.toMagnitude changes)
113+ in
114+ "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
115+ <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
116+ <> "\n"
117+ <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
118+
119+
120+
121+-- CHANGE VERSION
122+
123+
124+changeVersion :: FilePath -> Project.PkgInfo -> Pkg.Version -> D.Doc -> Task.Task ()
125+changeVersion root info targetVersion explanation =
126+ do liftIO $ Help.toStdout explanation
127+ approved <- Task.getApproval
128+ if not approved
129+ then
130+ liftIO $ putStrLn "Okay, no changes were made."
131+
132+ else
133+ do liftIO $ Project.write root $ Project.Pkg $
134+ info { Project._pkg_version = targetVersion }
135+
136+ liftIO $ Help.toStdout $
137+ "Version changed to "
138+ <> D.green (D.fromText (Pkg.versionToText targetVersion))
139+ <> "!\n"
builder/src/Elm/Details.hsdeleted−833
@@ -1,833 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3−module Elm.Details
4− ( Details(..)
5− , BuildID
6− , ValidOutline(..)
7− , Local(..)
8− , Foreign(..)
9− , load
10− , loadObjects
11− , loadInterfaces
12− , verifyInstall
13− )
14− where
15−
16−
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
19−import Control.Monad (liftM, liftM2, liftM3)
20−import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Either as Either
22−import qualified Data.Map as Map
23−import qualified Data.Map.Utils as Map
24−import 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
28−import qualified Data.OneOrMore as OneOrMore
29−import qualified Data.Set as Set
30−import qualified Data.Utf8 as Utf8
31−import Data.Word (Word64)
32−import qualified System.Directory as Dir
33−import System.FilePath ((</>), (<.>))
34−
35−import qualified AST.Canonical as Can
36−import qualified AST.Source as Src
37−import qualified AST.Optimized as Opt
38−import qualified BackgroundWriter as BW
39−import qualified Compile
40−import qualified Deps.Registry as Registry
41−import qualified Deps.Solver as Solver
42−import qualified Deps.Website as Website
43−import qualified Elm.Constraint as Con
44−import qualified Elm.Docs as Docs
45−import qualified Elm.Interface as I
46−import qualified Elm.Kernel as Kernel
47−import qualified Elm.ModuleName as ModuleName
48−import qualified Elm.Outline as Outline
49−import qualified Elm.Package as Pkg
50−import qualified Elm.Version as V
51−import qualified File
52−import qualified Http
53−import qualified Json.Decode as D
54−import qualified Json.Encode as E
55−import qualified Parse.Module as Parse
56−import qualified Reporting
57−import qualified Reporting.Annotation as A
58−import qualified Reporting.Exit as Exit
59−import qualified Reporting.Task as Task
60−import qualified Stuff
61−
62−
63−
64−-- DETAILS
65−
66−
67−data Details =
68− Details
69− { _outlineTime :: File.Time
70− , _outline :: ValidOutline
71− , _buildID :: BuildID
72− , _locals :: Map.Map ModuleName.Raw Local
73− , _foreigns :: Map.Map ModuleName.Raw Foreign
74− , _extras :: Extras
75− }
76−
77−
78−type BuildID = Word64
79−
80−
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−--
99−data Local =
100− Local
101− { _path :: FilePath
102− , _time :: File.Time
103− , _deps :: [ModuleName.Raw]
104− , _main :: Bool
105− , _lastChange :: BuildID
106− , _lastCompile :: BuildID
107− }
108−
109−
110−data Foreign =
111− Foreign Pkg.Name [Pkg.Name]
112−
113−
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−
141−
142−-- VERIFY INSTALL -- used by Install
143−
144−
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)
163− case maybeDetails of
164− Nothing ->
165− generate style scope root newTime
166−
167− Just details@(Details oldTime _ buildID _ _ _) ->
168− if oldTime == newTime
169− then return (Right details { _buildID = buildID + 1 })
170− else generate style scope root newTime
171−
172−
173−
174−-- GENERATE
175−
176−
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)
189−
190−
191−
192−-- ENV
193−
194−
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− }
205−
206−
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
210− eitherOutline <- Outline.read root
211− case eitherOutline of
212− Left problem ->
213− return $ Left $ Exit.DetailsBadOutline problem
214−
215− Right outline ->
216− do maybeEnv <- readMVar mvar
217− case maybeEnv of
218− Left problem ->
219− return $ Left $ Exit.DetailsCannotGetRegistry problem
220−
221− Right (Solver.Env cache manager connection registry) ->
222− return $ Right (Env key scope root cache manager connection registry, outline)
223−
224−
225−
226−-- VERIFY PROJECT
227−
228−
229−type Task a = Task.Task Exit.Details a
230−
231−
232−verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
233−verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
234− if Con.goodElm elm
235− 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
240− else
241− Task.throw $ Exit.DetailsBadElmInPkg elm
242−
243−
244−verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
245−verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
246− if elmVersion == V.compiler
247− then
248− do stated <- checkAppDeps outline
249− actual <- verifyConstraints env (Map.map Con.exactly stated)
250− if Map.size stated == Map.size actual
251− then verifyDependencies env time (ValidApp srcDirs) actual direct
252− else Task.throw $ Exit.DetailsHandEditedDependencies
253− else
254− Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
255−
256−
257−checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
258−checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
259− do x <- union allowEqualDups indirect testDirect
260− y <- union noDups direct testIndirect
261− union noDups x y
262−
263−
264−
265−-- VERIFY CONSTRAINTS
266−
267−
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
276−
277−
278−
279−-- UNION
280−
281−
282−union :: (Ord k) => (k -> v -> v -> Task v) -> Map.Map k v -> Map.Map k v -> Task (Map.Map k v)
283−union tieBreaker deps1 deps2 =
284− Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
285−
286−
287−noDups :: k -> v -> v -> Task v
288−noDups _ _ _ =
289− Task.throw Exit.DetailsHandEditedDependencies
290−
291−
292−allowEqualDups :: (Eq v) => k -> v -> v -> Task v
293−allowEqualDups _ v1 v2 =
294− if v1 == v2
295− then return v1
296− else Task.throw Exit.DetailsHandEditedDependencies
297−
298−
299−
300−-- FORK
301−
302−
303−fork :: IO a -> IO (MVar a)
304−fork work =
305− do mvar <- newEmptyMVar
306− _ <- forkIO $ putMVar mvar =<< work
307− return mvar
308−
309−
310−
311−-- VERIFY DEPENDENCIES
312−
313−
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
321− putMVar mvar mvars
322− deps <- traverse readMVar mvars
323− case sequence deps of
324− Left _ ->
325− do home <- Stuff.getElmHome
326− return $ Left $ Exit.DetailsBadDeps home $
327− Maybe.catMaybes $ Either.lefts $ Map.elems deps
328−
329− Right artifacts ->
330− 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)
335− 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)
340−
341−
342−addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph
343−addObjects (Artifacts _ objs) graph =
344− Opt.addGlobalGraph objs graph
345−
346−
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) $
350− if Map.member pkg directDeps
351− then ifaces
352− else Map.map I.privatize ifaces
353−
354−
355−gatherForeigns :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name)
356−gatherForeigns pkg (Artifacts ifaces _) foreigns =
357− let
358− isPublic di =
359− case di of
360− I.Public _ -> Just (OneOrMore.one pkg)
361− I.Private _ _ _ -> Nothing
362− in
363− Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
364−
365−
366−
367−-- VERIFY DEPENDENCY
368−
369−
370−data Artifacts =
371− Artifacts
372− { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
373− , _objects :: Opt.GlobalGraph
374− }
375−
376−
377−type Dep =
378− Either (Maybe Exit.DetailsBadDep) Artifacts
379−
380−
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")
385− if exists
386− then
387− do Reporting.report key Reporting.DCached
388− maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
389− case maybeCache of
390− Nothing ->
391− build key cache depsMVar pkg details fingerprint Set.empty
392−
393− Just (ArtifactCache fingerprints artifacts) ->
394− 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
397− else
398− do Reporting.report key Reporting.DRequested
399− result <- downloadPackage cache manager pkg vsn
400− 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
408−
409−
410−
411−-- ARTIFACT CACHE
412−
413−
414−data ArtifactCache =
415− ArtifactCache
416− { _fingerprints :: Set.Set Fingerprint
417− , _artifacts :: Artifacts
418− }
419−
420−
421−type Fingerprint =
422− Map.Map Pkg.Name V.Version
423−
424−
425−
426−-- BUILD
427−
428−
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)
432− case eitherOutline of
433− Left _ ->
434− do Reporting.report key Reporting.DBroken
435− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
436−
437− Right (Outline.App _) ->
438− do Reporting.report key Reporting.DBroken
439− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
440−
441− 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
445− Left _ ->
446− do Reporting.report key Reporting.DBroken
447− return $ Left $ Nothing
448−
449− Right directArtifacts ->
450− do let src = Stuff.package cache pkg vsn </> "src"
451− 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
460− 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−
487−
488−
489−-- GATHER
490−
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 =
499− 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
514−
515−
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
523−
524−
525−
526−-- GATHER FOREIGN INTERFACES
527−
528−
529−data ForeignInterface
530− = ForeignAmbiguous
531− | ForeignSpecific I.Interface
532−
533−
534−gatherForeignInterfaces :: Map.Map Pkg.Name Artifacts -> Map.Map ModuleName.Raw ForeignInterface
535−gatherForeignInterfaces directArtifacts =
536− Map.map (OneOrMore.destruct finalize) $
537− Map.foldrWithKey gather Map.empty directArtifacts
538− where
539− finalize :: I.Interface -> [I.Interface] -> ForeignInterface
540− finalize i is =
541− case is of
542− [] -> ForeignSpecific i
543− _:_ -> ForeignAmbiguous
544−
545− gather :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface)
546− gather _ (Artifacts ifaces _) buckets =
547− Map.unionWith OneOrMore.more buckets (Map.mapMaybe isPublic ifaces)
548−
549− isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
550− isPublic di =
551− case di of
552− I.Public iface -> Just (OneOrMore.one iface)
553− I.Private _ _ _ -> Nothing
554−
555−
556−
557−-- CRAWL
558−
559−
560−type StatusDict =
561− Map.Map ModuleName.Raw (MVar (Maybe Status))
562−
563−
564−data Status
565− = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
566− | SForeign I.Interface
567− | SKernelLocal [Kernel.Chunk]
568− | SKernelForeign
569−
570−
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 =
573− do let path = src </> ModuleName.toFilePath name <.> "elm"
574− exists <- File.exists path
575− case Map.lookup name foreignDeps of
576− Just ForeignAmbiguous ->
577− return Nothing
578−
579− Just (ForeignSpecific iface) ->
580− if exists
581− then return Nothing
582− else return (Just (SForeign iface))
583−
584− 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−
591− 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 =
656− 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
742−
743−
744−
745−-- DOWNLOAD PACKAGE
746−
747−
748−downloadPackage :: 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
753− do eitherByteString <-
754− Http.get manager url [] id (return . Right)
755−
756− case eitherByteString of
757− Left err ->
758− return $ Left $ Exit.PP_BadEndpointRequest err
759−
760− Right byteString ->
761− case D.fromByteString endpointDecoder byteString of
762− Left _ ->
763− return $ Left $ Exit.PP_BadEndpointContent url
764−
765− Right (endpoint, expectedHash) ->
766− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
767− \(sha, archive) ->
768− 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)
771−
772−
773−endpointDecoder :: D.Decoder e (String, String)
774−endpointDecoder =
775− do url <- D.field "url" D.string
776− hash <- D.field "hash" D.string
777− return (Utf8.toChars url, Utf8.toChars hash)
778−
779−
780−
781−-- BINARY
782−
783−
784−instance 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)
793−
794−
795−instance Binary ValidOutline where
796− put outline =
797− case outline of
798− ValidApp a -> putWord8 0 >> put a
799− ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
800−
801− get =
802− do n <- getWord8
803− case n of
804− 0 -> liftM ValidApp get
805− 1 -> liftM3 ValidPkg get get get
806− _ -> fail "binary encoding of ValidOutline was corrupted"
807−
808−
809−instance 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)
819−
820−
821−instance Binary Foreign where
822− get = liftM2 Foreign get get
823− put (Foreign a b) = put a >> put b
824−
825−
826−instance Binary Artifacts where
827− get = liftM2 Artifacts get get
828− put (Artifacts a b) = put a >> put b
829−
830−
831−instance Binary ArtifactCache where
832− get = liftM2 ArtifactCache get get
833− put (ArtifactCache a b) = put a >> put b
builder/src/Elm/Diff.hsnew file+279
@@ -0,0 +1,279 @@
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+
15+import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
16+import qualified Deps.Diff as Diff
17+import qualified Deps.Get as Get
18+import qualified Elm.Compiler.Module as Module
19+import qualified Elm.Compiler.Type as Type
20+import qualified Elm.Docs as Docs
21+import qualified Elm.Name as N
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 Reporting.Doc ((<>), (<+>))
27+import qualified Reporting.Doc as D
28+import qualified Reporting.Exit as Exit
29+import qualified Reporting.Exit.Diff as E
30+import qualified Reporting.Exit.Help as Help
31+import qualified Reporting.Render.Type.Localizer as L
32+import qualified Reporting.Task as Task
33+
34+
35+
36+-- DIFF
37+
38+
39+data Args
40+ = CodeVsLatest
41+ | CodeVsExactly Pkg.Version
42+ | LocalInquiry Pkg.Version Pkg.Version
43+ | GlobalInquiry Pkg.Name Pkg.Version Pkg.Version
44+
45+
46+diff :: Args -> Task.Task ()
47+diff args =
48+ case args of
49+ GlobalInquiry name v1 v2 ->
50+ do pkgs <- Get.all Get.RequireLatest
51+ case Get.versions name pkgs of
52+ Left suggestions ->
53+ throw $ E.UnknownPackage name suggestions
54+
55+ Right vsns ->
56+ do oldDocs <- getDocs name vsns (min v1 v2)
57+ newDocs <- getDocs name vsns (max v1 v2)
58+ writeDiff oldDocs newDocs
59+
60+ LocalInquiry v1 v2 ->
61+ do (_, name, vsns) <- getPackageInfo
62+ oldDocs <- getDocs name vsns (min v1 v2)
63+ newDocs <- getDocs name vsns (max v1 v2)
64+ writeDiff oldDocs newDocs
65+
66+ CodeVsLatest ->
67+ do (summary, name, vsns) <- getPackageInfo
68+ oldDocs <- getDocs name vsns (maximum vsns)
69+ newDocs <- Task.silently (Project.generateDocs summary)
70+ writeDiff oldDocs newDocs
71+
72+ CodeVsExactly version ->
73+ do (summary, name, vsns) <- getPackageInfo
74+ oldDocs <- getDocs name vsns version
75+ newDocs <- Task.silently (Project.generateDocs summary)
76+ writeDiff oldDocs newDocs
77+
78+
79+throw :: E.Exit -> Task.Task a
80+throw exit =
81+ Task.throw $ Exit.Diff exit
82+
83+
84+
85+-- DIFF HELPERS
86+
87+
88+getDocs :: Pkg.Name -> [Pkg.Version] -> Pkg.Version -> Task.Task Docs.Documentation
89+getDocs name allVersions version =
90+ if elem version allVersions then
91+ Get.docs name version
92+ else
93+ throw $ E.UnknownVersion name version allVersions
94+
95+
96+getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [Pkg.Version])
97+getPackageInfo =
98+ do summary <- Project.getRoot
99+ case Summary._project summary of
100+ Project.App _ ->
101+ throw $ E.Application
102+
103+ Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
104+ do pkgs <- Get.all Get.RequireLatest
105+ let vsns = either (const []) id (Get.versions name pkgs)
106+ return ( summary, name, vsns )
107+
108+
109+
110+-- WRITE DOC
111+
112+
113+writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()
114+writeDiff oldDocs newDocs =
115+ let
116+ changes = Diff.diff oldDocs newDocs
117+ localizer = L.fromNames (Map.union oldDocs newDocs)
118+ in
119+ liftIO $ Help.toStdout (toDoc localizer changes <> "\n")
120+
121+
122+
123+-- TO DOC
124+
125+
126+toDoc :: L.Localizer -> PackageChanges -> D.Doc
127+toDoc localizer changes@(PackageChanges added changed removed) =
128+ if null added && Map.null changed && null removed then
129+ "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
130+ else
131+ let
132+ magDoc =
133+ D.fromString (Diff.magnitudeToString (Diff.toMagnitude changes))
134+
135+ header =
136+ "This is a" <+> D.green magDoc <+> "change."
137+
138+ addedChunk =
139+ if null added then [] else
140+ [ Chunk "ADDED MODULES" MINOR $
141+ D.vcat $ map (D.fromString . Module.nameToString) added
142+ ]
143+
144+ removedChunk =
145+ if null removed then [] else
146+ [ Chunk "REMOVED MODULES" MAJOR $
147+ D.vcat $ map (D.fromString . Module.nameToString) removed
148+ ]
149+
150+ chunks =
151+ addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
152+ in
153+ D.vcat (header : "" : map chunkToDoc chunks)
154+
155+
156+data Chunk =
157+ Chunk
158+ { _title :: String
159+ , _magnitude :: Magnitude
160+ , _details :: D.Doc
161+ }
162+
163+
164+chunkToDoc :: Chunk -> D.Doc
165+chunkToDoc (Chunk title magnitude details) =
166+ let
167+ magDoc =
168+ Diff.magnitudeToString magnitude
169+
170+ header =
171+ "----" <+> D.fromString title <+> "-" <+> D.fromString magDoc <+> "----"
172+ in
173+ D.vcat
174+ [ D.dullcyan header
175+ , ""
176+ , D.indent 4 details
177+ , ""
178+ , ""
179+ ]
180+
181+
182+changesToChunk :: L.Localizer -> (N.Name, ModuleChanges) -> Chunk
183+changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
184+ let
185+ magnitude =
186+ Diff.moduleChangeMagnitude changes
187+
188+ (unionAdd, unionChange, unionRemove) =
189+ changesToDocTriple (unionToDoc localizer) unions
190+
191+ (aliasAdd, aliasChange, aliasRemove) =
192+ changesToDocTriple (aliasToDoc localizer) aliases
193+
194+ (valueAdd, valueChange, valueRemove) =
195+ changesToDocTriple (valueToDoc localizer) values
196+
197+ (binopAdd, binopChange, binopRemove) =
198+ changesToDocTriple (binopToDoc localizer) binops
199+ in
200+ Chunk (N.toString name) magnitude $
201+ D.vcat $ List.intersperse "" $ Maybe.catMaybes $
202+ [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
203+ , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
204+ , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
205+ ]
206+
207+
208+changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
209+changesToDocTriple entryToDoc (Changes added changed removed) =
210+ let
211+ indented (name, value) =
212+ D.indent 4 (entryToDoc name value)
213+
214+ diffed (name, (oldValue, newValue)) =
215+ D.vcat
216+ [ " - " <> entryToDoc name oldValue
217+ , " + " <> entryToDoc name newValue
218+ , ""
219+ ]
220+ in
221+ ( map indented (Map.toList added)
222+ , map diffed (Map.toList changed)
223+ , map indented (Map.toList removed)
224+ )
225+
226+
227+changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
228+changesToDoc categoryName unions aliases values binops =
229+ if null unions && null aliases && null values && null binops then
230+ Nothing
231+
232+ else
233+ Just $ D.vcat $
234+ D.fromString categoryName <> ":" : unions ++ aliases ++ binops ++ values
235+
236+
237+unionToDoc :: L.Localizer -> N.Name -> Docs.Union -> D.Doc
238+unionToDoc localizer name (Docs.Union _ tvars ctors) =
239+ let
240+ setup =
241+ "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
242+
243+ ctorDoc (ctor, tipes) =
244+ typeDoc localizer (Type.Type ctor tipes)
245+ in
246+ D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
247+
248+
249+aliasToDoc :: L.Localizer -> N.Name -> Docs.Alias -> D.Doc
250+aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
251+ let
252+ declaration =
253+ "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
254+ in
255+ D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
256+
257+
258+valueToDoc :: L.Localizer -> N.Name -> Docs.Value -> D.Doc
259+valueToDoc localizer name (Docs.Value _ tipe) =
260+ D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
261+
262+
263+binopToDoc :: L.Localizer -> N.Name -> Docs.Binop -> D.Doc
264+binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
265+ "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
266+ where
267+ details =
268+ " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
269+
270+ assoc =
271+ case associativity of
272+ Docs.Left -> "left"
273+ Docs.Non -> "non"
274+ Docs.Right -> "right"
275+
276+
277+typeDoc :: L.Localizer -> Type.Type -> D.Doc
278+typeDoc localizer tipe =
279+ Type.toDoc localizer Type.None tipe
builder/src/Elm/Install.hsnew file+357
@@ -0,0 +1,357 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Install
3+ ( install
4+ )
5+ where
6+
7+
8+import Control.Monad (filterM, forM, msum, void)
9+import Control.Monad.Except (catchError, lift, liftIO)
10+import Data.Map (Map, (!))
11+import qualified Data.Map as Map
12+import qualified Data.Map.Merge.Lazy as Map
13+import System.IO (stdout)
14+
15+import qualified Elm.Package as Pkg
16+import Elm.Package (Name, Version)
17+
18+import Deps.Explorer (Explorer)
19+import qualified Deps.Explorer as Explorer
20+import qualified Deps.Verify as Verify
21+import qualified Deps.Solver as Solver
22+import Elm.Project.Constraint (Constraint)
23+import qualified Elm.Project.Constraint as Con
24+import qualified Elm.Project.Json as Project
25+import qualified Elm.Project.Root as Root
26+import Reporting.Doc ((<>), (<+>))
27+import qualified Reporting.Doc as D
28+import qualified Reporting.Exit as Exit
29+import qualified Reporting.Exit.Install as E
30+import qualified Reporting.Task as Task
31+
32+
33+
34+-- INSTALL
35+
36+
37+install :: Name -> Task.Task ()
38+install pkg =
39+ do (root, oldProject) <- Root.unsafeGet
40+ makePlan pkg oldProject $ \newProject ->
41+ let
42+ upgrade =
43+ do liftIO $ Project.write root newProject
44+ void $ Verify.verify root newProject
45+
46+ revert err =
47+ do liftIO $ Project.write root oldProject
48+ Task.throw err
49+ in
50+ upgrade `catchError` revert
51+
52+
53+
54+-- MAKE PLAN
55+
56+
57+makePlan :: Name -> Project.Project -> (Project.Project -> Task.Task ()) -> Task.Task ()
58+makePlan pkg project attemptInstall =
59+ case project of
60+ Project.App info@(Project.AppInfo elm srcDirs deps test trans) ->
61+ do changes <- addToApp pkg info
62+
63+ let news = Map.mapMaybe keepNew changes
64+ let newDeps = addNews (Just pkg) news deps
65+ let newTest = addNews Nothing news test
66+ let newTrans = Map.union (Map.difference news (Map.union newDeps newTest)) trans
67+ let newInfo = Project.AppInfo elm srcDirs newDeps newTest newTrans
68+ let newProject = Project.App newInfo
69+
70+ withApproval Pkg.versionToString changes (attemptInstall newProject)
71+
72+ Project.Pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) ->
73+ do changes <- addToPkg pkg info
74+
75+ let news = Map.mapMaybe keepNew changes
76+ let newProject = Project.Pkg $
77+ info
78+ { Project._pkg_deps = addNews (Just pkg) news deps
79+ , Project._pkg_test_deps = addNews Nothing news test
80+ }
81+
82+ withApproval (show . Con.toString) changes (attemptInstall newProject)
83+
84+
85+addNews :: Maybe Name -> Map Name a -> Map Name a -> Map Name a
86+addNews pkg new old =
87+ Map.merge
88+ Map.preserveMissing
89+ (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))
90+ (Map.zipWithMatched (\_ _ n -> n))
91+ old
92+ new
93+
94+
95+
96+-- CHANGES
97+
98+
99+data Change a
100+ = Insert a
101+ | Change a a
102+ | Remove a
103+
104+
105+detectChanges :: (Eq a) => Map Name a -> Map Name a -> Map Name (Change a)
106+detectChanges old new =
107+ Map.merge
108+ (Map.mapMissing (\_ v -> Remove v))
109+ (Map.mapMissing (\_ v -> Insert v))
110+ (Map.zipWithMaybeMatched keepChange)
111+ old
112+ new
113+
114+
115+keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
116+keepChange _ old new =
117+ if old == new then
118+ Nothing
119+ else
120+ Just (Change old new)
121+
122+
123+keepNew :: Change a -> Maybe a
124+keepNew change =
125+ case change of
126+ Insert a ->
127+ Just a
128+
129+ Change _ a ->
130+ Just a
131+
132+ Remove _ ->
133+ Nothing
134+
135+
136+
137+-- ADD TO APP
138+
139+
140+addToApp :: Name -> Project.AppInfo -> Task.Task (Map Name (Change Version))
141+addToApp pkg info@(Project.AppInfo _ _ deps tests trans) =
142+ Explorer.run $
143+ do Explorer.exists pkg
144+ let old = Map.unions [ deps, tests, trans ]
145+ result <- Solver.run (addToAppHelp pkg info)
146+ case result of
147+ Just new ->
148+ return $ detectChanges old new
149+
150+ Nothing ->
151+ do badNames <- filterM isBadElm (pkg : Map.keys old)
152+ lift $ Task.throw (Exit.Install (E.NoSolution badNames))
153+
154+
155+addToAppHelp :: Name -> Project.AppInfo -> Solver.Solver (Map Name Version)
156+addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =
157+ let
158+ directs =
159+ Map.union deps tests
160+
161+ everything =
162+ Map.union directs trans
163+
164+ try constraints =
165+ Solver.solve $ Map.insert pkg Con.anything constraints
166+ in
167+ msum $ map try $
168+ [ Map.map Con.exactly everything
169+ , Map.map Con.exactly directs
170+ , Map.map Con.untilNextMinor directs
171+ , Map.map Con.untilNextMajor directs
172+ , Map.map (\_ -> Con.anything) directs
173+ ]
174+
175+
176+
177+-- ADD TO PKG
178+
179+
180+addToPkg :: Name -> Project.PkgInfo -> Task.Task (Map Name (Change Constraint))
181+addToPkg pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
182+ Explorer.run $
183+ do Explorer.exists pkg
184+ let old = Map.union deps tests
185+ result <- Solver.run (addToPkgHelp pkg info)
186+ case result of
187+ Just new ->
188+ return $ detectChanges old new
189+
190+ Nothing ->
191+ do let pkgs = Map.keys deps ++ Map.keys tests
192+ badNames <- filterM isBadElm (pkg : pkgs)
193+ lift $ Task.throw (Exit.Install (E.NoSolution badNames))
194+
195+
196+addToPkgHelp :: Name -> Project.PkgInfo -> Solver.Solver (Map Name Constraint)
197+addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
198+ do let directs = Map.union deps tests
199+ let newCons = Map.insert pkg Con.anything directs
200+ solution <- Solver.solve newCons
201+ let con = Con.untilNextMajor (solution ! pkg)
202+ return $ Map.insert pkg con directs
203+
204+
205+
206+-- FAILURE HINTS
207+
208+
209+isBadElm :: Name -> Explorer Bool
210+isBadElm name =
211+ do versions <- Explorer.getVersions name
212+
213+ elmVersions <- forM versions $ \vsn ->
214+ Explorer._elm <$> Explorer.getConstraints name vsn
215+
216+ return (not (any Con.goodElm elmVersions))
217+
218+
219+
220+-- VIEW
221+
222+
223+withApproval :: (a -> String) -> Map Name (Change a) -> Task.Task () -> Task.Task ()
224+withApproval toString changes attemptInstall =
225+ let
226+ widths =
227+ Map.foldrWithKey (widen toString) (Widths 0 0 0) changes
228+
229+ changeDocs =
230+ Map.foldrWithKey (addChange toString widths) (Docs [] [] []) changes
231+ in
232+ case changeDocs of
233+ Docs [] [] [] ->
234+ do liftIO $ putStrLn "Already installed. No changes necessary!"
235+
236+ Docs inserts [] [] ->
237+ do liftIO $ putStrLn "Adding the following dependencies:\n"
238+ liftIO $ D.toAnsi stdout $ D.indent 2 (D.vcat (reverse inserts))
239+ liftIO $ putStrLn "\n"
240+ attemptInstall
241+
242+ Docs _ _ _ ->
243+ do liftIO $ putStrLn "Here is my plan:"
244+ liftIO $ D.toAnsi stdout $ viewChangeDocs changeDocs
245+ liftIO $ putStrLn "\nDo you approve? [Y/n]: "
246+ Task.withApproval attemptInstall
247+
248+
249+
250+-- VIEW CHANGE DOCS
251+
252+
253+data ChangeDocs =
254+ Docs
255+ { _doc_inserts :: [D.Doc]
256+ , _doc_changes :: [D.Doc]
257+ , _doc_removes :: [D.Doc]
258+ }
259+
260+
261+viewChangeDocs :: ChangeDocs -> D.Doc
262+viewChangeDocs (Docs inserts changes removes) =
263+ D.indent 2 $ D.vcat $ concat $
264+ [ viewNonZero "Add:" inserts
265+ , viewNonZero "Change:" changes
266+ , viewNonZero "Remove:" removes
267+ ]
268+
269+
270+viewNonZero :: String -> [D.Doc] -> [D.Doc]
271+viewNonZero title entries =
272+ if null entries then
273+ []
274+ else
275+ [ ""
276+ , D.fromString title
277+ , D.indent 2 (D.vcat (reverse entries))
278+ ]
279+
280+
281+
282+-- VIEW CHANGE
283+
284+
285+addChange :: (a -> String) -> Widths -> Name -> Change a -> ChangeDocs -> ChangeDocs
286+addChange toString widths name change (Docs inserts changes removes) =
287+ case change of
288+ Insert new ->
289+ Docs (viewInsert toString widths name new : inserts) changes removes
290+
291+ Change old new ->
292+ Docs inserts (viewChange toString widths name old new : changes) removes
293+
294+ Remove old ->
295+ Docs inserts changes (viewRemove toString widths name old : removes)
296+
297+
298+viewInsert :: (a -> String) -> Widths -> Name -> a -> D.Doc
299+viewInsert toString (Widths nameWidth leftWidth _) name new =
300+ viewName nameWidth name <+> pad leftWidth (toString new)
301+
302+
303+viewChange :: (a -> String) -> Widths -> Name -> a -> a -> D.Doc
304+viewChange toString (Widths nameWidth leftWidth rightWidth) name old new =
305+ D.hsep
306+ [ viewName nameWidth name
307+ , pad leftWidth (toString old)
308+ , "=>"
309+ , pad rightWidth (toString new)
310+ ]
311+
312+
313+viewRemove :: (a -> String) -> Widths -> Name -> a -> D.Doc
314+viewRemove toString (Widths nameWidth leftWidth _) name old =
315+ viewName nameWidth name <+> pad leftWidth (toString old)
316+
317+
318+viewName :: Int -> Name -> D.Doc
319+viewName width name =
320+ D.fill (width + 3) (D.fromText (Pkg.toText name))
321+
322+
323+pad :: Int -> String -> D.Doc
324+pad width string =
325+ D.fromString (replicate (width - length string) ' ') <> D.fromString string
326+
327+
328+
329+-- WIDTHS
330+
331+
332+data Widths =
333+ Widths
334+ { _name :: !Int
335+ , _left :: !Int
336+ , _right :: !Int
337+ }
338+
339+
340+widen :: (a -> String) -> Name -> Change a -> Widths -> Widths
341+widen toString pkg change (Widths name left right) =
342+ let
343+ toLength a =
344+ length (toString a)
345+
346+ newName =
347+ max name (length (Pkg.toString pkg))
348+ in
349+ case change of
350+ Insert new ->
351+ Widths newName (max left (toLength new)) right
352+
353+ Change old new ->
354+ Widths newName (max left (toLength old)) (max right (toLength new))
355+
356+ Remove old ->
357+ Widths newName (max left (toLength old)) right
builder/src/Elm/Outline.hsdeleted−407
@@ -1,407 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
3−module Elm.Outline
4− ( Outline(..)
5− , AppOutline(..)
6− , PkgOutline(..)
7− , Exposed(..)
8− , SrcDir(..)
9− , read
10− , write
11− , encode
12− , decoder
13− , defaultSummary
14− , flattenExposed
15− )
16− where
17−
18−
19−import Prelude hiding (read)
20−import Control.Monad (filterM, liftM)
21−import Data.Binary (Binary, get, put, getWord8, putWord8)
22−import qualified Data.Map as Map
23−import qualified Data.NonEmptyList as NE
24−import qualified Data.OneOrMore as OneOrMore
25−import Foreign.Ptr (minusPtr)
26−import qualified System.Directory as Dir
27−import qualified System.FilePath as FP
28−import System.FilePath ((</>))
29−
30−import qualified Elm.Constraint as Con
31−import qualified Elm.Licenses as Licenses
32−import qualified Elm.ModuleName as ModuleName
33−import qualified Elm.Package as Pkg
34−import qualified Elm.Version as V
35−import qualified File
36−import qualified Json.Decode as D
37−import qualified Json.Encode as E
38−import Json.Encode ((==>))
39−import qualified Json.String as Json
40−import qualified Parse.Primitives as P
41−import qualified Reporting.Exit as Exit
42−
43−
44−
45−-- OUTLINE
46−
47−
48−data Outline
49− = App AppOutline
50− | Pkg PkgOutline
51−
52−
53−data AppOutline =
54− AppOutline
55− { _app_elm_version :: V.Version
56− , _app_source_dirs :: NE.List SrcDir
57− , _app_deps_direct :: Map.Map Pkg.Name V.Version
58− , _app_deps_indirect :: Map.Map Pkg.Name V.Version
59− , _app_test_direct :: Map.Map Pkg.Name V.Version
60− , _app_test_indirect :: Map.Map Pkg.Name V.Version
61− }
62−
63−
64−data PkgOutline =
65− PkgOutline
66− { _pkg_name :: Pkg.Name
67− , _pkg_summary :: Json.String
68− , _pkg_license :: Licenses.License
69− , _pkg_version :: V.Version
70− , _pkg_exposed :: Exposed
71− , _pkg_deps :: Map.Map Pkg.Name Con.Constraint
72− , _pkg_test_deps :: Map.Map Pkg.Name Con.Constraint
73− , _pkg_elm_version :: Con.Constraint
74− }
75−
76−
77−data Exposed
78− = ExposedList [ModuleName.Raw]
79− | ExposedDict [(Json.String, [ModuleName.Raw])]
80−
81−
82−data SrcDir
83− = AbsoluteSrcDir FilePath
84− | RelativeSrcDir FilePath
85−
86−
87−
88−-- DEFAULTS
89−
90−
91−defaultSummary :: Json.String
92−defaultSummary =
93− Json.fromChars "helpful summary of your project, less than 80 characters"
94−
95−
96−
97−-- HELPERS
98−
99−
100−flattenExposed :: Exposed -> [ModuleName.Raw]
101−flattenExposed exposed =
102− case exposed of
103− ExposedList names ->
104− names
105−
106− ExposedDict sections ->
107− concatMap snd sections
108−
109−
110−
111−-- WRITE
112−
113−
114−write :: FilePath -> Outline -> IO ()
115−write root outline =
116− E.write (root </> "elm.json") (encode outline)
117−
118−
119−
120−-- JSON ENCODE
121−
122−
123−encode :: Outline -> E.Value
124−encode outline =
125− case outline of
126− App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
127− E.object
128− [ "type" ==> E.chars "application"
129− , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
130− , "elm-version" ==> V.encode elm
131− , "dependencies" ==>
132− E.object
133− [ "direct" ==> encodeDeps V.encode depsDirect
134− , "indirect" ==> encodeDeps V.encode depsTrans
135− ]
136− , "test-dependencies" ==>
137− E.object
138− [ "direct" ==> encodeDeps V.encode testDirect
139− , "indirect" ==> encodeDeps V.encode testTrans
140− ]
141− ]
142−
143− Pkg (PkgOutline name summary license version exposed deps tests elm) ->
144− E.object
145− [ "type" ==> E.string (Json.fromChars "package")
146− , "name" ==> Pkg.encode name
147− , "summary" ==> E.string summary
148− , "license" ==> Licenses.encode license
149− , "version" ==> V.encode version
150− , "exposed-modules" ==> encodeExposed exposed
151− , "elm-version" ==> Con.encode elm
152− , "dependencies" ==> encodeDeps Con.encode deps
153− , "test-dependencies" ==> encodeDeps Con.encode tests
154− ]
155−
156−
157−encodeExposed :: Exposed -> E.Value
158−encodeExposed exposed =
159− case exposed of
160− ExposedList modules ->
161− E.list encodeModule modules
162−
163− ExposedDict chunks ->
164− E.object (map (fmap (E.list encodeModule)) chunks)
165−
166−
167−encodeModule :: ModuleName.Raw -> E.Value
168−encodeModule name =
169− E.name name
170−
171−
172−encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
173−encodeDeps 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
182−
183−
184−
185−-- PARSE AND VERIFY
186−
187−
188−read :: FilePath -> IO (Either Exit.Outline Outline)
189−read root =
190− do bytes <- File.readUtf8 (root </> "elm.json")
191− case D.fromByteString decoder bytes of
192− Left err ->
193− return $ Left (Exit.OutlineHasBadStructure err)
194−
195− Right outline ->
196− 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−
237−
238−toAbsolute :: FilePath -> SrcDir -> FilePath
239−toAbsolute root srcDir =
240− case srcDir of
241− AbsoluteSrcDir dir -> dir
242− RelativeSrcDir dir -> root </> dir
243−
244−
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)
263−
264−
265−
266−-- JSON DECODE
267−
268−
269−type Decoder a =
270− D.Decoder Exit.OutlineProblem a
271−
272−
273−decoder :: Decoder Outline
274−decoder =
275− let
276− application = Json.fromChars "application"
277− package = Json.fromChars "package"
278− in
279− 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
283−
284−
285−appDecoder :: Decoder AppOutline
286−appDecoder =
287− AppOutline
288− <$> D.field "elm-version" versionDecoder
289− <*> D.field "source-directories" dirsDecoder
290− <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
291− <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
292− <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
293− <*> D.field "test-dependencies" (D.field "indirect" (depsDecoder versionDecoder))
294−
295−
296−pkgDecoder :: Decoder PkgOutline
297−pkgDecoder =
298− PkgOutline
299− <$> D.field "name" nameDecoder
300− <*> D.field "summary" summaryDecoder
301− <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
302− <*> D.field "version" versionDecoder
303− <*> D.field "exposed-modules" exposedDecoder
304− <*> D.field "dependencies" (depsDecoder constraintDecoder)
305− <*> D.field "test-dependencies" (depsDecoder constraintDecoder)
306− <*> D.field "elm-version" constraintDecoder
307−
308−
309−
310−-- JSON DECODE HELPERS
311−
312−
313−nameDecoder :: Decoder Pkg.Name
314−nameDecoder =
315− D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316−
317−
318−summaryDecoder :: Decoder Json.String
319−summaryDecoder =
320− D.customString
321− (boundParser 80 Exit.OP_BadSummaryTooLong)
322− (\_ _ -> Exit.OP_BadSummaryTooLong)
323−
324−
325−versionDecoder :: Decoder V.Version
326−versionDecoder =
327− D.mapError (uncurry Exit.OP_BadVersion) V.decoder
328−
329−
330−constraintDecoder :: Decoder Con.Constraint
331−constraintDecoder =
332− D.mapError Exit.OP_BadConstraint Con.decoder
333−
334−
335−depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
336−depsDecoder valueDecoder =
337− D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
338−
339−
340−dirsDecoder :: Decoder (NE.List SrcDir)
341−dirsDecoder =
342− fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
343−
344−
345−toSrcDir :: FilePath -> SrcDir
346−toSrcDir path =
347− if FP.isRelative path
348− then RelativeSrcDir path
349− else AbsoluteSrcDir path
350−
351−
352−
353−-- EXPOSED MODULES DECODER
354−
355−
356−exposedDecoder :: Decoder Exposed
357−exposedDecoder =
358− D.oneOf
359− [ ExposedList <$> D.list moduleDecoder
360− , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
361− ]
362−
363−
364−moduleDecoder :: Decoder ModuleName.Raw
365−moduleDecoder =
366− D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
367−
368−
369−headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
370−headerKeyDecoder =
371− D.KeyDecoder
372− (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
373− (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
374−
375−
376−
377−-- BOUND PARSER
378−
379−
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)
390−
391−
392−
393−-- BINARY
394−
395−
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
401−
402− get =
403− do n <- getWord8
404− case n of
405− 0 -> liftM AbsoluteSrcDir get
406− 1 -> liftM RelativeSrcDir get
407− _ -> fail "binary encoding of SrcDir was corrupted"
builder/src/Elm/PerUserCache.hsnew file+47
@@ -0,0 +1,47 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Elm.PerUserCache
3+ ( getPackageRoot
4+ , getReplRoot
5+ , getElmHome
6+ )
7+ where
8+
9+import qualified System.Directory as Dir
10+import qualified System.Environment as Env
11+import System.FilePath ((</>))
12+
13+import qualified Elm.Compiler as Compiler
14+import qualified Elm.Package as Pkg
15+
16+
17+
18+-- ROOTS
19+
20+
21+getPackageRoot :: IO FilePath
22+getPackageRoot =
23+ getRoot "package"
24+
25+
26+getReplRoot :: IO FilePath
27+getReplRoot =
28+ getRoot "repl"
29+
30+
31+getRoot :: FilePath -> IO FilePath
32+getRoot projectName =
33+ do home <- getElmHome
34+ let root = home </> version </> projectName
35+ Dir.createDirectoryIfMissing True root
36+ return root
37+
38+
39+version :: FilePath
40+version =
41+ Pkg.versionToString Compiler.version
42+
43+
44+getElmHome :: IO FilePath
45+getElmHome =
46+ do maybeHome <- Env.lookupEnv "ELM_HOME"
47+ maybe (Dir.getAppUserDataDirectory "elm") return maybeHome
builder/src/Elm/Project.hsnew file+98
@@ -0,0 +1,98 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Project
4+ ( getRoot
5+ , getRootWithReplFallback
6+ , compile
7+ , compileForRepl
8+ , generateDocs
9+ )
10+ where
11+
12+
13+import qualified Data.ByteString as BS
14+import Data.Map ((!))
15+import System.FilePath ((</>))
16+
17+import qualified Elm.Compiler as Compiler
18+import qualified Elm.Docs as Docs
19+import qualified Elm.Name as N
20+import qualified Elm.Project.Root as Root
21+import qualified Elm.Project.Summary as Summary
22+import Elm.Project.Summary (Summary)
23+import qualified File.Args as Args
24+import qualified File.Artifacts as Artifacts
25+import qualified File.Compile as Compile
26+import qualified File.Crawl as Crawl
27+import qualified File.Plan as Plan
28+import qualified Generate.Output as Output
29+import qualified Reporting.Render.Type.Localizer as L
30+import qualified Reporting.Task as Task
31+import qualified Stuff.Paths as Path
32+
33+
34+
35+-- GET ROOT
36+
37+
38+getRoot :: Task.Task Summary
39+getRoot =
40+ Root.get
41+
42+
43+getRootWithReplFallback :: IO FilePath
44+getRootWithReplFallback =
45+ Root.getWithReplFallback
46+
47+
48+
49+-- COMPILE
50+
51+
52+compile
53+ :: Output.Mode
54+ -> Output.Target
55+ -> Maybe Output.Output
56+ -> Maybe FilePath
57+ -> Summary
58+ -> [FilePath]
59+ -> Task.Task ()
60+compile mode target maybeOutput docs summary@(Summary.Summary root project _ _ _) paths =
61+ do args <- Args.fromPaths summary paths
62+ graph <- Crawl.crawl summary args
63+ (dirty, ifaces) <- Plan.plan docs summary graph
64+ answers <- Compile.compile project docs ifaces dirty
65+ results <- Artifacts.write root answers
66+ _ <- traverse (Artifacts.writeDocs results) docs
67+ Output.generate mode target maybeOutput summary graph results
68+
69+
70+
71+-- COMPILE FOR REPL
72+
73+
74+compileForRepl :: Bool -> L.Localizer -> BS.ByteString -> Maybe N.Name -> Task.Task (Maybe FilePath)
75+compileForRepl noColors localizer source maybeName =
76+ do summary@(Summary.Summary root project _ _ _) <- getRoot
77+ graph <- Crawl.crawlFromSource summary source
78+ (dirty, ifaces) <- Plan.plan Nothing summary graph
79+ answers <- Compile.compile project Nothing ifaces dirty
80+ results <- Artifacts.write root answers
81+ let (Compiler.Artifacts elmi _ _) = results ! N.replModule
82+ traverse (Output.generateReplFile noColors localizer summary graph elmi) maybeName
83+
84+
85+
86+-- GENERATE DOCS
87+
88+
89+generateDocs :: Summary.Summary -> Task.Task Docs.Documentation
90+generateDocs summary@(Summary.Summary root project _ _ _) =
91+ do let docsPath = root </> Path.docs
92+ args <- Args.fromSummary summary
93+ graph <- Crawl.crawl summary args
94+ (dirty, ifaces) <- Plan.plan (Just docsPath) summary graph
95+ answers <- Compile.compile project (Just docsPath) ifaces dirty
96+ results <- Artifacts.write root answers
97+ Output.noDebugUsesInPackage summary graph
98+ Artifacts.writeDocs results docsPath
builder/src/Elm/Project/Constraint.hsnew file+234
@@ -0,0 +1,234 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Project.Constraint
4+ ( Constraint
5+ , exactly
6+ , anything
7+ , fromText
8+ , toString
9+ , toText
10+ , satisfies
11+ , check
12+ , intersect
13+ , goodElm
14+ , defaultElm
15+ , untilNextMajor
16+ , untilNextMinor
17+ , expand
18+ )
19+ where
20+
21+import qualified Data.Text as Text
22+import Data.Text (Text)
23+
24+import qualified Elm.Compiler as Compiler
25+import qualified Elm.Package as Pkg
26+import Elm.Package (Version(..))
27+
28+
29+
30+-- CONSTRAINTS
31+
32+
33+data Constraint
34+ = Range Version Op Op Version
35+ deriving (Eq)
36+
37+
38+data Op
39+ = Less
40+ | LessOrEqual
41+ deriving (Eq)
42+
43+
44+
45+-- COMMON CONSTRAINTS
46+
47+
48+exactly :: Version -> Constraint
49+exactly version =
50+ Range version LessOrEqual LessOrEqual version
51+
52+
53+anything :: Constraint
54+anything =
55+ Range (Version 1 0 0) LessOrEqual LessOrEqual (Version 30000 0 0)
56+
57+
58+
59+-- TEXT CONVERSION
60+
61+
62+toString :: Constraint -> String
63+toString constraint =
64+ Text.unpack (toText constraint)
65+
66+
67+toText :: Constraint -> Text
68+toText constraint =
69+ case constraint of
70+ Range lower lowerOp upperOp upper ->
71+ Text.intercalate " "
72+ [ Pkg.versionToText lower
73+ , opToText lowerOp
74+ , "v"
75+ , opToText upperOp
76+ , Pkg.versionToText upper
77+ ]
78+
79+
80+opToText :: Op -> Text
81+opToText op =
82+ case op of
83+ Less ->
84+ "<"
85+
86+ LessOrEqual ->
87+ "<="
88+
89+
90+fromText :: Text -> Either String Constraint
91+fromText text =
92+ case Text.splitOn " " text of
93+ [lower, lowerOp, "v", upperOp, upper] ->
94+ do lo <- versionFromText "lower" lower
95+ lop <- opFromText lowerOp
96+ hop <- opFromText upperOp
97+ hi <- versionFromText "upper" upper
98+ if lo < hi
99+ then Right (Range lo lop hop hi)
100+ else
101+ Left $
102+ "The lower bound (" ++ Text.unpack lower
103+ ++ ") must be less than the upper bound ("
104+ ++ Text.unpack upper ++ ")"
105+
106+ _ ->
107+ Left "The standard format is \"1.0.0 <= v < 2.0.0\""
108+
109+
110+versionFromText :: String -> Text -> Either String Version
111+versionFromText lowerOrUpper text =
112+ case Pkg.versionFromText text of
113+ Just vsn ->
114+ Right vsn
115+
116+ Nothing ->
117+ Left $ "The " ++ lowerOrUpper ++ " bound (" ++ Text.unpack text ++ ") is not a valid version number."
118+
119+
120+opFromText :: Text -> Either String Op
121+opFromText text =
122+ case text of
123+ "<=" ->
124+ Right LessOrEqual
125+
126+ "<" ->
127+ Right Less
128+
129+ _ ->
130+ Left $ "The operator (" ++ Text.unpack text ++ ") is not valid. Must be (<=) or (<)."
131+
132+
133+
134+-- IS SATISFIED
135+
136+
137+satisfies :: Constraint -> Version -> Bool
138+satisfies constraint version =
139+ case constraint of
140+ Range lower lowerOp upperOp upper ->
141+ isLess lowerOp lower version
142+ &&
143+ isLess upperOp version upper
144+
145+
146+isLess :: (Ord a) => Op -> (a -> a -> Bool)
147+isLess op =
148+ case op of
149+ Less ->
150+ (<)
151+
152+ LessOrEqual ->
153+ (<=)
154+
155+
156+check :: Constraint -> Version -> Ordering
157+check constraint version =
158+ case constraint of
159+ Range lower lowerOp upperOp upper ->
160+ if not (isLess lowerOp lower version) then
161+ LT
162+
163+ else if not (isLess upperOp version upper) then
164+ GT
165+
166+ else
167+ EQ
168+
169+
170+
171+-- INTERSECT
172+
173+
174+intersect :: Constraint -> Constraint -> Maybe Constraint
175+intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) =
176+ let
177+ (newLo, newLop) =
178+ case compare lo lo_ of
179+ LT -> (lo_, lop_)
180+ EQ -> (lo, if elem Less [lop,lop_] then Less else LessOrEqual)
181+ GT -> (lo, lop)
182+
183+ (newHi, newHop) =
184+ case compare hi hi_ of
185+ LT -> (hi, hop)
186+ EQ -> (hi, if elem Less [hop, hop_] then Less else LessOrEqual)
187+ GT -> (hi_, hop_)
188+ in
189+ if newLo <= newHi then
190+ Just (Range newLo newLop newHop newHi)
191+ else
192+ Nothing
193+
194+
195+
196+-- ELM CONSTRAINT
197+
198+
199+goodElm :: Constraint -> Bool
200+goodElm constraint =
201+ satisfies constraint Compiler.version
202+
203+
204+defaultElm :: Constraint
205+defaultElm =
206+ if Pkg._major Compiler.version > 0
207+ then untilNextMajor Compiler.version
208+ else untilNextMinor Compiler.version
209+
210+
211+
212+-- CREATE CONSTRAINTS
213+
214+
215+untilNextMajor :: Version -> Constraint
216+untilNextMajor version =
217+ Range version LessOrEqual Less (Pkg.bumpMajor version)
218+
219+
220+untilNextMinor :: Version -> Constraint
221+untilNextMinor version =
222+ Range version LessOrEqual Less (Pkg.bumpMinor version)
223+
224+
225+expand :: Constraint -> Version -> Constraint
226+expand constraint@(Range lower lowerOp upperOp upper) version
227+ | version < lower =
228+ Range version LessOrEqual upperOp upper
229+
230+ | version > upper =
231+ Range lower lowerOp Less (Pkg.bumpMajor version)
232+
233+ | otherwise =
234+ constraint
builder/src/Elm/Project/Json.hsnew file+423
@@ -0,0 +1,423 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Project.Json
4+ ( Project(..)
5+ , AppInfo(..)
6+ , PkgInfo(..)
7+ , Exposed(..)
8+ , defaultSummary
9+ -- json
10+ , write
11+ , encode
12+ , read
13+ , pkgDecoder
14+ -- queries
15+ , appSolution
16+ , isPlatformPackage
17+ , get
18+ , getName
19+ , getExposed
20+ )
21+ where
22+
23+
24+import Prelude hiding (read)
25+import Control.Monad.Trans (liftIO)
26+import qualified Data.ByteString as BS
27+import Data.Foldable (traverse_)
28+import Data.Map (Map)
29+import Data.Text (Text)
30+import qualified Data.Map as Map
31+import qualified Data.Text as Text
32+import qualified System.Directory as Dir
33+import System.FilePath ((</>))
34+
35+import qualified Elm.Compiler.Module as Module
36+import qualified Elm.Package as Pkg
37+import Elm.Package (Name, Version)
38+
39+import qualified Elm.Project.Constraint as Con
40+import qualified Elm.Project.Licenses as Licenses
41+import qualified Json.Decode as D
42+import qualified Json.Encode as E
43+import qualified Reporting.Exit as Exit
44+import qualified Reporting.Exit.Assets as E
45+import qualified Reporting.Task as Task
46+
47+
48+
49+-- PROJECT
50+
51+
52+data Project
53+ = App AppInfo
54+ | Pkg PkgInfo
55+
56+
57+
58+-- APPLICATION
59+
60+
61+data AppInfo =
62+ AppInfo
63+ { _app_elm_version :: Version
64+ , _app_source_dirs :: [FilePath]
65+ , _app_deps :: Map Name Version
66+ , _app_test_deps :: Map Name Version
67+ , _app_trans_deps :: Map Name Version
68+ }
69+
70+
71+
72+-- PACKAGE
73+
74+
75+data PkgInfo =
76+ PkgInfo
77+ { _pkg_name :: Name
78+ , _pkg_summary :: Text
79+ , _pkg_license :: Licenses.License
80+ , _pkg_version :: Version
81+ , _pkg_exposed :: Exposed
82+ , _pkg_deps :: Map Name Con.Constraint
83+ , _pkg_test_deps :: Map Name Con.Constraint
84+ , _pkg_elm_version :: Con.Constraint
85+ }
86+
87+
88+data Exposed
89+ = ExposedList [Module.Raw]
90+ | ExposedDict [(Text, [Module.Raw])]
91+
92+
93+
94+-- DEFAULTS
95+
96+
97+defaultSummary :: Text
98+defaultSummary =
99+ "helpful summary of your project, less than 80 characters"
100+
101+
102+
103+-- QUERIES
104+
105+
106+appSolution :: AppInfo -> Map Name Version
107+appSolution info =
108+ Map.unions
109+ [ _app_deps info
110+ , _app_test_deps info
111+ , _app_trans_deps info
112+ ]
113+
114+
115+isPlatformPackage :: Project -> Bool
116+isPlatformPackage project =
117+ case project of
118+ App _ ->
119+ False
120+
121+ Pkg info ->
122+ let
123+ (Pkg.Name user _) =
124+ _pkg_name info
125+ in
126+ user == "elm-lang" || user == "elm-explorations"
127+
128+
129+get :: (AppInfo -> a) -> (PkgInfo -> a) -> Project -> a
130+get appFunc pkgFunc project =
131+ case project of
132+ App info ->
133+ appFunc info
134+
135+ Pkg info ->
136+ pkgFunc info
137+
138+
139+getName :: Project -> Name
140+getName project =
141+ get (\_ -> Pkg.dummyName) _pkg_name project
142+
143+
144+getExposed :: PkgInfo -> [Module.Raw]
145+getExposed info =
146+ case _pkg_exposed info of
147+ ExposedList modules ->
148+ modules
149+
150+ ExposedDict chunks ->
151+ concatMap snd chunks
152+
153+
154+
155+-- WRITE
156+
157+
158+write :: FilePath -> Project -> IO ()
159+write root project =
160+ E.write (root </> "elm.json") (encode project)
161+
162+
163+
164+-- JSON ENCODE
165+
166+
167+encode :: Project -> E.Value
168+encode project =
169+ case project of
170+ App (AppInfo elm srcDirs deps tests trans) ->
171+ E.object
172+ [ "type" ==> E.text "application"
173+ , "source-directories" ==> E.list (E.text . Text.pack) srcDirs
174+ , "elm-version" ==> encodeVersion elm
175+ , "dependencies" ==> encodeDeps encodeVersion deps
176+ , "test-dependencies" ==> encodeDeps encodeVersion tests
177+ , "do-not-edit-this-by-hand" ==>
178+ E.object [ "transitive-dependencies" ==> encodeDeps encodeVersion trans ]
179+ ]
180+
181+ Pkg (PkgInfo name summary license version exposed deps tests elm) ->
182+ E.object
183+ [ "type" ==> E.text "package"
184+ , "name" ==> E.text (Pkg.toText name)
185+ , "summary" ==> E.text summary
186+ , "license" ==> Licenses.encode license
187+ , "version" ==> E.text (Pkg.versionToText version)
188+ , "exposed-modules" ==> encodeExposed exposed
189+ , "elm-version" ==> encodeConstraint elm
190+ , "dependencies" ==> encodeDeps encodeConstraint deps
191+ , "test-dependencies" ==> encodeDeps encodeConstraint tests
192+ ]
193+
194+
195+(==>) :: a -> b -> (a, b)
196+(==>) a b =
197+ (a, b)
198+
199+
200+encodeExposed :: Exposed -> E.Value
201+encodeExposed exposed =
202+ case exposed of
203+ ExposedList modules ->
204+ E.list encodeModule modules
205+
206+ ExposedDict chunks ->
207+ E.object (map (fmap (E.list encodeModule)) chunks)
208+
209+
210+encodeModule :: Module.Raw -> E.Value
211+encodeModule name =
212+ E.name name
213+
214+
215+encodeDeps :: (a -> E.Value) -> Map Pkg.Name a -> E.Value
216+encodeDeps encodeValue deps =
217+ E.dict Pkg.toText encodeValue deps
218+
219+
220+encodeConstraint :: Con.Constraint -> E.Value
221+encodeConstraint constraint =
222+ E.text (Con.toText constraint)
223+
224+
225+encodeVersion :: Pkg.Version -> E.Value
226+encodeVersion version =
227+ E.text (Pkg.versionToText version)
228+
229+
230+
231+-- PARSE AND VERIFY
232+
233+
234+read :: FilePath -> Task.Task Project
235+read path =
236+ do bytes <- liftIO $ BS.readFile path
237+ case D.parse "project" E.badContentToDocs decoder bytes of
238+ Left err ->
239+ throwBadJson (E.BadJson err)
240+
241+ Right project@(Pkg (PkgInfo _ _ _ _ _ deps tests _)) ->
242+ do checkOverlap "dependencies" "test-dependencies" deps tests
243+ return project
244+
245+ Right project@(App (AppInfo _ srcDirs deps tests trans)) ->
246+ do checkOverlap "dependencies" "test-dependencies" deps tests
247+ checkOverlap "dependencies" "transitive-dependencies" deps trans
248+ checkOverlap "test-dependencies" "transitive-dependencies" tests trans
249+ mapM_ doesDirectoryExist srcDirs
250+ return project
251+
252+
253+throwBadJson :: E.ElmJsonProblem -> Task.Task a
254+throwBadJson problem =
255+ Task.throw (Exit.Assets (E.BadElmJson problem))
256+
257+
258+checkOverlap :: String -> String -> Map Name a -> Map Name a -> Task.Task ()
259+checkOverlap field1 field2 deps1 deps2 =
260+ case Map.keys (Map.intersection deps1 deps2) of
261+ [] ->
262+ return ()
263+
264+ dup : dups ->
265+ throwBadJson (E.BadDepDup field1 field2 dup dups)
266+
267+
268+doesDirectoryExist :: FilePath -> Task.Task ()
269+doesDirectoryExist dir =
270+ do exists <- liftIO $ Dir.doesDirectoryExist dir
271+ if exists
272+ then return ()
273+ else throwBadJson (E.BadSrcDir dir)
274+
275+
276+
277+-- JSON DECODE
278+
279+
280+type Decoder a =
281+ D.Decoder E.BadElmJsonContent a
282+
283+
284+decoder :: Decoder Project
285+decoder =
286+ do tipe <- D.field "type" D.text
287+ case tipe of
288+ "application" ->
289+ D.map App appDecoder
290+
291+ "package" ->
292+ D.map Pkg pkgDecoder
293+
294+ other ->
295+ D.fail (E.BadType other)
296+
297+
298+appDecoder :: Decoder AppInfo
299+appDecoder =
300+ AppInfo
301+ <$> D.field "elm-version" versionDecoder
302+ <*> D.field "source-directories" (D.list dirDecoder)
303+ <*> D.field "dependencies" (depsDecoder versionDecoder)
304+ <*> D.field "test-dependencies" (depsDecoder versionDecoder)
305+ <*> D.at ["do-not-edit-this-by-hand", "transitive-dependencies"] (depsDecoder versionDecoder)
306+
307+
308+pkgDecoder :: Decoder PkgInfo
309+pkgDecoder =
310+ PkgInfo
311+ <$> D.field "name" pkgNameDecoder
312+ <*> D.field "summary" summaryDecoder
313+ <*> D.field "license" licenseDecoder
314+ <*> D.field "version" versionDecoder
315+ <*> D.field "exposed-modules" exposedDecoder
316+ <*> D.field "dependencies" (depsDecoder constraintDecoder)
317+ <*> D.field "test-dependencies" (depsDecoder constraintDecoder)
318+ <*> D.field "elm-version" constraintDecoder
319+
320+
321+
322+-- JSON DECODE HELPERS
323+
324+
325+pkgNameDecoder :: Decoder Pkg.Name
326+pkgNameDecoder =
327+ D.mapError E.BadPkgName Pkg.decoder
328+
329+
330+summaryDecoder :: Decoder Text
331+summaryDecoder =
332+ do summary <- D.text
333+ if Text.length summary < 80
334+ then D.succeed summary
335+ else D.fail E.BadSummaryTooLong
336+
337+
338+licenseDecoder :: Decoder Licenses.License
339+licenseDecoder =
340+ do txt <- D.text
341+ case Licenses.check txt of
342+ Left suggestions ->
343+ D.fail (E.BadLicense txt suggestions)
344+
345+ Right license ->
346+ D.succeed license
347+
348+
349+versionDecoder :: Decoder Version
350+versionDecoder =
351+ do txt <- D.text
352+ case Pkg.versionFromText txt of
353+ Just version ->
354+ D.succeed version
355+
356+ Nothing ->
357+ D.fail (E.BadVersion txt)
358+
359+
360+constraintDecoder :: Decoder Con.Constraint
361+constraintDecoder =
362+ do txt <- D.text
363+ case Con.fromText txt of
364+ Right constraint ->
365+ D.succeed constraint
366+
367+ Left msg ->
368+ D.fail (E.BadConstraint msg)
369+
370+
371+depsDecoder :: Decoder a -> Decoder (Map Name a)
372+depsDecoder valueDecoder =
373+ Map.fromList <$> (
374+ traverse validateKey =<< D.pairs valueDecoder
375+ )
376+
377+
378+validateKey :: (Text, a) -> Decoder (Name, a)
379+validateKey (key, value) =
380+ case Pkg.fromText key of
381+ Right name ->
382+ D.succeed (name, value)
383+
384+ Left _ ->
385+ D.fail (E.BadDependencyName key)
386+
387+
388+dirDecoder :: Decoder FilePath
389+dirDecoder =
390+ do maybeText <- D.maybe D.text
391+ case maybeText of
392+ Nothing ->
393+ D.fail E.BadDirectoryNotString
394+
395+ Just txt ->
396+ D.succeed (Text.unpack txt)
397+
398+
399+
400+-- EXPOSED MODULES DECODER
401+
402+
403+exposedDecoder :: Decoder Exposed
404+exposedDecoder =
405+ D.oneOf
406+ [ ExposedList <$> D.list moduleDecoder
407+ , do pairs <- D.pairs (D.list moduleDecoder)
408+ traverse_ (checkHeader . fst) pairs
409+ return (ExposedDict pairs)
410+ ]
411+
412+
413+moduleDecoder :: Decoder Module.Raw
414+moduleDecoder =
415+ D.mapError E.BadModuleName Module.decoder
416+
417+
418+checkHeader :: Text -> Decoder ()
419+checkHeader header =
420+ if Text.length header < 20 then
421+ D.succeed ()
422+ else
423+ D.fail (E.BadModuleHeaderTooLong header)
compiler/src/Elm/Licenses.hs → builder/src/Elm/Project/Licenses.hsrenamed+59−65
@@ -1,20 +1,19 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Licenses
3+module Elm.Project.Licenses
44 ( License
5+ , check
56 , bsd3
67 , encode
7− , decoder
88 )
99 where
1010
1111
12+import Data.Map ((!))
1213import qualified Data.Map as Map
13−import qualified Data.Utf8 as Utf8
14+import qualified Data.Text as Text
1415
15−import qualified Json.Decode as D
16−import qualified Json.Encode as E
17−import qualified Json.String as Json
16+import qualified Json.Encode as Encode
1817import qualified Reporting.Suggest as Suggest
1918
2019
@@ -22,122 +21,119 @@ import qualified Reporting.Suggest as Suggest
2221-- LICENCES
2322
2423
25−newtype License =
26− License Json.String
24+data License =
25+ License
26+ { _name :: Text.Text
27+ , _code :: Text.Text
28+ }
29+ deriving (Eq, Ord)
2730
2831
2932bsd3 :: License
3033bsd3 =
31− License (Json.fromChars "BSD-3-Clause")
34+ osiApprovedSpdxLicenses ! "BSD-3-Clause"
3235
3336
34−encode :: License -> E.Value
35−encode (License code) =
36− E.string code
37−
38−
39−decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License
40−decoder toError =
41− do str <- D.string
42− case check str of
43− Right license ->
44− return license
45−
46− Left suggestions ->
47− D.failure (toError str suggestions)
37+encode :: License -> Encode.Value
38+encode (License _ code) =
39+ Encode.text code
4840
4941
5042
5143-- CHECK
5244
5345
54−check :: Json.String -> Either [Json.String] License
55−check givenCode =
56− if Map.member givenCode osiApprovedSpdxLicenses then
57− Right (License givenCode)
46+check :: Text.Text -> Either [Text.Text] License
47+check rawName =
48+ case Map.lookup rawName osiApprovedSpdxLicenses of
49+ Just license ->
50+ Right license
51+
52+ Nothing ->
53+ let
54+ toPairs (License name code) =
55+ [ (Text.unpack code, code), (Text.unpack name, code) ]
5856
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
57+ pairs =
58+ concatMap toPairs (Map.elems osiApprovedSpdxLicenses)
59+ in
60+ Left $ map snd $
61+ Suggest.sort (Text.unpack rawName) fst pairs
6862
6963
7064
7165-- LIST OF LICENCES
7266
7367
74−(==>) :: [Char] -> [Char] -> (Json.String, [Char])
75−(==>) code fullName =
76− ( Json.fromChars code, fullName )
68+(==>) :: Text.Text -> Text.Text -> (Text.Text, License)
69+(==>) code name =
70+ ( code, License name code )
7771
7872
7973--
8074-- OSI approved licenses in SPDX format.
8175-- <https://spdx.org/licenses/>
8276--
83−osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
77+osiApprovedSpdxLicenses :: Map.Map Text.Text License
8478osiApprovedSpdxLicenses =
8579 Map.fromList
86− [ "0BSD" ==> "BSD Zero Clause License"
87− , "AAL" ==> "Attribution Assurance License"
88− , "AFL-1.1" ==> "Academic Free License v1.1"
80+ [ "AFL-1.1" ==> "Academic Free License v1.1"
8981 , "AFL-1.2" ==> "Academic Free License v1.2"
9082 , "AFL-2.0" ==> "Academic Free License v2.0"
9183 , "AFL-2.1" ==> "Academic Free License v2.1"
9284 , "AFL-3.0" ==> "Academic Free License v3.0"
93− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
85+ , "APL-1.0" ==> "Adaptive Public License 1.0"
9486 , "Apache-1.1" ==> "Apache License 1.1"
9587 , "Apache-2.0" ==> "Apache License 2.0"
96− , "APL-1.0" ==> "Adaptive Public License 1.0"
9788 , "APSL-1.0" ==> "Apple Public Source License 1.0"
9889 , "APSL-1.1" ==> "Apple Public Source License 1.1"
9990 , "APSL-1.2" ==> "Apple Public Source License 1.2"
10091 , "APSL-2.0" ==> "Apple Public Source License 2.0"
10192 , "Artistic-1.0" ==> "Artistic License 1.0"
102− , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
10393 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
94+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
10495 , "Artistic-2.0" ==> "Artistic License 2.0"
96+ , "AAL" ==> "Attribution Assurance License"
97+ , "BSL-1.0" ==> "Boost Software License 1.0"
10598 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
10699 , "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"
100+ , "0BSD" ==> "BSD Zero Clause License"
110101 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
111102 , "CNRI-Python" ==> "CNRI Python License"
103+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
112104 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
113105 , "CPL-1.0" ==> "Common Public License 1.0"
106+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
114107 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
108+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
115109 , "ECL-1.0" ==> "Educational Community License v1.0"
116110 , "ECL-2.0" ==> "Educational Community License v2.0"
117111 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
118112 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
119113 , "Entessa" ==> "Entessa Public License v1.0"
120− , "EPL-1.0" ==> "Eclipse Public License 1.0"
121114 , "EUDatagrid" ==> "EU DataGrid Software License"
122115 , "EUPL-1.1" ==> "European Union Public License 1.1"
123116 , "Fair" ==> "Fair License"
124117 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
118+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
125119 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
126120 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
121+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
122+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
123+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
127124 , "HPND" ==> "Historic Permission Notice and Disclaimer"
125+ , "IPL-1.0" ==> "IBM Public License v1.0"
128126 , "Intel" ==> "Intel Open Source License"
129127 , "IPA" ==> "IPA Font License"
130− , "IPL-1.0" ==> "IBM Public License v1.0"
131128 , "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"
129+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
135130 , "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"
137131 , "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"
132+ , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
139133 , "LPL-1.02" ==> "Lucent Public License v1.02"
140− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
134+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"
135+ , "MS-PL" ==> "Microsoft Public License"
136+ , "MS-RL" ==> "Microsoft Reciprocal License"
141137 , "MirOS" ==> "MirOS Licence"
142138 , "MIT" ==> "MIT License"
143139 , "Motosoto" ==> "Motosoto License"
@@ -145,40 +141,38 @@ osiApprovedSpdxLicenses =
145141 , "MPL-1.1" ==> "Mozilla Public License 1.1"
146142 , "MPL-2.0" ==> "Mozilla Public License 2.0"
147143 , "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"
150144 , "Multics" ==> "Multics License"
151145 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
152146 , "Naumen" ==> "Naumen Public License"
153− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
154147 , "NGPL" ==> "Nethack General Public License"
155148 , "Nokia" ==> "Nokia Open Source License"
156149 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
157150 , "NTP" ==> "NTP License"
158151 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159− , "OFL-1.1" ==> "SIL Open Font License 1.1"
160152 , "OGTSL" ==> "Open Group Test Suite License"
161− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
162153 , "OSL-1.0" ==> "Open Software License 1.0"
163154 , "OSL-2.0" ==> "Open Software License 2.0"
164155 , "OSL-2.1" ==> "Open Software License 2.1"
165156 , "OSL-3.0" ==> "Open Software License 3.0"
157+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
166158 , "PHP-3.0" ==> "PHP License v3.0"
167159 , "PostgreSQL" ==> "PostgreSQL License"
168160 , "Python-2.0" ==> "Python License 2.0"
169161 , "QPL-1.0" ==> "Q Public License 1.0"
162+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
170163 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
171164 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
173165 , "RSCPL" ==> "Ricoh Source Code Public License"
166+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
174167 , "SimPL-2.0" ==> "Simple Public License 2.0"
175− , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176168 , "Sleepycat" ==> "Sleepycat License"
169+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"
177170 , "SPL-1.0" ==> "Sun Public License v1.0"
171+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
178172 , "UPL-1.0" ==> "Universal Permissive License v1.0"
173+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
179174 , "VSL-1.0" ==> "Vovida Software License v1.0"
180175 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
182176 , "Xnet" ==> "X.Net License"
183177 , "Zlib" ==> "zlib License"
184178 , "ZPL-2.0" ==> "Zope Public License 2.0"
builder/src/Elm/Project/Root.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Project.Root
3+ ( get
4+ , unsafeGet
5+ , getWithReplFallback
6+ )
7+ where
8+
9+import Control.Monad.Trans (liftIO)
10+import qualified Data.Map as Map
11+import qualified System.Directory as Dir
12+import System.FilePath ((</>))
13+
14+import qualified Elm.Package as Pkg
15+import qualified Elm.Project.Constraint as Con
16+import qualified Elm.Project.Json as Project
17+import qualified Elm.Project.Licenses as Licenses
18+import Elm.Project.Json (Project(..), PkgInfo(..))
19+import Elm.Project.Summary (Summary)
20+import qualified Elm.PerUserCache as PerUserCache
21+import qualified File.IO as IO
22+import qualified Reporting.Exit as Exit
23+import qualified Reporting.Task as Task
24+import qualified Stuff.Verify as Verify
25+import qualified Json.Encode as Encode
26+
27+
28+
29+-- GET
30+
31+
32+get :: Task.Task Summary
33+get =
34+ do root <- moveToRoot
35+ project <- Project.read "elm.json"
36+ Verify.verify root project
37+
38+
39+unsafeGet :: Task.Task (FilePath, Project)
40+unsafeGet =
41+ (,) <$> moveToRoot <*> Project.read "elm.json"
42+
43+
44+
45+-- MOVE TO ROOT
46+
47+
48+moveToRoot :: Task.Task FilePath
49+moveToRoot =
50+ do maybeRoot <- liftIO $ IO.find "elm.json"
51+ case maybeRoot of
52+ Just root ->
53+ do liftIO $ Dir.setCurrentDirectory root
54+ return root
55+
56+ Nothing ->
57+ Task.throw Exit.NoElmJson
58+
59+
60+
61+-- GET WITH FALLBACK
62+
63+
64+getWithReplFallback :: IO FilePath
65+getWithReplFallback =
66+ do maybeRoot <- IO.find "elm.json"
67+
68+ case maybeRoot of
69+ Just root ->
70+ do Dir.setCurrentDirectory root
71+ return root
72+
73+ Nothing ->
74+ do cache <- PerUserCache.getReplRoot
75+ let root = cache </> "tmp"
76+ Dir.createDirectoryIfMissing True root
77+ Dir.setCurrentDirectory root
78+ IO.removeDir "elm-stuff"
79+ Encode.write "elm.json" (Project.encode (Pkg replInfo))
80+ return root
81+
82+
83+replInfo :: PkgInfo
84+replInfo =
85+ PkgInfo
86+ { _pkg_name = Pkg.dummyName
87+ , _pkg_summary = "dummy code for the REPL"
88+ , _pkg_license = Licenses.bsd3
89+ , _pkg_version = Pkg.dummyVersion
90+ , _pkg_exposed = Project.ExposedList []
91+ , _pkg_deps = Map.singleton Pkg.core Con.anything
92+ , _pkg_test_deps = Map.empty
93+ , _pkg_elm_version = Con.defaultElm
94+ }
builder/src/Elm/Project/Summary.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Elm.Project.Summary
3+ ( Summary(..)
4+ , ExposedModules
5+ , DepsGraph
6+ , init
7+ , cheapInit
8+ )
9+ where
10+
11+
12+import Prelude hiding (init)
13+import qualified Data.List as List
14+import qualified Data.Map as Map
15+import Data.Map (Map)
16+
17+import qualified Elm.Compiler.Module as Module
18+import Elm.Package (Package(..), Name, Version)
19+import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..))
20+import qualified Elm.Project.Json as Project
21+
22+
23+
24+-- SUMMARY
25+
26+
27+data Summary =
28+ Summary
29+ { _root :: FilePath
30+ , _project :: Project
31+ , _exposed :: ExposedModules
32+ , _ifaces :: Module.Interfaces
33+ , _depsGraph :: DepsGraph
34+ }
35+
36+
37+type ExposedModules =
38+ Map.Map Module.Raw [Package]
39+
40+
41+type DepsGraph =
42+ Map.Map Name ( Version, [Name] )
43+
44+
45+
46+-- MAKE SUMMARY
47+
48+
49+init :: FilePath -> Project -> Map Name PkgInfo -> Module.Interfaces -> Summary
50+init root project deps ifaces =
51+ let
52+ exposed =
53+ Project.get
54+ (getExposed deps . _app_deps)
55+ (getExposed deps . _pkg_deps)
56+ project
57+
58+ privatizedInterfaces =
59+ Map.mapMaybeWithKey (privatize exposed) ifaces
60+
61+ depsGraph =
62+ Map.foldr toNode Map.empty deps
63+ in
64+ Summary root project exposed privatizedInterfaces depsGraph
65+
66+
67+privatize :: ExposedModules -> Module.Canonical -> Module.Interface -> Maybe Module.Interface
68+privatize exposed (Module.Canonical _ name) iface =
69+ case Map.lookup name exposed of
70+ Just [_] ->
71+ Just iface
72+
73+ _ ->
74+ Nothing
75+
76+
77+toNode :: PkgInfo -> DepsGraph -> DepsGraph
78+toNode (PkgInfo name _ _ version _ deps _ _) graph =
79+ Map.insert name (version, Map.keys deps) graph
80+
81+
82+
83+-- MAKE CHEAP SUMMARY
84+
85+
86+cheapInit :: FilePath -> PkgInfo -> Map Name PkgInfo -> Module.Interfaces -> Summary
87+cheapInit root info deps ifaces =
88+ Summary root (Pkg info) (getExposed deps (_pkg_deps info)) ifaces Map.empty
89+
90+
91+getExposed :: Map Name PkgInfo -> Map Name a -> ExposedModules
92+getExposed deps directs =
93+ Map.foldl insertExposed Map.empty (Map.intersection deps directs)
94+
95+
96+insertExposed :: ExposedModules -> PkgInfo -> ExposedModules
97+insertExposed exposed info =
98+ let
99+ home =
100+ Package (_pkg_name info) (_pkg_version info)
101+
102+ insertModule dict modul =
103+ Map.insertWith (++) modul [home] dict
104+ in
105+ List.foldl' insertModule exposed (Project.getExposed info)
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.Text as Text
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.Diff as Diff
17+import qualified Deps.Get as Get
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 as Project
23+import qualified Elm.Project.Json as Project
24+import qualified Elm.Project.Summary as Summary
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+ pkgs <- Get.all Get.RequireLatest
45+ let maybePublishedVersions = either (const Nothing) Just (Get.versions name pkgs)
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 (Project.generateDocs 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 :: Text.Text -> Bool
75+badSummary summary =
76+ Text.null 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 -> Pkg.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 -> Pkg.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 -> Pkg.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 $ 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 -> Pkg.Version -> Docs.Documentation -> Maybe [Pkg.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 == Pkg.initialVersion 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 -> Pkg.Version -> Docs.Documentation -> [Pkg.Version] -> Task.Task (Pkg.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 <- Get.docs 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.hsdeleted−231
@@ -1,231 +0,0 @@
1−module File
2− ( Time
3− , getTime
4− , zeroTime
5− , writeBinary
6− , readBinary
7− , writeUtf8
8− , readUtf8
9− , writeBuilder
10− , writePackage
11− , exists
12− , remove
13− , removeDir
14− )
15− where
16−
17−
18−import qualified Codec.Archive.Zip as Zip
19−import Control.Exception (catch)
20−import qualified Data.Binary as Binary
21−import qualified Data.ByteString as BS
22−import qualified Data.ByteString.Internal as BS
23−import qualified Data.ByteString.Builder as B
24−import qualified Data.ByteString.Lazy as LBS
25−import qualified Data.Fixed as Fixed
26−import qualified Data.List as List
27−import qualified Data.Time.Clock as Time
28−import qualified Data.Time.Clock.POSIX as Time
29−import qualified Foreign.ForeignPtr as FPtr
30−import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
31−import qualified System.Directory as Dir
32−import qualified System.FilePath as FP
33−import System.FilePath ((</>))
34−import qualified System.IO as IO
35−import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
36−
37−
38−
39−-- TIME
40−
41−
42−newtype Time = Time Fixed.Pico
43− deriving (Eq, Ord)
44−
45−
46−getTime :: FilePath -> IO Time
47−getTime path =
48− fmap
49− (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
50− (Dir.getModificationTime path)
51−
52−
53−zeroTime :: Time
54−zeroTime =
55− Time 0
56−
57−
58−instance Binary.Binary Time where
59− put (Time time) = Binary.put time
60− get = Time <$> Binary.get
61−
62−
63−
64−-- BINARY
65−
66−
67−writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
68−writeBinary path value =
69− do let dir = FP.dropFileName path
70− Dir.createDirectoryIfMissing True dir
71− Binary.encodeFile path value
72−
73−
74−readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
75−readBinary path =
76− do pathExists <- Dir.doesFileExist path
77− if pathExists
78− then
79− do result <- Binary.decodeFileOrFail path
80− 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
96− else
97− return Nothing
98−
99−
100−
101−-- WRITE UTF-8
102−
103−
104−writeUtf8 :: FilePath -> BS.ByteString -> IO ()
105−writeUtf8 path content =
106− withUtf8 path IO.WriteMode $ \handle ->
107− BS.hPut handle content
108−
109−
110−withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
111−withUtf8 path mode callback =
112− IO.withFile path mode $ \handle ->
113− do IO.hSetEncoding handle IO.utf8
114− callback handle
115−
116−
117−
118−-- READ UTF-8
119−
120−
121−readUtf8 :: FilePath -> IO BS.ByteString
122−readUtf8 path =
123− withUtf8 path IO.ReadMode $ \handle ->
124− modifyIOError (encodingError path) $
125− do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
126− let readSize = max 0 (fromIntegral fileSize) + 1
127− hGetContentsSizeHint handle readSize (max 255 readSize)
128−
129−
130−useZeroIfNotRegularFile :: IOException -> IO Integer
131−useZeroIfNotRegularFile _ =
132− return 0
133−
134−
135−hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
136−hGetContentsSizeHint handle =
137− readChunks []
138− where
139− readChunks chunks readSize incrementSize =
140− do fp <- BS.mallocByteString readSize
141− readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
142− let chunk = BS.PS fp 0 readCount
143− if readCount < readSize && readSize > 0
144− then return $! BS.concat (reverse (chunk:chunks))
145− else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
146−
147−
148−encodingError :: FilePath -> IOError -> IOError
149−encodingError path ioErr =
150− case ioeGetErrorType ioErr of
151− InvalidArgument ->
152− annotateIOError
153− (userError "Bad encoding; the file must be valid UTF-8")
154− ""
155− Nothing
156− (Just path)
157−
158− _ ->
159− ioErr
160−
161−
162−
163−-- WRITE BUILDER
164−
165−
166−writeBuilder :: FilePath -> B.Builder -> IO ()
167−writeBuilder path builder =
168− IO.withBinaryFile path IO.WriteMode $ \handle ->
169− do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
170− B.hPutBuilder handle builder
171−
172−
173−
174−-- WRITE PACKAGE
175−
176−
177−writePackage :: FilePath -> Zip.Archive -> IO ()
178−writePackage destination archive =
179− case Zip.zEntries archive of
180− [] ->
181− return ()
182−
183− entry:entries ->
184− do let root = length (Zip.eRelativePath entry)
185− mapM_ (writeEntry destination root) entries
186−
187−
188−writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
189−writeEntry destination root entry =
190− let
191− path = drop root (Zip.eRelativePath entry)
192− in
193− if List.isPrefixOf "src/" path
194− || path == "LICENSE"
195− || path == "README.md"
196− || path == "elm.json"
197− then
198− if not (null path) && last path == '/'
199− then Dir.createDirectoryIfMissing True (destination </> path)
200− else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
201− else
202− return ()
203−
204−
205−
206−-- EXISTS
207−
208−
209−exists :: FilePath -> IO Bool
210−exists path =
211− Dir.doesFileExist path
212−
213−
214−
215−-- REMOVE FILES
216−
217−
218−remove :: FilePath -> IO ()
219−remove path =
220− do exists_ <- Dir.doesFileExist path
221− if exists_
222− then Dir.removeFile path
223− else return ()
224−
225−
226−removeDir :: FilePath -> IO ()
227−removeDir path =
228− do exists_ <- Dir.doesDirectoryExist path
229− if exists_
230− then Dir.removeDirectoryRecursive path
231− else return ()
builder/src/File/Args.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module File.Args
3+ ( Args(..)
4+ , fromPaths
5+ , fromSummary
6+ )
7+ where
8+
9+
10+import qualified Elm.Compiler.Module as Module
11+import qualified Elm.Project.Json as Project
12+import qualified Elm.Project.Summary as Summary
13+import qualified Reporting.Exit as Exit
14+import qualified Reporting.Exit.Make as E
15+import qualified Reporting.Task as Task
16+
17+
18+data Args root
19+ = Pkg [Module.Raw]
20+ | Roots root [root]
21+
22+
23+fromPaths :: Summary.Summary -> [FilePath] -> Task.Task (Args FilePath)
24+fromPaths summary paths =
25+ case paths of
26+ [] ->
27+ fromSummary summary
28+
29+ first : rest ->
30+ return $ Roots first rest
31+
32+
33+fromSummary :: Summary.Summary -> Task.Task (Args a)
34+fromSummary (Summary.Summary _ project _ _ _) =
35+ case project of
36+ Project.Pkg info ->
37+ return $ Pkg (Project.getExposed info)
38+
39+ Project.App _ ->
40+ Task.throw (Exit.Make E.CannotMakeNothing)
builder/src/File/Artifacts.hsnew file+138
@@ -0,0 +1,138 @@
1+module File.Artifacts
2+ ( ignore
3+ , write
4+ , writeDocs
5+ )
6+ where
7+
8+
9+import Control.Concurrent (forkIO)
10+import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
11+import Control.Monad (foldM, void)
12+import Control.Monad.Except (liftIO)
13+import qualified Data.Binary as Binary
14+import Data.Map (Map)
15+import qualified Data.Map as Map
16+import qualified Data.Maybe as Maybe
17+import qualified Data.Text.Encoding as Text
18+
19+import qualified Elm.Compiler as Compiler
20+import qualified Elm.Compiler.Module as Module
21+import qualified Elm.Docs as Docs
22+import qualified Json.Encode as Encode
23+
24+import File.Compile (Answer(..))
25+import qualified Reporting.Exit.Compile as E
26+import qualified Reporting.Exit as Exit
27+import qualified Reporting.Task as Task
28+import qualified Stuff.Paths as Path
29+
30+
31+
32+-- IGNORE
33+
34+
35+ignore :: Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts)
36+ignore answers =
37+ let
38+ ignorer _name result =
39+ return result
40+ in
41+ gather ignorer answers
42+
43+
44+
45+-- WRITE
46+
47+
48+write :: FilePath -> Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts)
49+write root answers =
50+ let
51+ writer name result@(Compiler.Artifacts elmi elmo _) =
52+ do mvar <- newEmptyMVar
53+ void $ forkIO $
54+ do Binary.encodeFile (Path.elmi root name) elmi
55+ Binary.encodeFile (Path.elmo root name) elmo
56+ putMVar mvar result
57+ return mvar
58+ in
59+ do mvars <- gather writer answers
60+ liftIO $ traverse readMVar mvars
61+
62+
63+writeDocs :: Map Module.Raw Compiler.Artifacts -> FilePath -> Task.Task Docs.Documentation
64+writeDocs results path =
65+ let
66+ getDocs (Compiler.Artifacts _ _ docs) =
67+ docs
68+ in
69+ case Maybe.mapMaybe getDocs (Map.elems results) of
70+ [] ->
71+ return Map.empty
72+
73+ docs ->
74+ do liftIO $ Encode.writeUgly path $ Encode.list Docs.encode docs
75+ return $ Docs.toDict docs
76+
77+
78+
79+-- GATHER
80+
81+
82+gather :: OnGood a -> Map Module.Raw Answer -> Task.Task (Map Module.Raw a)
83+gather onGood answers =
84+ do summary <- liftIO $
85+ foldM (gatherHelp onGood) (Right Map.empty) (Map.toList answers)
86+
87+ case summary of
88+ Left (err, errors) ->
89+ Task.throw (Exit.Compile err errors)
90+
91+ Right results ->
92+ return results
93+
94+
95+type OnGood a = Module.Raw -> Compiler.Artifacts -> IO a
96+
97+
98+gatherHelp :: OnGood a -> Summary a -> (Module.Raw, Answer) -> IO (Summary a)
99+gatherHelp onGood summary (name, answer) =
100+ case answer of
101+ Blocked ->
102+ return summary
103+
104+ Bad path time src errors ->
105+ do let err = E.Exit name path time (Text.decodeUtf8 src) errors
106+ return (addErr err summary)
107+
108+ Good result ->
109+ do value <- onGood name result
110+ return (addOk name value summary)
111+
112+
113+
114+-- DICT RESULT
115+
116+
117+type Summary a =
118+ Either (E.Exit, [E.Exit]) (Map Module.Raw a)
119+
120+
121+addOk :: Module.Raw -> a -> Summary a -> Summary a
122+addOk name result acc =
123+ case acc of
124+ Left _ ->
125+ acc
126+
127+ Right results ->
128+ Right (Map.insert name result results)
129+
130+
131+addErr :: E.Exit -> Summary a -> Summary a
132+addErr err acc =
133+ case acc of
134+ Left (e, es) ->
135+ Left (err, e:es)
136+
137+ Right _ ->
138+ Left (err, [])
builder/src/File/Compile.hsnew file+192
@@ -0,0 +1,192 @@
1+module File.Compile
2+ ( compile
3+ , Answer(..)
4+ )
5+ where
6+
7+import Control.Concurrent (forkIO)
8+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
9+import Control.Monad (void)
10+import Control.Monad.Except (liftIO)
11+import qualified Data.ByteString as BS
12+import qualified Data.Map as Map
13+import qualified Data.Time.Clock as Time
14+
15+import qualified Elm.Compiler as Compiler
16+import qualified Elm.Compiler.Module as Module
17+
18+import Elm.Project.Json (Project)
19+import qualified Elm.Project.Json as Project
20+import qualified File.Plan as Plan
21+import qualified Reporting.Progress as Progress
22+import qualified Reporting.Task as Task
23+
24+
25+
26+-- COMPILE
27+
28+
29+compile :: Project -> Maybe FilePath -> Module.Interfaces -> Dict Plan.Info -> Task.Task (Dict Answer)
30+compile project maybeDocsPath ifaces modules =
31+ do Task.report (Progress.CompileStart (Map.size modules))
32+
33+ tell <- Task.getReporter
34+
35+ answers <- liftIO $
36+ do mvar <- newEmptyMVar
37+ iMVar <- newMVar ifaces
38+ answerMVars <- Map.traverseWithKey (compileModule tell project maybeDocsPath mvar iMVar) modules
39+ putMVar mvar answerMVars
40+ traverse readMVar answerMVars
41+
42+ Task.report Progress.CompileEnd
43+
44+ return answers
45+
46+
47+
48+-- ANSWERS
49+
50+
51+data Answer
52+ = Blocked
53+ | Bad FilePath Time.UTCTime BS.ByteString [Compiler.Error]
54+ | Good Compiler.Artifacts
55+
56+
57+type Dict a = Map.Map Module.Raw a
58+
59+
60+
61+-- COMPILE MODULE
62+
63+
64+compileModule
65+ :: (Progress.Progress -> IO ())
66+ -> Project
67+ -> Maybe FilePath
68+ -> MVar (Dict (MVar Answer))
69+ -> MVar Module.Interfaces
70+ -> Module.Raw
71+ -> Plan.Info
72+ -> IO (MVar Answer)
73+compileModule tell project maybeDocsPath answersMVar ifacesMVar name info =
74+ do mvar <- newEmptyMVar
75+
76+ void $ forkIO $
77+ do answers <- readMVar answersMVar
78+ blocked <- isBlocked answers info
79+ if blocked
80+ then putMVar mvar Blocked
81+ else
82+ do tell (Progress.CompileFileStart name)
83+ let pkg = Project.getName project
84+ let docs = toDocsFlag name project maybeDocsPath
85+ let imports = makeImports project info
86+ ifaces <- readMVar ifacesMVar
87+ let context = Compiler.Context pkg docs imports ifaces
88+ let source = Plan._src info
89+ case Compiler.compile context source of
90+ (_warnings, Left errors) ->
91+ do tell (Progress.CompileFileEnd name Progress.Bad)
92+ let path = Plan._path info
93+ let time = Plan._time info
94+ putMVar mvar (Bad path time source errors)
95+
96+ (_warnings, Right result@(Compiler.Artifacts elmi _ _)) ->
97+ do tell (Progress.CompileFileEnd name Progress.Good)
98+ let canonicalName = Module.Canonical pkg name
99+ lock <- takeMVar ifacesMVar
100+ putMVar ifacesMVar (Map.insert canonicalName elmi lock)
101+ putMVar mvar (Good result)
102+
103+ return mvar
104+
105+
106+
107+-- TO DOCS FLAG
108+
109+
110+toDocsFlag :: Module.Raw -> Project -> Maybe FilePath -> Compiler.DocsFlag
111+toDocsFlag name project maybeDocsPath =
112+ case maybeDocsPath of
113+ Nothing ->
114+ Compiler.NoDocs
115+
116+ Just _ ->
117+ case project of
118+ Project.App _ ->
119+ Compiler.NoDocs
120+
121+ Project.Pkg info ->
122+ if isExposed name (Project._pkg_exposed info) then
123+ Compiler.YesDocs
124+ else
125+ Compiler.NoDocs
126+
127+
128+isExposed :: Module.Raw -> Project.Exposed -> Bool
129+isExposed name exposed =
130+ case exposed of
131+ Project.ExposedList modules ->
132+ elem name modules
133+
134+ Project.ExposedDict chunks ->
135+ elem name (concatMap snd chunks)
136+
137+
138+
139+-- IMPORTS
140+
141+
142+makeImports :: Project -> Plan.Info -> Dict Module.Canonical
143+makeImports project (Plan.Info _ _ _ clean dirty foreign) =
144+ let
145+ pkgName =
146+ Project.getName project
147+
148+ mkLocal name =
149+ ( name, Module.Canonical pkgName name )
150+
151+ mkForeign canonicalName@(Module.Canonical _ name) =
152+ ( name, canonicalName )
153+ in
154+ Map.fromList $
155+ map mkLocal clean
156+ ++ map mkLocal dirty
157+ ++ map mkForeign foreign
158+
159+
160+
161+-- INTERFACES
162+
163+
164+isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool
165+isBlocked answers info =
166+ anyBlock <$> traverse (get answers) (Plan._dirty info)
167+
168+
169+get :: Dict (MVar Answer) -> Module.Raw -> IO Answer
170+get names name =
171+ case Map.lookup name names of
172+ Nothing ->
173+ error "bug manifesting in File.Complie.get, please report at <TODO>!"
174+
175+ Just mvar ->
176+ readMVar mvar
177+
178+
179+anyBlock :: [Answer] -> Bool
180+anyBlock answers =
181+ case answers of
182+ [] ->
183+ False
184+
185+ Blocked : _ ->
186+ True
187+
188+ Bad _ _ _ _ : _ ->
189+ True
190+
191+ Good _ : otherAnswers ->
192+ anyBlock otherAnswers
builder/src/File/Crawl.hsnew file+297
@@ -0,0 +1,297 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module File.Crawl
4+ ( Result
5+ , Graph(..)
6+ , crawl
7+ , crawlFromSource
8+ )
9+ where
10+
11+import Control.Concurrent.Chan (Chan, newChan, readChan)
12+import Control.Monad (foldM)
13+import Control.Monad.Except (liftIO)
14+import qualified Data.ByteString as BS
15+import qualified Data.Graph as Graph
16+import qualified Data.Map as Map
17+import qualified Data.Set as Set
18+
19+import qualified Elm.Compiler.Module as Module
20+import qualified Elm.Compiler.Objects as Obj
21+import qualified Elm.Kernel as Kernel
22+import qualified Elm.Package as Pkg
23+
24+import qualified Elm.Project.Json as Project
25+import Elm.Project.Summary (Summary(..))
26+import qualified File.Args as Args
27+import qualified File.Find as Find
28+import qualified File.Header as Header
29+import qualified File.IO as IO
30+import qualified Reporting.Exit as Exit
31+import qualified Reporting.Exit.Crawl as E
32+import qualified Reporting.Task as Task
33+
34+
35+
36+-- GRAPH
37+
38+
39+data Graph kernel problems =
40+ Graph
41+ { _args :: Args.Args Module.Raw
42+ , _locals :: Map.Map Module.Raw Header.Info
43+ , _kernels :: Map.Map Module.Raw kernel
44+ , _foreigns :: Map.Map Module.Raw Pkg.Package
45+ , _problems :: problems
46+ }
47+
48+
49+type Result =
50+ Graph Obj.Kernel ()
51+
52+
53+type WorkGraph =
54+ Graph (FilePath, Maybe FilePath) [E.Problem]
55+
56+
57+initWorkGraph :: Args.Args Module.Raw -> Map.Map Module.Raw Header.Info -> WorkGraph
58+initWorkGraph args locals =
59+ Graph args locals Map.empty Map.empty []
60+
61+
62+
63+-- CRAWL
64+
65+
66+crawl :: Summary -> Args.Args FilePath -> Task.Task Result
67+crawl summary args =
68+ case args of
69+ Args.Pkg names ->
70+ do let roots = map (Unvisited E.ElmJson) names
71+ let graph = initWorkGraph (Args.Pkg names) Map.empty
72+ depthFirstSearch summary roots graph
73+
74+ Args.Roots path [] ->
75+ crawlHelp summary =<< Header.readOneFile summary path
76+
77+ Args.Roots p ps ->
78+ do (h,hs) <- Header.readManyFiles summary p ps
79+ let unvisited = concatMap toUnvisited (h:hs)
80+ let graph = initWorkGraph (Args.Roots (fst h) (map fst hs)) (Map.fromList (h:hs))
81+ depthFirstSearch summary unvisited graph
82+ where
83+ toUnvisited (name, Header.Info path _ _ deps) =
84+ map (Unvisited (E.Module path name)) deps
85+
86+
87+crawlFromSource :: Summary -> BS.ByteString -> Task.Task Result
88+crawlFromSource summary@(Summary _ project _ _ _) source =
89+ crawlHelp summary =<<
90+ Header.readSource project source
91+
92+
93+crawlHelp :: Summary -> ( Maybe Module.Raw, Header.Info ) -> Task.Task Result
94+crawlHelp summary ( maybeName, info@(Header.Info path _ _ deps) ) =
95+ do let name = maybe "Main" id maybeName
96+ let toUnvisited dep = Unvisited (maybe (E.File path) (E.Module path) maybeName) dep
97+ let roots = map toUnvisited deps
98+ let graph = initWorkGraph (Args.Roots name []) (Map.singleton name info)
99+ depthFirstSearch summary roots graph
100+
101+
102+
103+-- DEPTH FIRST SEARCH
104+
105+
106+depthFirstSearch :: Summary -> [Unvisited] -> WorkGraph -> Task.Task Result
107+depthFirstSearch summary unvisited startGraph =
108+ do chan <- liftIO newChan
109+
110+ (Graph args locals kernelPaths foreigns problems) <-
111+ dfs summary chan 0 Set.empty unvisited startGraph
112+
113+ case problems of
114+ [] ->
115+ do checkForCycles locals
116+ kernels <- visitKernels summary locals kernelPaths
117+ return $ Graph args locals kernels foreigns ()
118+
119+ problem : otherProblems ->
120+ Task.throw (Exit.Crawl (E.DependencyProblems problem otherProblems))
121+
122+
123+
124+-- CHECK FOR CYCLES
125+
126+
127+checkForCycles :: Map.Map Module.Raw Header.Info -> Task.Task ()
128+checkForCycles locals =
129+ let
130+ toNode (name, Header.Info _ _ _ imports) =
131+ (name, name, imports)
132+
133+ components =
134+ Graph.stronglyConnComp (map toNode (Map.toList locals))
135+ in
136+ mapM_ checkComponent components
137+
138+
139+checkComponent :: Graph.SCC Module.Raw -> Task.Task ()
140+checkComponent scc =
141+ case scc of
142+ Graph.AcyclicSCC _ ->
143+ return ()
144+
145+ Graph.CyclicSCC names ->
146+ Task.throw (Exit.Cycle names)
147+
148+
149+
150+-- CONCURRENT DEPTH FIRST SEARCH
151+
152+
153+dfs
154+ :: Summary
155+ -> Chan (Either E.Problem Asset)
156+ -> Int
157+ -> Set.Set Module.Raw
158+ -> [Unvisited]
159+ -> WorkGraph
160+ -> Task.Task WorkGraph
161+dfs summary chan oldPending oldSeen unvisited graph =
162+ do (seen, pending) <-
163+ foldM (spawnVisitor summary chan) (oldSeen, oldPending) unvisited
164+
165+ if pending == 0
166+ then return graph
167+ else
168+ do asset <- liftIO $ readChan chan
169+ case asset of
170+ Right (Local name info@(Header.Info path _ _ imports)) ->
171+ do let newGraph = graph { _locals = Map.insert name info (_locals graph) }
172+ let deps = map (Unvisited (E.Module path name)) imports
173+ dfs summary chan (pending - 1) seen deps newGraph
174+
175+ Right (Kernel name info) ->
176+ do let kernels = Map.insert name info (_kernels graph)
177+ let newGraph = graph { _kernels = kernels }
178+ dfs summary chan (pending - 1) seen [] newGraph
179+
180+ Right (Foreign name pkg) ->
181+ do let foreigns = Map.insert name pkg (_foreigns graph)
182+ let newGraph = graph { _foreigns = foreigns }
183+ dfs summary chan (pending - 1) seen [] newGraph
184+
185+ Right ForeignKernel ->
186+ dfs summary chan (pending - 1) seen [] graph
187+
188+ Left problem ->
189+ do let problems = problem : _problems graph
190+ let newGraph = graph { _problems = problems }
191+ dfs summary chan (pending - 1) seen [] newGraph
192+
193+
194+spawnVisitor
195+ :: Summary
196+ -> Chan (Either E.Problem Asset)
197+ -> (Set.Set Module.Raw, Int)
198+ -> Unvisited
199+ -> Task.Task (Set.Set Module.Raw, Int)
200+spawnVisitor summary chan (seen, n) unvisited@(Unvisited _ name) =
201+ if Set.member name seen then
202+ return (seen, n)
203+ else
204+ do Task.workerChan chan (toVisitor summary unvisited)
205+ return (Set.insert name seen, n + 1)
206+
207+
208+
209+-- VISITOR
210+
211+
212+data Unvisited =
213+ Unvisited
214+ { _origin :: E.Origin
215+ , _name :: Module.Raw
216+ }
217+
218+
219+data Asset
220+ = Local Module.Raw Header.Info
221+ | Kernel Module.Raw (FilePath, Maybe FilePath)
222+ | Foreign Module.Raw Pkg.Package
223+ | ForeignKernel
224+
225+
226+toVisitor :: Summary -> Unvisited -> Task.Task_ E.Problem Asset
227+toVisitor summary (Unvisited origin name) =
228+ do asset <- Find.find summary origin name
229+ case asset of
230+ Find.Local path ->
231+ uncurry Local <$> Header.readModule summary name path
232+
233+ Find.Foreign pkg ->
234+ return $ Foreign name pkg
235+
236+ Find.Kernel clientPath maybeServerPath ->
237+ return $ Kernel name (clientPath, maybeServerPath)
238+
239+ Find.ForeignKernel ->
240+ return ForeignKernel
241+
242+
243+
244+-- VISIT KERNELS
245+
246+
247+visitKernels
248+ :: Summary
249+ -> Map.Map Module.Raw Header.Info
250+ -> Map.Map Module.Raw (FilePath, Maybe FilePath)
251+ -> Task.Task (Map.Map Module.Raw Obj.Kernel)
252+visitKernels summary locals kernelPaths =
253+ if Map.null kernelPaths then
254+ return Map.empty
255+ else
256+ -- TODO do this concurrently?
257+ -- Need better concurrency primitives in Task
258+ traverse (readKernel (toImportDict summary locals)) kernelPaths
259+
260+
261+readKernel :: ImportDict -> (FilePath, Maybe FilePath) -> Task.Task Obj.Kernel
262+readKernel importDict (clientPath, maybeServerPath) =
263+ Obj.Kernel
264+ <$> readKContent importDict clientPath
265+ <*> traverse (readKContent importDict) maybeServerPath
266+
267+
268+readKContent :: ImportDict -> FilePath -> Task.Task Kernel.KContent
269+readKContent importDict path =
270+ do source <- liftIO $ IO.readUtf8 path
271+ case Kernel.parse importDict source of
272+ Right content ->
273+ return content
274+
275+ Left _ ->
276+ Task.throw (Exit.Crawl (E.BadKernelHeader path))
277+
278+
279+
280+-- IMPORT DICT
281+
282+
283+type ImportDict =
284+ Map.Map Module.Raw [Pkg.Name]
285+
286+
287+toImportDict :: Summary -> Map.Map Module.Raw info -> ImportDict
288+toImportDict (Summary _ project exposed _ _) locals =
289+ let
290+ localPkg =
291+ [Project.getName project]
292+
293+ addLocal name _ dict =
294+ Map.insertWith (++) name localPkg dict
295+ in
296+ Map.foldrWithKey addLocal (Map.map (map Pkg._name) exposed) locals
297+
builder/src/File/Find.hsnew file+109
@@ -0,0 +1,109 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module File.Find
4+ ( Asset(..)
5+ , find
6+ )
7+ where
8+
9+import Control.Monad.Except (liftIO)
10+import qualified Data.Map as Map
11+import qualified Data.Maybe as Maybe
12+import qualified System.FilePath as FP
13+import qualified System.Directory as Dir
14+import System.FilePath ((</>), (<.>))
15+
16+import qualified Elm.Compiler.Module as Module
17+import qualified Elm.Name as N
18+import qualified Elm.Package as Pkg
19+
20+import qualified Elm.Project.Json as Project
21+import qualified Elm.Project.Summary as Summary
22+import qualified Reporting.Exit.Crawl as E
23+import qualified Reporting.Task as Task
24+
25+
26+
27+-- ASSET
28+
29+
30+data Asset
31+ = Local FilePath
32+ | Kernel FilePath (Maybe FilePath)
33+ | Foreign Pkg.Package
34+ | ForeignKernel
35+
36+
37+
38+-- FIND
39+
40+
41+find :: Summary.Summary -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset
42+find (Summary.Summary root project exposed _ _) origin name =
43+ do here <- liftIO Dir.getCurrentDirectory
44+ let toRoot dir = FP.makeRelative here (root </> dir)
45+ case project of
46+ Project.App info ->
47+ do let srcDirs = map toRoot (Project._app_source_dirs info)
48+ findElm srcDirs exposed origin name
49+
50+ Project.Pkg _ ->
51+ if N.startsWith "Elm.Kernel." name then
52+ if Project.isPlatformPackage project then
53+ findKernel (toRoot "src") exposed origin name
54+ else
55+ Task.throw $ E.ModuleNameReservedForKernel origin name
56+
57+ else
58+ findElm [ toRoot "src" ] exposed origin name
59+
60+
61+
62+-- FIND ELM
63+
64+
65+findElm :: [FilePath] -> Summary.ExposedModules -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset
66+findElm srcDirs exposed origin name =
67+ do
68+ paths <- liftIO $ Maybe.catMaybes <$> mapM (elmExists name) srcDirs
69+
70+ case (paths, Map.lookup name exposed) of
71+ ([path], Nothing) ->
72+ return (Local path)
73+
74+ ([], Just [pkg]) ->
75+ return (Foreign pkg)
76+
77+ ([], Nothing) ->
78+ Task.throw $ E.ModuleNotFound origin name srcDirs
79+
80+ (_, maybePkgs) ->
81+ Task.throw $ E.ModuleAmbiguous origin name paths (maybe [] id maybePkgs)
82+
83+
84+elmExists :: Module.Raw -> FilePath -> IO (Maybe FilePath)
85+elmExists name srcDir =
86+ do let path = srcDir </> Module.nameToSlashPath name <.> "elm"
87+ exists <- Dir.doesFileExist path
88+ return $ if exists then Just path else Nothing
89+
90+
91+
92+-- FIND KERNEL
93+
94+
95+findKernel :: FilePath -> Summary.ExposedModules -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset
96+findKernel srcDir exposed origin name =
97+ do let clientPath = srcDir </> Module.nameToSlashPath name <.> "js"
98+ let serverPath = srcDir </> Module.nameToSlashPath name <.> "server.js"
99+ client <- liftIO $ Dir.doesFileExist clientPath
100+ server <- liftIO $ Dir.doesFileExist serverPath
101+ if client
102+ then return $ Kernel clientPath (if server then Just serverPath else Nothing)
103+ else
104+ case Map.lookup (N.drop 11 name) exposed of
105+ Just [Pkg.Package pkg _vsn] | pkg == Pkg.core || pkg == Pkg.virtualDom ->
106+ return ForeignKernel
107+
108+ _ ->
109+ Task.throw $ E.ModuleNotFound origin name [srcDir]
builder/src/File/Hash.hsnew file+110
@@ -0,0 +1,110 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module File.Hash
3+ ( Hasher
4+ , put
5+ , Digest
6+ , toString
7+ , putByteString
8+ , putBuilder
9+ , putFile
10+ )
11+ where
12+
13+
14+import Prelude hiding (appendFile)
15+import Control.Monad (foldM)
16+import qualified Control.Monad.State as State
17+import qualified Data.Binary.Get as Binary
18+import qualified Data.ByteString as BS
19+import qualified Data.ByteString.Builder as BS
20+import qualified Data.ByteString.Builder.Extra as BS (defaultChunkSize)
21+import qualified Data.ByteString.Lazy as LBS
22+import qualified Data.Digest.Pure.SHA as SHA
23+import qualified System.IO as IO
24+
25+
26+
27+-- HASHER
28+
29+
30+type Hasher = State.StateT State IO ()
31+
32+
33+type Digest = SHA.Digest SHA.SHA1State
34+
35+
36+put :: FilePath -> Hasher -> IO Digest
37+put path hasher =
38+ IO.withBinaryFile path IO.WriteMode $ \handle ->
39+ do let state = State handle 0 SHA.sha1Incremental
40+ (State _ len decoder) <- State.execStateT hasher state
41+ return (SHA.completeSha1Incremental decoder len)
42+
43+
44+toString :: Digest -> String
45+toString =
46+ SHA.showDigest
47+
48+
49+
50+-- HASH STATE
51+
52+
53+data State =
54+ State
55+ { _handle :: !IO.Handle
56+ , _length :: !Int
57+ , _decoder :: !(Binary.Decoder SHA.SHA1State)
58+ }
59+
60+
61+
62+-- PUBLIC API
63+
64+
65+putByteString :: BS.ByteString -> Hasher
66+putByteString chunk =
67+ do state <- State.get
68+ State.put =<< State.liftIO (appendByteString state chunk)
69+
70+
71+putBuilder :: BS.Builder -> Hasher
72+putBuilder builder =
73+ do state <- State.get
74+ State.put =<< State.liftIO (appendBuilder builder state)
75+
76+
77+putFile :: FilePath -> Hasher
78+putFile path =
79+ do state <- State.get
80+ State.put =<< State.liftIO (appendFile path state)
81+
82+
83+
84+-- PRIMITIVES
85+
86+
87+appendByteString :: State -> BS.ByteString -> IO State
88+appendByteString (State handle len decoder) chunk =
89+ do BS.hPut handle chunk
90+ return $ State handle (len + BS.length chunk) (Binary.pushChunk decoder chunk)
91+
92+
93+appendBuilder :: BS.Builder -> State -> IO State
94+appendBuilder builder state =
95+ foldM appendByteString state $
96+ LBS.toChunks (BS.toLazyByteString builder)
97+
98+
99+appendFile :: FilePath -> State -> IO State
100+appendFile path state =
101+ IO.withBinaryFile path IO.ReadMode $ \handle ->
102+ appendHelp handle state
103+
104+
105+appendHelp :: IO.Handle -> State -> IO State
106+appendHelp handle state =
107+ do chunk <- BS.hGet handle BS.defaultChunkSize
108+ if BS.null chunk
109+ then return state
110+ else appendHelp handle =<< appendByteString state chunk
builder/src/File/Header.hsnew file+191
@@ -0,0 +1,191 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module File.Header
4+ ( Info(..)
5+ , readModule
6+ , readOneFile
7+ , readManyFiles
8+ , readSource
9+ )
10+ where
11+
12+import Control.Monad.Except (liftIO)
13+import qualified Data.ByteString as BS
14+import qualified Data.Map as Map
15+import qualified Data.Time.Calendar as Day
16+import qualified Data.Time.Clock as Time
17+import qualified System.Directory as Dir
18+
19+import qualified Elm.Compiler.Module as Module
20+import qualified Elm.Header as Header
21+
22+import qualified Elm.Project.Json as Project
23+import Elm.Project.Json (Project)
24+import Elm.Project.Summary (Summary(..))
25+import qualified File.IO as IO
26+import qualified Reporting.Exit as Exit
27+import qualified Reporting.Exit.Crawl as E
28+import qualified Reporting.Task as Task
29+
30+
31+
32+-- INFO
33+
34+
35+data Info =
36+ Info
37+ { _path :: FilePath
38+ , _time :: Time.UTCTime
39+ , _source :: BS.ByteString
40+ , _imports :: [Module.Raw]
41+ }
42+
43+
44+atRoot :: Task.Task_ E.Problem a -> Task.Task_ E.Exit a
45+atRoot task =
46+ Task.mapError (\problem -> E.DependencyProblems problem []) task
47+
48+
49+-- READ MODULE
50+
51+
52+readModule :: Summary -> Module.Raw -> FilePath -> Task.Task_ E.Problem (Module.Raw, Info)
53+readModule summary expectedName path =
54+ do time <- liftIO $ Dir.getModificationTime path
55+ source <- liftIO $ IO.readUtf8 path
56+ (maybeName, info) <- parse (_project summary) path time source
57+ name <- checkName path expectedName maybeName
58+ return (name, info)
59+
60+
61+checkName :: FilePath -> Module.Raw -> Maybe Module.Raw -> Task.Task_ E.Problem Module.Raw
62+checkName path expectedName maybeName =
63+ case maybeName of
64+ Nothing ->
65+ Task.throw (E.ModuleNameMissing path expectedName)
66+
67+ Just actualName ->
68+ if expectedName == actualName
69+ then return expectedName
70+ else Task.throw (E.ModuleNameMismatch path expectedName actualName)
71+
72+
73+
74+-- READ ONE FILE
75+
76+
77+readOneFile :: Summary -> FilePath -> Task.Task (Maybe Module.Raw, Info)
78+readOneFile summary path =
79+ Task.mapError Exit.Crawl $
80+ do (time, source) <- readOneHelp path
81+ atRoot $ parse (_project summary) path time source
82+
83+
84+readOneHelp :: FilePath -> Task.Task_ E.Exit (Time.UTCTime, BS.ByteString)
85+readOneHelp path =
86+ do exists <- IO.exists path
87+ if exists
88+ then liftIO $ (,) <$> Dir.getModificationTime path <*> IO.readUtf8 path
89+ else Task.throw $ E.RootFileNotFound path
90+
91+
92+
93+-- READ MANY FILES
94+
95+
96+readManyFiles :: Summary -> FilePath -> [FilePath] -> Task.Task ((Module.Raw, Info), [(Module.Raw, Info)])
97+readManyFiles summary file files =
98+ Task.mapError Exit.Crawl $
99+ do info <- readManyFilesHelp summary file
100+ infos <- traverse (readManyFilesHelp summary) files
101+ let nameTable = foldr insert Map.empty (info:infos)
102+ _ <- Map.traverseWithKey detectDuplicateNames nameTable
103+ return (info, infos)
104+ where
105+ append (x,xs) (y,ys) = (x, xs ++ y : ys)
106+ insert (k,v) dict = Map.insertWith append k (v, []) dict
107+
108+
109+readManyFilesHelp :: Summary -> FilePath -> Task.Task_ E.Exit (Module.Raw, Info)
110+readManyFilesHelp summary path =
111+ do (time, source) <- readOneHelp path
112+ (maybeName, info) <- atRoot $ parse (_project summary) path time source
113+ case maybeName of
114+ Nothing ->
115+ Task.throw (E.RootNameless path)
116+
117+ Just name ->
118+ return (name, info)
119+
120+
121+detectDuplicateNames :: Module.Raw -> (Info, [Info]) -> Task.Task_ E.Exit ()
122+detectDuplicateNames name (info, otherInfos) =
123+ case otherInfos of
124+ [] ->
125+ return ()
126+
127+ _ ->
128+ Task.throw (E.RootModuleNameDuplicate name (map _path (info : otherInfos)))
129+
130+
131+
132+
133+-- READ SOURCE
134+
135+
136+readSource :: Project -> BS.ByteString -> Task.Task (Maybe Module.Raw, Info)
137+readSource project source =
138+ Task.mapError Exit.Crawl $
139+ atRoot $ parse project "elm" fakeTime source
140+
141+
142+fakeTime :: Time.UTCTime
143+fakeTime =
144+ Time.UTCTime (Day.fromGregorian 3000 1 1) 0
145+
146+
147+
148+-- PARSE HEADER
149+
150+
151+parse :: Project -> FilePath -> Time.UTCTime -> BS.ByteString -> Task.Task_ E.Problem (Maybe Module.Raw, Info)
152+parse project path time source =
153+ -- TODO get regions on data extracted here
154+ case Header.parse (Project.getName project) source of
155+ Right (maybeDecl, deps) ->
156+ do maybeName <- checkTag project path maybeDecl
157+ return ( maybeName, Info path time source deps )
158+
159+ Left msg ->
160+ Task.throw (E.BadHeader path time source msg)
161+
162+
163+checkTag :: Project -> FilePath -> Maybe (Header.Tag, Module.Raw) -> Task.Task_ E.Problem (Maybe Module.Raw)
164+checkTag project path maybeDecl =
165+ case maybeDecl of
166+ Nothing ->
167+ return Nothing
168+
169+ Just (tag, name) ->
170+ let
171+ success =
172+ return (Just name)
173+ in
174+ case tag of
175+ Header.Normal ->
176+ success
177+
178+ Header.Port ->
179+ case project of
180+ Project.App _ ->
181+ success
182+
183+ Project.Pkg _ ->
184+ Task.throw (E.PortsInPackage path name)
185+
186+ Header.Effect ->
187+ if Project.isPlatformPackage project then
188+ success
189+
190+ else
191+ Task.throw (E.EffectsUnexpected path name)
builder/src/File/IO.hsnew file+251
@@ -0,0 +1,251 @@
1+module File.IO
2+ ( writeBinary, readBinary
3+ , writeUtf8, readUtf8
4+ , writeBuilder
5+ , Writer
6+ , put
7+ , putByteString
8+ , putBuilder
9+ , putFile
10+ , exists
11+ , remove, removeDir
12+ , find
13+ , andM
14+ )
15+ where
16+
17+
18+import Control.Exception (catch)
19+import Control.Monad.Trans (liftIO)
20+import qualified Data.Binary as Binary
21+import qualified Data.ByteString as BS
22+import qualified Data.ByteString.Internal as BS
23+import qualified Data.ByteString.Builder as B
24+import qualified Data.ByteString.Builder.Extra as B (defaultChunkSize)
25+import qualified Foreign.ForeignPtr as FPtr
26+import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
27+import qualified System.Directory as Dir
28+import System.FilePath ((</>))
29+import qualified System.FilePath as FP
30+import qualified System.IO as IO
31+import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
32+
33+import qualified Elm.PerUserCache as PerUserCache
34+import qualified Reporting.Exit as Exit
35+import qualified Reporting.Exit.Assets as E
36+import qualified Reporting.Task as Task
37+
38+
39+
40+-- BINARY
41+
42+
43+writeBinary :: (Binary.Binary a) => FilePath -> a -> Task.Task ()
44+writeBinary path value =
45+ liftIO $
46+ do let dir = FP.dropFileName path
47+ Dir.createDirectoryIfMissing True dir
48+ Binary.encodeFile path value
49+
50+
51+readBinary :: (Binary.Binary a) => FilePath -> Task.Task a
52+readBinary path =
53+ do exists_ <- liftIO (Dir.doesFileExist path)
54+ if not exists_
55+ then throwCorruptBinary path
56+ else
57+ do result <- liftIO (Binary.decodeFileOrFail path)
58+ case result of
59+ Left _ ->
60+ throwCorruptBinary path
61+
62+ Right value ->
63+ return value
64+
65+
66+throwCorruptBinary :: FilePath -> Task.Task a
67+throwCorruptBinary filePath =
68+ do elmHome <- liftIO PerUserCache.getElmHome
69+ Task.throw (Exit.Assets (E.CorruptBinary elmHome filePath))
70+
71+
72+
73+-- WRITE UTF-8
74+
75+
76+writeUtf8 :: FilePath -> BS.ByteString -> IO ()
77+writeUtf8 filePath content =
78+ withUtf8 filePath IO.WriteMode $ \handle ->
79+ BS.hPut handle content
80+
81+
82+withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
83+withUtf8 filePath mode callback =
84+ IO.withFile filePath mode $ \handle ->
85+ do IO.hSetEncoding handle IO.utf8
86+ callback handle
87+
88+
89+
90+-- READ UTF-8
91+
92+
93+readUtf8 :: FilePath -> IO BS.ByteString
94+readUtf8 filePath =
95+ withUtf8 filePath IO.ReadMode $ \handle ->
96+ modifyIOError (encodingError filePath) $
97+ do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
98+ let readSize = max 0 (fromIntegral fileSize) + 1
99+ hGetContentsSizeHint handle readSize (max 255 readSize)
100+
101+
102+useZeroIfNotRegularFile :: IOException -> IO Integer
103+useZeroIfNotRegularFile _ =
104+ return 0
105+
106+
107+hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
108+hGetContentsSizeHint handle =
109+ readChunks []
110+ where
111+ readChunks chunks readSize incrementSize =
112+ do fp <- BS.mallocByteString readSize
113+ readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
114+ let chunk = BS.PS fp 0 readCount
115+ if readCount < readSize && readSize > 0
116+ then return $! BS.concat (reverse (chunk:chunks))
117+ else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
118+
119+
120+encodingError :: FilePath -> IOError -> IOError
121+encodingError filePath ioErr =
122+ case ioeGetErrorType ioErr of
123+ InvalidArgument ->
124+ annotateIOError
125+ (userError "Bad encoding; the file must be valid UTF-8")
126+ ""
127+ Nothing
128+ (Just filePath)
129+
130+ _ ->
131+ ioErr
132+
133+
134+
135+-- WRITE BUILDER
136+
137+
138+writeBuilder :: FilePath -> B.Builder -> IO ()
139+writeBuilder path builder =
140+ IO.withBinaryFile path IO.WriteMode $ \handle ->
141+ do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
142+ B.hPutBuilder handle builder
143+
144+
145+
146+-- WRITER
147+
148+
149+newtype Writer =
150+ Writer (IO.Handle -> IO ())
151+
152+
153+put :: FilePath -> Writer -> IO ()
154+put path (Writer callback) =
155+ IO.withBinaryFile path IO.WriteMode callback
156+
157+
158+putByteString :: BS.ByteString -> Writer
159+putByteString chunk =
160+ Writer $ \handle ->
161+ BS.hPut handle chunk
162+
163+
164+putBuilder :: B.Builder -> Writer
165+putBuilder builder =
166+ Writer $ \handle ->
167+ B.hPutBuilder handle builder
168+
169+
170+putFile :: FilePath -> Writer
171+putFile path =
172+ Writer $ \sink ->
173+ IO.withBinaryFile path IO.ReadMode $ \source ->
174+ putHelp source sink
175+
176+
177+putHelp :: IO.Handle -> IO.Handle -> IO ()
178+putHelp source sink =
179+ do chunk <- BS.hGet source B.defaultChunkSize
180+ if BS.null chunk
181+ then return ()
182+ else
183+ do BS.hPut sink chunk
184+ putHelp source sink
185+
186+
187+
188+-- EXISTS
189+
190+
191+exists :: FilePath -> Task.Task_ e Bool
192+exists filePath =
193+ liftIO $ Dir.doesFileExist filePath
194+
195+
196+
197+-- REMOVE FILES
198+
199+
200+remove :: FilePath -> Task.Task_ e ()
201+remove filePath =
202+ liftIO $
203+ do exists_ <- Dir.doesFileExist filePath
204+ if exists_
205+ then Dir.removeFile filePath
206+ else return ()
207+
208+
209+removeDir :: FilePath -> IO ()
210+removeDir path =
211+ do exists_ <- Dir.doesDirectoryExist path
212+ if exists_
213+ then Dir.removeDirectoryRecursive path
214+ else return ()
215+
216+
217+
218+-- FIND FILES
219+
220+
221+find :: FilePath -> IO (Maybe FilePath)
222+find name =
223+ do subDir <- Dir.getCurrentDirectory
224+ findHelp name (FP.splitDirectories subDir)
225+
226+
227+findHelp :: FilePath -> [String] -> IO (Maybe FilePath)
228+findHelp name dirs =
229+ if null dirs then
230+ return Nothing
231+
232+ else
233+ do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)
234+ if exists_
235+ then return (Just (FP.joinPath dirs))
236+ else findHelp name (init dirs)
237+
238+
239+
240+-- HELPER
241+
242+
243+andM :: (Monad m) => [m Bool] -> m Bool
244+andM checks =
245+ case checks of
246+ [] ->
247+ return True
248+
249+ check : otherChecks ->
250+ do bool <- check
251+ if bool then andM otherChecks else return False
builder/src/File/Plan.hsnew file+205
@@ -0,0 +1,205 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module File.Plan
4+ ( plan
5+ , Info(..)
6+ )
7+ where
8+
9+import Control.Concurrent (forkIO)
10+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
11+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
12+import Control.Monad (foldM, void, when)
13+import Control.Monad.Except (liftIO)
14+import qualified Data.Binary as Binary
15+import qualified Data.ByteString as BS
16+import qualified Data.Map as Map
17+import qualified Data.Time.Clock as Time
18+import qualified System.Directory as Dir
19+
20+import qualified Elm.Compiler.Module as Module
21+import qualified Elm.Package as Pkg
22+
23+import qualified Elm.Project.Json as Project
24+import qualified Elm.Project.Summary as Summary
25+import qualified File.Crawl as Crawl
26+import qualified File.Header as Header
27+import qualified Reporting.Task as Task
28+import qualified Stuff.Paths
29+
30+
31+
32+-- PLAN
33+
34+
35+type Dict value = Map.Map Module.Raw value
36+
37+
38+plan :: Maybe FilePath -> Summary.Summary -> Crawl.Result -> Task.Task (Dict Info, Module.Interfaces)
39+plan docs (Summary.Summary root project _ ifaces _) (Crawl.Graph _ locals _ foreigns _) =
40+ liftIO $
41+ do queue <- newChan
42+ let env = Env queue root (Project.getName project) docs
43+
44+ mvar <- newEmptyMVar
45+ statusMVars <- Map.traverseWithKey (getStatus env mvar foreigns) locals
46+ putMVar mvar statusMVars
47+
48+ void $ forkIO $
49+ do graph <- Map.traverseMaybeWithKey (\_ -> readMVar) statusMVars
50+ writeChan queue (EndLoop graph)
51+
52+ ifaceLoader queue ifaces
53+
54+
55+data Env =
56+ Env
57+ { _queue :: Chan Msg
58+ , _root :: FilePath
59+ , _pkg :: Pkg.Name
60+ , _docs :: Maybe FilePath
61+ }
62+
63+
64+
65+-- STATUS
66+
67+
68+type Status = Maybe Info
69+ -- Nothing == clean
70+ -- Just info == dirty
71+
72+
73+data Info =
74+ Info
75+ { _path :: FilePath
76+ , _time :: Time.UTCTime
77+ , _src :: BS.ByteString
78+ , _clean :: [Module.Raw]
79+ , _dirty :: [Module.Raw]
80+ , _foreign :: [Module.Canonical] -- TODO is this needed?
81+ }
82+
83+
84+
85+-- GET STATUS
86+
87+
88+getStatus
89+ :: Env
90+ -> MVar (Dict (MVar Status))
91+ -> Dict Pkg.Package
92+ -> Module.Raw
93+ -> Header.Info
94+ -> IO (MVar Status)
95+getStatus env statusMVars foreigns name (Header.Info path time src deps) =
96+ do mvar <- newEmptyMVar
97+
98+ void $ forkIO $ putMVar mvar =<<
99+ do statuses <- readMVar statusMVars
100+ info <- foldM (addDep statuses foreigns) (Info path time src [] [] []) deps
101+
102+ let elmi = Stuff.Paths.elmi (_root env) name
103+ let docs = Stuff.Paths.moduleDocs (_root env) name
104+
105+ case _dirty info of
106+ _ : _ ->
107+ do remove elmi
108+ remove docs
109+ return (Just info)
110+
111+ [] ->
112+ do freshElmi <- isFresh time elmi
113+ freshDocs <-
114+ case _docs env of
115+ Nothing -> return True
116+ Just _ -> isFresh time docs
117+
118+ if freshElmi && freshDocs
119+ then
120+ do let canonical = Module.Canonical (_pkg env) name
121+ writeChan (_queue env) (Get canonical elmi)
122+ return Nothing
123+ else
124+ do remove elmi
125+ remove docs
126+ return (Just info)
127+
128+ return mvar
129+
130+
131+addDep :: Dict (MVar Status) -> Dict Pkg.Package -> Info -> Module.Raw -> IO Info
132+addDep locals foreigns info name =
133+ case Map.lookup name locals of
134+ Just mvar ->
135+ do status <- readMVar mvar
136+ case status of
137+ Nothing ->
138+ return $ info { _clean = name : _clean info }
139+
140+ Just _ ->
141+ return $ info { _dirty = name : _dirty info }
142+
143+ Nothing ->
144+ case Map.lookup name foreigns of
145+ Just (Pkg.Package pkg _vsn) ->
146+ return $ info { _foreign = Module.Canonical pkg name : _foreign info }
147+
148+ Nothing ->
149+ return info -- must be native
150+
151+
152+
153+-- IS FRESH
154+
155+
156+isFresh :: Time.UTCTime -> FilePath -> IO Bool
157+isFresh srcTime cachedFile =
158+ andM
159+ [ Dir.doesFileExist cachedFile
160+ , do cacheTime <- Dir.getModificationTime cachedFile
161+ return (cacheTime >= srcTime)
162+ ]
163+
164+
165+andM :: [IO Bool] -> IO Bool
166+andM checks =
167+ case checks of
168+ [] ->
169+ return True
170+
171+ check : otherChecks ->
172+ do bool <- check
173+ if bool then andM otherChecks else return False
174+
175+
176+remove :: FilePath -> IO ()
177+remove path =
178+ do exists <- Dir.doesFileExist path
179+ when exists (Dir.removeFile path)
180+
181+
182+
183+-- INTERFACE LOADER
184+
185+
186+data Msg
187+ = EndLoop (Dict Info)
188+ | Get Module.Canonical FilePath
189+
190+
191+ifaceLoader :: Chan Msg -> Module.Interfaces -> IO (Dict Info, Module.Interfaces)
192+ifaceLoader queue ifaces =
193+ do msg <- readChan queue
194+ case msg of
195+ EndLoop dirty ->
196+ return ( dirty, ifaces )
197+
198+ Get canonical elmi ->
199+ case Map.lookup canonical ifaces of
200+ Just _ ->
201+ ifaceLoader queue ifaces
202+
203+ Nothing ->
204+ do iface <- Binary.decodeFile elmi
205+ ifaceLoader queue $ Map.insert canonical iface ifaces
builder/src/File/Watcher.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module File.Watcher where
3+
4+import Control.Concurrent (forkIO, threadDelay)
5+import Control.Concurrent.Chan (newChan, readChan, writeChan)
6+import qualified System.FSNotify as Notify
7+
8+import qualified Elm.Project as Project
9+import Elm.Project (Project)
10+
11+
12+
13+-- GRAPH
14+
15+
16+data Graph =
17+ Graph
18+ { _elm :: Map.Map Module.Raw Node
19+ , _js :: Map.Map Module.Raw FilePath
20+ }
21+
22+
23+data Node =
24+ Node
25+ { _path :: FilePath
26+ , _time :: UTCTime
27+ , _needs :: Set.Set Module.Raw
28+ , _blocks :: Set.Set Module.Raw
29+ , _iface :: Maybe (UTCTime, Interface)
30+ }
31+
32+
33+
34+-- ABC
35+
36+
37+action :: Notify.Event -> IO ()
38+action event =
39+ case event of
40+ Notify.Added path time ->
41+ return ()
42+
43+ Notify.Modified path time ->
44+ return ()
45+
46+ Notify.Removed path time ->
47+ return ()
48+
49+
50+watcher :: Project -> IO ()
51+watcher project =
52+ let
53+ srcDir =
54+ Project.toSourceDir project
55+
56+ action event =
57+ case event of
58+ Notify.Added _ _ ->
59+ return ()
60+
61+ Notify.Modified path time ->
62+
63+ Notify.Removed path time ->
64+
65+ in
66+ do killer <- newChan
67+ mapM_ (watcherHelp killer action) [srcDir]
68+
69+
70+
71+watcherHelp :: Notify.Action -> FilePath -> IO ()
72+watcherHelp killer action dir =
73+ void $ forkIO $ Notify.withManager $ \manager ->
74+ do stop <- Notify.watchTree manager dir (const True) action
75+ _ <- readChan killer
76+ stop
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
compiler/src/Generate/JavaScript/Functions.hs → builder/src/Generate/Functions.hsrenamed+3−6
@@ -1,9 +1,6 @@
1−{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2−module Generate.JavaScript.Functions
3− ( functions
4− )
5− where
6−
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+module Generate.Functions (functions) where
74
85import qualified Data.ByteString.Builder as B
96import Text.RawString.QQ (r)
builder/src/Generate/Html.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+module Generate.Html
4+ ( sandwich
5+ )
6+ where
7+
8+
9+import qualified Data.ByteString.Builder as B
10+import Data.Monoid ((<>))
11+import Text.RawString.QQ (r)
12+
13+import qualified Elm.Name as N
14+
15+
16+
17+-- SANDWICH
18+
19+
20+sandwich :: N.Name -> B.Builder -> B.Builder
21+sandwich moduleName javascript =
22+ let name = N.toBuilder moduleName in
23+ [r|<!DOCTYPE HTML>
24+<html>
25+<head>
26+ <meta charset="UTF-8">
27+ <title>|] <> name <> [r|</title>
28+</head>
29+
30+<body>
31+<div id="embed"></div>
32+<script>
33+|] <> javascript <> [r|
34+
35+// It is too complicated to figure out which kind of Program you created
36+// based on only the code. So here we check for different possibilities.
37+//
38+// When you embed compiled Elm into HTML yourself, you should not copy/paste
39+// from here. Do just the part that makes sense for your application!
40+//
41+var app =
42+ Elm.|] <> name <> [r|.fullscreen
43+ ? Elm.|] <> name <> [r|.fullscreen()
44+ :
45+ Elm.|] <> name <> [r|.embed
46+ ? Elm.|] <> name <> [r|.embed(document.getElementById('embed'))
47+ :
48+ Elm.|] <> name <> [r|.worker
49+ ? (document.getElementById('embed').innerText = 'This is a headless program, meaning there is nothing to show here. I started the program anyway though, and you can access it as `app` in the developer console.', Elm.|] <> name <> [r|.worker())
50+ : (document.getElementById('embed').innerText = 'I cannot figure out what kind of program this is supposed to be. Perhaps someone on Slack can help?', undefined);
51+</script>
52+</body>
53+</html>|]
compiler/src/Nitpick/Debug.hs → builder/src/Generate/Nitpick.hsrenamed+22−10
@@ -1,21 +1,33 @@
1−module Nitpick.Debug
2− ( hasDebugUses
1+module Generate.Nitpick
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.Set as Set
89
910import qualified AST.Optimized as Opt
11+import qualified AST.Module.Name as ModuleName
12+import qualified Elm.Package as Pkg
13+import qualified Elm.Name as N
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 -> [N.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 N.Name -> Set.Set N.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
@@ -27,7 +39,7 @@ nodeHasDebug node =
2739 Opt.Enum _ -> False
2840 Opt.Box -> False
2941 Opt.Link _ -> False
30− Opt.Cycle _ vs fs _ -> any (hasDebug . snd) vs || any defHasDebug fs
42+ Opt.Cycle defs _ -> any (hasDebug . snd) defs
3143 Opt.Manager _ -> False
3244 Opt.Kernel _ _ -> False
3345 Opt.PortIncoming expr _ -> hasDebug expr
@@ -63,7 +75,7 @@ hasDebug expression =
6375 Opt.Record fs -> any hasDebug fs
6476 Opt.Unit -> False
6577 Opt.Tuple a b c -> hasDebug a || hasDebug b || maybe False hasDebug c
66− Opt.Shader _ _ _ -> False
78+ Opt.Shader _ -> False
6779
6880
6981defHasDebug :: Opt.Def -> Bool
@@ -84,4 +96,4 @@ deciderHasDebug decider =
8496
8597
8698-- TODO: FIND GLOBALLY UNUSED DEFINITIONS?
87−-- TODO: FIND PACKAGE USAGE STATS? (e.g. elm/core = 142, author/project = 2, etc.)
99+-- TODO: FIND PACKAGE USAGE STATS? (e.g. elm-lang/core = 142, author/project = 2, etc.)
builder/src/Generate/Output.hsnew file+281
@@ -0,0 +1,281 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Generate.Output
4+ ( Mode(..)
5+ , Mode.Target(..)
6+ , generate
7+ , generateReplFile
8+ , noDebugUsesInPackage
9+ , Output(..)
10+ , output
11+ )
12+ where
13+
14+
15+import Control.Concurrent.MVar (MVar, putMVar)
16+import Control.Monad.Trans (liftIO)
17+import qualified Data.ByteString.Builder as B
18+import qualified Data.Map as Map
19+import Data.Monoid ((<>))
20+import qualified System.Directory as Dir
21+import qualified System.FilePath as FP
22+import System.FilePath ((</>))
23+
24+import qualified Elm.Compiler as Compiler
25+import qualified Elm.Compiler.Module as Module
26+import qualified Elm.Compiler.Objects as Obj
27+import qualified Elm.Interface as I
28+import qualified Elm.Name as N
29+import qualified Elm.Package as Pkg
30+
31+import qualified AST.Module.Name as ModuleName
32+import qualified Elm.Project.Json as Project
33+import qualified Elm.Project.Summary as Summary
34+import qualified File.Args as Args
35+import qualified File.Crawl as Crawl
36+import qualified File.IO as IO
37+import qualified Generate.Functions as Functions
38+import qualified Generate.Html as Html
39+import qualified Generate.Nitpick as Nitpick
40+import qualified Generate.JavaScript.Mode as Mode
41+import qualified Reporting.Exit as Exit
42+import qualified Reporting.Exit.Make as E
43+import qualified Reporting.Render.Type.Localizer as L
44+import qualified Reporting.Task as Task
45+import qualified Stuff.Paths as Paths
46+import Terminal.Args (Parser(..))
47+
48+
49+
50+-- GENERATE
51+
52+
53+data Mode = Debug | Dev | Prod
54+
55+
56+generate
57+ :: Mode
58+ -> Mode.Target
59+ -> Maybe Output
60+ -> Summary.Summary
61+ -> Crawl.Result
62+ -> Map.Map Module.Raw Compiler.Artifacts
63+ -> Task.Task ()
64+generate mode target maybeOutput summary graph@(Crawl.Graph args _ _ _ _) artifacts =
65+ case args of
66+ Args.Pkg _ ->
67+ return ()
68+
69+ Args.Roots name names ->
70+ do objectGraph <- organize summary graph
71+
72+ realMode <-
73+ case mode of
74+ Debug ->
75+ return $ Mode.debug target (getInterfaces summary artifacts)
76+
77+ Dev ->
78+ return $ Mode.dev target
79+
80+ Prod ->
81+ do noDebugUses summary objectGraph
82+ return $ Mode.prod target objectGraph
83+
84+ generateMonolith realMode maybeOutput summary objectGraph (name:names)
85+
86+
87+getInterfaces :: Summary.Summary -> Map.Map Module.Raw Compiler.Artifacts -> I.Interfaces
88+getInterfaces (Summary.Summary _ project _ interfaces _) artifacts =
89+ let
90+ pkg = Project.getName project
91+ addArtifact home (Compiler.Artifacts elmi _ _) ifaces =
92+ Map.insert (ModuleName.Canonical pkg home) elmi ifaces
93+ in
94+ Map.foldrWithKey addArtifact interfaces artifacts
95+
96+
97+
98+-- GENERATE MONOLITH
99+
100+
101+generateMonolith
102+ :: Mode.Mode
103+ -> Maybe Output
104+ -> Summary.Summary
105+ -> Obj.Graph
106+ -> [Module.Raw]
107+ -> Task.Task ()
108+generateMonolith mode maybeOutput (Summary.Summary _ project _ _ _) graph rootNames =
109+ do let pkg = Project.getName project
110+ let roots = map (Module.Canonical pkg) rootNames
111+ case Obj.generate mode graph roots of
112+ Obj.None ->
113+ return ()
114+
115+ Obj.Some name _names builder ->
116+ let
117+ monolith =
118+ "(function(scope){\n'use strict';"
119+ <> Functions.functions <> builder <> "}(this));"
120+ in
121+ liftIO $
122+ case maybeOutput of
123+ Nothing ->
124+ IO.writeBuilder "elm.js" monolith
125+
126+ Just output_ ->
127+ case output_ of
128+ None ->
129+ return ()
130+
131+ JavaScript maybeDir fileName ->
132+ do path <- toWritablePath maybeDir fileName
133+ IO.writeBuilder path monolith
134+
135+ HtmlBuilder mvar ->
136+ putMVar mvar (Html.sandwich name monolith)
137+
138+ Html maybeDir fileName ->
139+ do path <- toWritablePath maybeDir fileName
140+ IO.writeBuilder path (Html.sandwich name monolith)
141+
142+
143+
144+-- GENERATE REPL MONOLITH
145+
146+
147+generateReplFile
148+ :: Bool
149+ -> L.Localizer
150+ -> Summary.Summary
151+ -> Crawl.Result
152+ -> I.Interface
153+ -> N.Name
154+ -> Task.Task FilePath
155+generateReplFile noColors localizer summary@(Summary.Summary _ project _ _ _) graph iface name =
156+ do
157+ objectGraph <- organize summary graph
158+
159+ let home = Module.Canonical (Project.getName project) N.replModule
160+ let builder = Obj.generateForRepl (not noColors) localizer objectGraph iface home name
161+
162+ liftIO $ IO.writeBuilder (Paths.temp "js") $
163+ replRecovery <> "(function(){\n'use strict';" <> Functions.functions <> builder <> "}());"
164+
165+ return (Paths.temp "js")
166+
167+
168+replRecovery :: B.Builder
169+replRecovery =
170+ "process.on('uncaughtException', function(err) { process.stderr.write(err.toString()); process.exit(1); });"
171+
172+
173+
174+-- ORGANIZE
175+
176+
177+organize :: Summary.Summary -> Crawl.Result -> Task.Task Obj.Graph
178+organize (Summary.Summary root _ _ _ deps) (Crawl.Graph _ locals _ _ _) =
179+ do localObjs <- Obj.unions <$> traverse (loadModuleObj root) (Map.keys locals)
180+ foreignObjs <- Obj.unions <$> traverse loadPackageObj (Map.toList deps)
181+ return (Obj.union localObjs foreignObjs)
182+
183+
184+loadModuleObj :: FilePath -> Module.Raw -> Task.Task Obj.Graph
185+loadModuleObj root name =
186+ IO.readBinary (Paths.elmo root name)
187+
188+
189+loadPackageObj :: ( Pkg.Name, (Pkg.Version, deps) ) -> Task.Task Obj.Graph
190+loadPackageObj ( name, (version,_) ) =
191+ do dir <- Task.getPackageCacheDirFor name version
192+ IO.readBinary (dir </> "objs.dat")
193+
194+
195+
196+-- NO DEBUG USES
197+
198+
199+noDebugUses :: Summary.Summary -> Obj.Graph -> Task.Task ()
200+noDebugUses (Summary.Summary _ project _ _ _) graph =
201+ case Nitpick.findDebugUses (Project.getName project) graph of
202+ [] ->
203+ return ()
204+
205+ m:ms ->
206+ Task.throw (Exit.Make (E.CannotOptimizeDebugValues m ms))
207+
208+
209+noDebugUsesInPackage :: Summary.Summary -> Crawl.Result -> Task.Task ()
210+noDebugUsesInPackage summary graph =
211+ noDebugUses summary =<< organize summary graph
212+
213+
214+
215+-- OUTPUT
216+
217+
218+data Output
219+ = None
220+ | Html (Maybe FilePath) FilePath
221+ | JavaScript (Maybe FilePath) FilePath
222+ | HtmlBuilder (MVar B.Builder)
223+
224+
225+toWritablePath :: Maybe FilePath -> FilePath -> IO FilePath
226+toWritablePath maybeDir fileName =
227+ case maybeDir of
228+ Nothing ->
229+ do return fileName
230+
231+ Just dir ->
232+ do Dir.createDirectoryIfMissing True dir
233+ return (dir </> fileName)
234+
235+
236+
237+-- OUTPUT PARSER
238+
239+
240+output :: Parser Output
241+output =
242+ Parser
243+ { _singular = "output file"
244+ , _plural = "output files"
245+ , _parser = parseOutput
246+ , _suggest = \_ -> return []
247+ , _examples = exampleOutput
248+ }
249+
250+
251+parseOutput :: String -> Maybe Output
252+parseOutput string =
253+ if string == "/dev/null" || string == "NUL" || string == "$null" then
254+ Just None
255+
256+ else if FP.takeExtension string == ".html" && length string > 5 then
257+ splitOutput Html string
258+
259+ else if FP.takeExtension string == ".js" && length string > 3 then
260+ splitOutput JavaScript string
261+
262+ else
263+ Nothing
264+
265+
266+splitOutput :: (Maybe FilePath -> FilePath -> Output) -> String -> Maybe Output
267+splitOutput toOutput string =
268+ case FP.splitPath string of
269+ [] ->
270+ Nothing
271+
272+ [name] ->
273+ Just $ toOutput Nothing name
274+
275+ segments ->
276+ Just $ toOutput (Just (FP.joinPath (init segments))) (last segments)
277+
278+
279+exampleOutput :: String -> IO [String]
280+exampleOutput _ =
281+ return [ "elm.js", "index.html", "/dev/null" ]
builder/src/Http.hsdeleted−244
@@ -1,244 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Http
3− ( Manager
4− , getManager
5− , toUrl
6− -- fetch
7− , get
8− , post
9− , Header
10− , accept
11− , Error(..)
12− -- archives
13− , Sha
14− , shaToChars
15− , getArchive
16− -- upload
17− , upload
18− , filePart
19− , jsonPart
20− , stringPart
21− )
22− where
23−
24−
25−import Prelude hiding (zip)
26−import qualified Codec.Archive.Zip as Zip
27−import Control.Exception (SomeException, handle)
28−import qualified Data.Binary as Binary
29−import qualified Data.Binary.Get as Binary
30−import qualified Data.ByteString.Builder as B
31−import qualified Data.ByteString.Char8 as BS
32−import qualified Data.Digest.Pure.SHA as SHA
33−import qualified Data.String as String
34−import Network.HTTP (urlEncodeVars)
35−import Network.HTTP.Client
36−import Network.HTTP.Client.TLS (tlsManagerSettings)
37−import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38−import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
40−import qualified Network.HTTP.Client.MultipartFormData as Multi
41−
42−import qualified Json.Encode as Encode
43−import qualified Elm.Version as V
44−
45−
46−
47−-- MANAGER
48−
49−
50−getManager :: IO Manager
51−getManager =
52− newManager tlsManagerSettings
53−
54−
55−
56−-- URL
57−
58−
59−toUrl :: String -> [(String,String)] -> String
60−toUrl url params =
61− case params of
62− [] -> url
63− _:_ -> url ++ "?" ++ urlEncodeVars params
64−
65−
66−
67−-- FETCH
68−
69−
70−get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
71−get =
72− fetch methodGet
73−
74−
75−post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
76−post =
77− fetch methodPost
78−
79−
80−fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
81−fetch methodVerb manager url headers onError onSuccess =
82− handle (handleSomeException url onError) $
83− handle (handleHttpException url onError) $
84− do req0 <- parseUrlThrow url
85− let req1 =
86− req0
87− { method = methodVerb
88− , requestHeaders = addDefaultHeaders headers
89− }
90− withResponse req1 manager $ \response ->
91− do chunks <- brConsume (responseBody response)
92− onSuccess (BS.concat chunks)
93−
94−
95−addDefaultHeaders :: [Header] -> [Header]
96−addDefaultHeaders headers =
97− (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
98−
99−
100−{-# NOINLINE userAgent #-}
101−userAgent :: BS.ByteString
102−userAgent =
103− BS.pack ("elm/" ++ V.toChars V.compiler)
104−
105−
106−accept :: BS.ByteString -> Header
107−accept mime =
108− (hAccept, mime)
109−
110−
111−
112−-- EXCEPTIONS
113−
114−
115−data Error
116− = BadUrl String String
117− | BadHttp String HttpExceptionContent
118− | BadMystery String SomeException
119−
120−
121−handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
122−handleHttpException url onError httpException =
123− case httpException of
124− InvalidUrlException _ reason ->
125− return (Left (onError (BadUrl url reason)))
126−
127− HttpExceptionRequest _ content ->
128− return (Left (onError (BadHttp url content)))
129−
130−
131−handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
132−handleSomeException url onError exception =
133− return (Left (onError (BadMystery url exception)))
134−
135−
136−
137−-- SHA
138−
139−
140−type Sha = SHA.Digest SHA.SHA1State
141−
142−
143−shaToChars :: Sha -> String
144−shaToChars =
145− SHA.showDigest
146−
147−
148−
149−-- FETCH ARCHIVE
150−
151−
152−getArchive
153− :: Manager
154− -> String
155− -> (Error -> e)
156− -> e
157− -> ((Sha, Zip.Archive) -> IO (Either e a))
158− -> IO (Either e a)
159−getArchive manager url onError err onSuccess =
160− handle (handleSomeException url onError) $
161− handle (handleHttpException url onError) $
162− do req0 <- parseUrlThrow url
163− let req1 =
164− req0
165− { method = methodGet
166− , requestHeaders = addDefaultHeaders []
167− }
168− withResponse req1 manager $ \response ->
169− do result <- readArchive (responseBody response)
170− case result of
171− Nothing -> return (Left err)
172− Just shaAndArchive -> onSuccess shaAndArchive
173−
174−
175−readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
176−readArchive body =
177− readArchiveHelp body $
178− AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
179−
180−
181−data ArchiveState =
182− AS
183− { _len :: !Int
184− , _sha :: !(Binary.Decoder SHA.SHA1State)
185− , _zip :: !(Binary.Decoder Zip.Archive)
186− }
187−
188−
189−readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
190−readArchiveHelp body (AS len sha zip) =
191− case zip of
192− Binary.Fail _ _ _ ->
193− return Nothing
194−
195− Binary.Partial k ->
196− do chunk <- brRead body
197− readArchiveHelp body $
198− AS
199− { _len = len + BS.length chunk
200− , _sha = Binary.pushChunk sha chunk
201− , _zip = k (if BS.null chunk then Nothing else Just chunk)
202− }
203−
204− Binary.Done _ _ archive ->
205− return $ Just ( SHA.completeSha1Incremental sha len, archive )
206−
207−
208−
209−-- UPLOAD
210−
211−
212−upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
213−upload manager url parts =
214− handle (handleSomeException url id) $
215− handle (handleHttpException url id) $
216− do req0 <- parseUrlThrow url
217− req1 <-
218− Multi.formDataBody parts $
219− req0
220− { method = methodPost
221− , requestHeaders = addDefaultHeaders []
222− , responseTimeout = responseTimeoutNone
223− }
224− withResponse req1 manager $ \_ ->
225− return (Right ())
226−
227−
228−filePart :: String -> FilePath -> Multi.Part
229−filePart name filePath =
230− Multi.partFileSource (String.fromString name) filePath
231−
232−
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−
242−stringPart :: String -> String -> Multi.Part
243−stringPart name string =
244− Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hsdeleted−474
@@ -1,474 +0,0 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2−module Reporting
3− ( Style
4− , silent
5− , json
6− , terminal
7− --
8− , attempt
9− , attemptWithStyle
10− --
11− , Key
12− , report
13− , ignorer
14− , ask
15− --
16− , DKey
17− , DMsg(..)
18− , trackDetails
19− --
20− , BKey
21− , BMsg(..)
22− , trackBuild
23− --
24− , reportGenerate
25− )
26− where
27−
28−
29−import Control.Concurrent
30−import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
31−import Control.Monad (when)
32−import qualified Data.ByteString.Builder as B
33−import qualified Data.NonEmptyList as NE
34−import qualified System.Exit as Exit
35−import qualified System.Info as Info
36−import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
37−
38−import qualified Elm.ModuleName as ModuleName
39−import qualified Elm.Package as Pkg
40−import qualified Elm.Version as V
41−import qualified Json.Encode as Encode
42−import Reporting.Doc ((<+>), (<>))
43−import qualified Reporting.Doc as D
44−import qualified Reporting.Exit as Exit
45−import qualified Reporting.Exit.Help as Help
46−
47−
48−
49−-- STYLE
50−
51−
52−data Style
53− = Silent
54− | Json
55− | Terminal (MVar ())
56−
57−
58−silent :: Style
59−silent =
60− Silent
61−
62−
63−json :: Style
64−json =
65− Json
66−
67−
68−terminal :: IO Style
69−terminal =
70− Terminal <$> newMVar ()
71−
72−
73−
74−-- ATTEMPT
75−
76−
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
92− case result of
93− Right a ->
94− return a
95−
96− Left x ->
97− case style of
98− Silent ->
99− do Exit.exitFailure
100−
101− Json ->
102− do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
103− Exit.exitFailure
104−
105− Terminal mvar ->
106− do readMVar mvar
107− Exit.toStderr (toReport x)
108− Exit.exitFailure
109−
110−
111−
112−-- MARKS
113−
114−
115−goodMark :: D.Doc
116−goodMark =
117− D.green $ if isWindows then "+" else "●"
118−
119−
120−badMark :: D.Doc
121−badMark =
122− D.red $ if isWindows then "X" else "✗"
123−
124−
125−isWindows :: Bool
126−isWindows =
127− Info.os == "mingw32"
128−
129−
130−
131−-- KEY
132−
133−
134−newtype Key msg = Key (msg -> IO ())
135−
136−
137−report :: Key msg -> msg -> IO ()
138−report (Key send) msg =
139− send msg
140−
141−
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−
170−
171−-- DETAILS
172−
173−
174−type DKey = Key DMsg
175−
176−
177−trackDetails :: Style -> (DKey -> IO a) -> IO a
178−trackDetails style callback =
179− case style of
180− Silent ->
181− callback (Key (\_ -> return ()))
182−
183− Json ->
184− callback (Key (\_ -> return ()))
185−
186− Terminal mvar ->
187− do chan <- newChan
188−
189− _ <- forkIO $
190− do takeMVar mvar
191− detailsLoop chan (DState 0 0 0 0 0 0 0)
192− putMVar mvar ()
193−
194− answer <- callback (Key (writeChan chan . Just))
195− writeChan chan Nothing
196− return answer
197−
198−
199−detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()
200−detailsLoop chan state@(DState total _ _ _ _ built _) =
201− do msg <- readChan chan
202− case msg of
203− Just dmsg ->
204− detailsLoop chan =<< detailsStep dmsg state
205−
206− Nothing ->
207− putStrLn $ clear (toBuildProgress total total) $
208− if built == total
209− then "Dependencies ready!"
210− else "Dependency problem!"
211−
212−
213−data DState =
214− DState
215− { _total :: !Int
216− , _cached :: !Int
217− , _requested :: !Int
218− , _received :: !Int
219− , _failed :: !Int
220− , _built :: !Int
221− , _broken :: !Int
222− }
223−
224−
225−data DMsg
226− = DStart Int
227− | DCached
228− | DRequested
229− | DReceived Pkg.Name V.Version
230− | DFailed Pkg.Name V.Version
231− | DBuilt
232− | DBroken
233−
234−
235−detailsStep :: DMsg -> DState -> IO DState
236−detailsStep msg (DState total cached rqst rcvd failed built broken) =
237− case msg of
238− DStart numDependencies ->
239− return (DState numDependencies 0 0 0 0 0 0)
240−
241− DCached ->
242− putTransition (DState total (cached + 1) rqst rcvd failed built broken)
243−
244− DRequested ->
245− do when (rqst == 0) (putStrLn "Starting downloads...\n")
246− return (DState total cached (rqst + 1) rcvd failed built broken)
247−
248− DReceived pkg vsn ->
249− do putDownload goodMark pkg vsn
250− putTransition (DState total cached rqst (rcvd + 1) failed built broken)
251−
252− DFailed pkg vsn ->
253− do putDownload badMark pkg vsn
254− putTransition (DState total cached rqst rcvd (failed + 1) built broken)
255−
256− DBuilt ->
257− putBuilt (DState total cached rqst rcvd failed (built + 1) broken)
258−
259− DBroken ->
260− putBuilt (DState total cached rqst rcvd failed built (broken + 1))
261−
262−
263−putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
264−putDownload mark pkg vsn =
265− Help.toStdout $ D.indent 2 $
266− mark
267− <+> D.fromPackage pkg
268− <+> D.fromVersion vsn
269− <> "\n"
270−
271−
272−putTransition :: DState -> IO DState
273−putTransition state@(DState total cached _ rcvd failed built broken) =
274− if cached + rcvd + failed < total then
275− return state
276−
277− else
278− do let char = if rcvd + failed == 0 then '\r' else '\n'
279− putStrFlush (char : toBuildProgress (built + broken + failed) total)
280− return state
281−
282−
283−putBuilt :: DState -> IO DState
284−putBuilt state@(DState total cached _ rcvd failed built broken) =
285− do when (total == cached + rcvd + failed) $
286− putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
287− return state
288−
289−
290−toBuildProgress :: Int -> Int -> [Char]
291−toBuildProgress built total =
292− "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"
293−
294−
295−clear :: [Char] -> [Char] -> [Char]
296−clear before after =
297− '\r' : replicate (length before) ' ' ++ '\r' : after
298−
299−
300−
301−-- BUILD
302−
303−
304−type BKey = Key BMsg
305−
306−type BResult a = Either Exit.BuildProblem a
307−
308−
309−trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
310−trackBuild style callback =
311− case style of
312− Silent ->
313− callback (Key (\_ -> return ()))
314−
315− Json ->
316− callback (Key (\_ -> return ()))
317−
318− Terminal mvar ->
319− do chan <- newChan
320−
321− _ <- forkIO $
322− do takeMVar mvar
323− putStrFlush "Compiling ..."
324− buildLoop chan 0
325− putMVar mvar ()
326−
327− result <- callback (Key (writeChan chan . Left))
328− writeChan chan (Right result)
329− return result
330−
331−
332−data BMsg
333− = BDone
334−
335−
336−buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()
337−buildLoop chan done =
338− do msg <- readChan chan
339− case msg of
340− Left BDone ->
341− do let !done1 = done + 1
342− putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"
343− buildLoop chan done1
344−
345− Right result ->
346− let
347− !message = toFinalMessage done result
348− !width = 12 + length (show done)
349− in
350− putStrLn $
351− if length message < width
352− then '\r' : replicate width ' ' ++ '\r' : message
353− else '\r' : message
354−
355−
356−toFinalMessage :: Int -> BResult a -> [Char]
357−toFinalMessage done result =
358− case result of
359− Right _ ->
360− case done of
361− 0 -> "Success!"
362− 1 -> "Success! Compiled 1 module."
363− n -> "Success! Compiled " ++ show n ++ " modules."
364−
365− Left problem ->
366− case problem of
367− Exit.BuildBadModules _ _ [] ->
368− "Detected problems in 1 module."
369−
370− Exit.BuildBadModules _ _ (_:ps) ->
371− "Detected problems in " ++ show (2 + length ps) ++ " modules."
372−
373− Exit.BuildProjectProblem _ ->
374− "Detected a problem."
375−
376−
377−
378−-- GENERATE
379−
380−
381−reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
382−reportGenerate style names output =
383− case style of
384− Silent ->
385− return ()
386−
387− Json ->
388− return ()
389−
390− Terminal mvar ->
391− do readMVar mvar
392− let cnames = fmap ModuleName.toChars names
393− putStrLn ('\n' : toGenDiagram cnames output)
394−
395−
396−toGenDiagram :: NE.List [Char] -> FilePath -> [Char]
397−toGenDiagram (NE.List name names) output =
398− let
399− width = 3 + foldr (max . length) (length name) names
400− in
401− case names of
402− [] ->
403− toGenLine width name ('>' : ' ' : output ++ "\n")
404−
405− _:_ ->
406− unlines $
407− toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
408− : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
409−
410−
411−toGenLine :: Int -> [Char] -> [Char] -> [Char]
412−toGenLine width name end =
413− " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end
414−
415−
416−hbar :: Char
417−hbar = if isWindows then '-' else '─'
418−
419−vtop :: Char
420−vtop = if isWindows then '+' else '┬'
421−
422−vmiddle :: Char
423−vmiddle = if isWindows then '+' else '┤'
424−
425−vbottom :: Char
426−vbottom = if isWindows then '+' else '┘'
427−
428−
429−--
430−
431−
432−putStrFlush :: String -> IO ()
433−putStrFlush str =
434− 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+72−2018
@@ -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,2041 +8,116 @@ 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
46−import 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
11+import qualified Elm.Compiler.Module as Module
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−
21+import qualified Reporting.Exit.Http as Http
22+import qualified Reporting.Exit.Make as Make
23+import qualified Reporting.Exit.Install as Install
24+import qualified Reporting.Exit.Publish as Publish
23525
23626
237−-- BUMP
23827
28+-- ALL POSSIBLE ERRORS
23929
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
25030
31+data Exit
32+ = NoElmJson
33+ | Assets Asset.Exit
34+ | Bump Bump.Exit
35+ | Compile Compile.Exit [Compile.Exit]
36+ | Crawl Crawl.Exit
37+ | Cycle [Module.Raw] -- TODO write docs to help with this scenario
38+ | Deps Deps.Exit
39+ | Diff Diff.Exit
40+ | Make Make.Exit
41+ | Install Install.Exit
42+ | Publish Publish.Exit
43+ | BadHttp String Http.Exit
25144
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
38945
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"
591−
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− ]
625−
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
647−
648− PublishZipNoExposed ->
649− badZipReport
650−
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− ]
676−
677−
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− ]
688−
689−
690−
691−-- DOCS
692−
693−
694−data DocsProblem
695− = DP_Http Http.Error
696− | DP_Data String BS.ByteString
697− | DP_Cache
69846
47+-- RENDERERS
69948
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
70549
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− ]
50+toString :: Exit -> String
51+toString exit =
52+ Help.toString (Help.reportToDoc (toReport exit))
73253
73354
55+toStderr :: Exit -> IO ()
56+toStderr exit =
57+ Help.toStderr (Help.reportToDoc (toReport exit))
73458
735−-- INSTALL
73659
60+toJson :: Exit -> Encode.Value
61+toJson exit =
62+ Help.reportToJson (toReport exit)
73763
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
75164
752−
753−installToReport :: Install -> Help.Report
754−installToReport exit =
65+toReport :: Exit -> Help.Report
66+toReport exit =
75567 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."
68+ NoElmJson ->
69+ Help.report "WELCOME" Nothing
70+ "It looks like you are trying to start a new Elm project. Very exciting! :D"
128371 [ 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" <> "."
72+ ["I","very","highly","recommend","working","through"
73+ ,D.green "<https://guide.elm-lang.org>","which","will","teach","you","the"
74+ ,"basics","of","Elm,","including","how","to","start","new","projects."
128675 ]
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
131376 , 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!"
77+ ["For","folks","who","have","already","built","stuff","with","Elm,","the"
78+ ,"problem","is","just","that","there","is","no",D.dullyellow "elm.json","yet."
79+ ,"If","you","want","to","work","from","an","example,","check","out","the"
80+ ,"one","at","<https://github.com/evancz/elm-todomvc/blob/master/elm.json>"
155081 ]
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!"
82+ , D.reflow
83+ "Whatever your scenario, I hope you have a lovely time using Elm!"
157184 ]
157285
86+ Assets assetExit ->
87+ Asset.toReport assetExit
157388
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)
89+ Bump bumpExit ->
90+ Bump.toReport bumpExit
158291
92+ Compile e es ->
93+ Help.compilerReport e es
158394
95+ Crawl crawlExit ->
96+ Crawl.toReport crawlExit
158497
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 ->
1605− Help.report "NO elm.json FILE" Nothing
1606− "It looks like you are starting a new Elm project. Very exciting! Try running:"
1607− [ D.indent 4 $ D.green $ "elm init"
1608− , D.reflow $
1609− "It will help you get set up. It is really simple!"
1610− ]
1611−
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− ]
1819−
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− ]
1846−
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− ]
1864−
1865− BP_CannotLoadDependencies ->
1866− corruptCacheReport
1867−
1868− BP_Cycle name names ->
98+ Cycle names ->
186999 Help.report "IMPORT CYCLE" Nothing
1870100 "Your module imports form a cycle:"
1871− [ D.cycle 4 name names
101+ [ D.cycle 4 names
1872102 , D.reflow $
1873103 "Learn more about why this is disallowed and how to break cycles here:"
1874104 ++ D.makeLink "import-cycles"
1875105 ]
1876106
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
2052−
2053− ReplBadInput source err ->
2054− Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
107+ Deps depsExit ->
108+ Deps.toReport depsExit
2055109
2056− ReplBadLocalDeps root e es ->
2057− Help.compilerReport root e es
110+ Diff commandsExit ->
111+ Diff.toReport commandsExit
2058112
2059− ReplProjectProblem projectProblem ->
2060− toProjectProblemReport projectProblem
113+ Make makeExit ->
114+ Make.toReport makeExit
2061115
2062− ReplBadGenerate generate ->
2063− toGenerateReport generate
116+ Install installExit ->
117+ Install.toReport installExit
2064118
2065− ReplBadCache ->
2066− corruptCacheReport
119+ Publish publishExit ->
120+ Publish.toReport publishExit
2067121
2068− ReplBlocked ->
2069− corruptCacheReport
122+ BadHttp url httpExit ->
123+ Http.toReport url httpExit
builder/src/Reporting/Exit/Assets.hsnew file+231
@@ -0,0 +1,231 @@
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+ | BadDepDup String String Pkg.Name [Pkg.Name]
38+ | BadSrcDir FilePath
39+
40+
41+
42+-- TO REPORT
43+
44+
45+toReport :: Exit -> Help.Report
46+toReport exit =
47+ case exit of
48+ CorruptElmJson pkg vsn ->
49+ corruptJsonToReport "elm.json" pkg vsn
50+
51+ CorruptDocumentation pkg vsn ->
52+ corruptJsonToReport "docs.json" pkg vsn
53+
54+ CorruptBinary elmHome path ->
55+ Help.report "CORRUPT BINARY" (Just path)
56+ ("The binary data at " ++ path ++ " is corrupt.")
57+ [ D.reflow "Elm caches build artifacts in the following directories:"
58+ , D.dullyellow $ D.indent 4 $ D.vcat $
59+ [ D.fromString elmHome
60+ , "elm-stuff/"
61+ ]
62+ , D.reflow
63+ "Maybe you recently installed a command line tool or editor plugin that messes\
64+ \ with them? They definitely should not be doing that, but you never know! So\
65+ \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
66+ \ help reveal the corrupting influence."
67+ ]
68+
69+ BadElmJson problem ->
70+ elmJsonProblemToReport problem
71+
72+
73+
74+-- CORRUPT JSON
75+
76+
77+corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
78+corruptJsonToReport path pkg vsn =
79+ Help.report "CORRUPT JSON" Nothing
80+ ( "The " ++ path ++ " for " ++ Pkg.toString pkg
81+ ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
82+ )
83+ [ D.reflow $
84+ "I removed it from my file cache, so if it was some transient\
85+ \ error it should be fixed if you try the same thing again.\
86+ \ Please report this if it seems like an Elm problem though!"
87+ ]
88+
89+
90+
91+-- BAD ELM JSON
92+
93+
94+elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
95+elmJsonProblemToReport problem =
96+ case problem of
97+ BadJson doc ->
98+ Help.jsonReport "BAD JSON" (Just "elm.json") doc
99+
100+ BadSrcDir dir ->
101+ Help.report "BAD JSON" (Just "elm.json")
102+ "The \"source-directories\" in your elm.json lists the following directory:"
103+ [ D.indent 4 (D.dullyellow (D.fromString dir))
104+ , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
105+ ]
106+
107+ BadDepDup field1 field2 dup dups ->
108+ let
109+ packagesAre =
110+ if null dups then "package is" else "packages are"
111+
112+ advice =
113+ if null dups then
114+ "Delete one of the entries."
115+ else
116+ "Delete duplicates until each package lives in ONE category."
117+ in
118+ Help.report "BAD JSON" (Just "elm.json")
119+ (
120+ if null dups then
121+ "The following package appears twice in your elm.json file:"
122+ else
123+ "The following packages appear twice in your elm.json file:"
124+ )
125+ [ D.dullyellow $ D.indent 4 $ D.vcat $
126+ map (D.fromString . Pkg.toString) (dup:dups)
127+ , D.reflow $
128+ "The " ++ packagesAre ++ " available in \"" ++ field1
129+ ++ "\", so it is redundant to list it again in \"" ++ field2
130+ ++ "\". It is already available! " ++ advice
131+ , D.reflow "More help at <https://github.com/elm-lang/elm-package/blob/master/TODO>"
132+ ]
133+
134+
135+
136+-- PROBLEM TO DOCS
137+
138+
139+data BadElmJsonContent
140+ = BadType Text.Text
141+ | BadPkgName String
142+ | BadVersion Text.Text
143+ | BadConstraint String
144+ | BadModuleName Text.Text
145+ | BadModuleHeaderTooLong Text.Text
146+ | BadDependencyName Text.Text
147+ | BadLicense Text.Text [Text.Text]
148+ | BadDirectoryNotString
149+ | BadSummaryTooLong
150+
151+
152+badContentToDocs :: BadElmJsonContent -> [D.Doc]
153+badContentToDocs badContent =
154+ case badContent of
155+ BadType _ ->
156+ ["The","only","valid","types","of","elm.json","are"
157+ ,D.green "\"application\"","and",D.green "\"package\"" <> "."
158+ ]
159+
160+ BadPkgName problem ->
161+ map D.fromString (words problem)
162+
163+ BadVersion txt ->
164+ ["You","provided",D.red (D.fromString (show txt))
165+ ,"which","is","not","a","valid","version.","I","need","something","like"
166+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
167+ ]
168+
169+ BadConstraint problem ->
170+ map D.fromString (words ("It is not a valid constraint. " ++ problem))
171+
172+ BadModuleName name ->
173+ ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
174+ ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
175+ ]
176+
177+ BadModuleHeaderTooLong header ->
178+ ["The",D.fromString (show header),"header","is","too","long."
179+ ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
180+ ,"to","ensure","that","formatting","is","nice","on","the","package","website."
181+ ]
182+
183+ BadDependencyName name ->
184+ ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
185+ ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
186+ ,"the","package","website,","and","installing","it","with","the"
187+ ,D.green "`elm install`","command","instead."
188+ ]
189+
190+ BadLicense _given suggestions ->
191+ case suggestions of
192+ [] ->
193+ ["I","need","an","OSI","approved","SPDX","license,","like"
194+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
195+ ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
196+ ]
197+
198+ code:codes ->
199+ ["I","need","an","OSI","approved","SPDX","license."]
200+ ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
201+ ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
202+
203+ BadDirectoryNotString ->
204+ ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
205+ ]
206+
207+ BadSummaryTooLong ->
208+ ["Your","summary","is","too","long.","I","need","it","to"
209+ ,"be",D.green "under",D.green "80",D.green "characters."
210+ ]
211+
212+
213+oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
214+oneOf code codes =
215+ let
216+ toDoc spdx =
217+ D.green (D.fromString (show spdx))
218+ in
219+ case codes of
220+ [] ->
221+ [toDoc code]
222+
223+ [code2] ->
224+ [toDoc code,"or",toDoc code2]
225+
226+ _:_ ->
227+ let
228+ these = code : init codes
229+ final = last codes
230+ in
231+ 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.Package as Pkg
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 Pkg.Version [Pkg.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.fromText (Pkg.versionToText 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.fromText . Pkg.versionToText) versions
51+ ]
builder/src/Reporting/Exit/Compile.hsnew file+105
@@ -0,0 +1,105 @@
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.Text as Text
13+import qualified Data.Time.Clock as Time
14+
15+import qualified Elm.Compiler as Compiler
16+import qualified Elm.Compiler.Module as Module
17+import qualified Json.Encode as Encode
18+import qualified Reporting.Doc as D
19+
20+
21+
22+-- EXITS
23+
24+
25+data Exit =
26+ Exit
27+ { _name :: Module.Raw
28+ , _path :: FilePath
29+ , _time :: Time.UTCTime
30+ , _source :: Text.Text
31+ , _errors :: [Compiler.Error]
32+ }
33+
34+
35+
36+-- TO JSON
37+
38+
39+toJson :: Exit -> Encode.Value
40+toJson (Exit name path _ source errors) =
41+ Compiler.errorsToJson name path source errors
42+
43+
44+
45+-- TO DOC
46+
47+
48+toDoc :: Exit -> [Exit] -> D.Doc
49+toDoc e es =
50+ let
51+ (exit, exits) = sortByTime e es
52+ in
53+ D.vcat (toDocHelp exit exits)
54+
55+
56+toDocHelp :: Exit -> [Exit] -> [D.Doc]
57+toDocHelp e1 exits =
58+ case exits of
59+ [] ->
60+ [exitToDoc e1]
61+
62+ e2 : otherErrors ->
63+ exitToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors
64+
65+
66+exitToDoc :: Exit -> D.Doc
67+exitToDoc (Exit _name path _time source errors) =
68+ Compiler.errorsToDoc path source errors
69+
70+
71+separator :: Module.Raw -> Module.Raw -> D.Doc
72+separator beforeName afterName =
73+ let
74+ before = Module.nameToString beforeName ++ " ↑ "
75+ after = " ↓ " ++ Module.nameToString afterName
76+ in
77+ D.dullred $ D.vcat $
78+ [ D.indent (80 - length before) (D.fromString before)
79+ , "====o======================================================================o===="
80+ , D.fromString after
81+ , D.empty
82+ , D.empty
83+ ]
84+
85+
86+
87+-- SORT BY TIME
88+
89+
90+sortByTime :: Exit -> [Exit] -> (Exit, [Exit])
91+sortByTime exit exits =
92+ case List.sortBy timeCompare exits of
93+ [] ->
94+ (exit, [])
95+
96+ e:es ->
97+ if _time exit < _time e then
98+ (exit, e:es)
99+ else
100+ (e, List.insertBy timeCompare exit es)
101+
102+
103+timeCompare :: Exit -> Exit -> Ordering
104+timeCompare e1 e2 =
105+ compare (_time e1) (_time e2)
builder/src/Reporting/Exit/Crawl.hsnew file+326
@@ -0,0 +1,326 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Crawl
3+ ( Exit(..)
4+ , Problem(..)
5+ , Origin(..)
6+ , toReport
7+ )
8+ where
9+
10+
11+import qualified Data.ByteString as BS
12+import qualified Data.Char as Char
13+import qualified Data.Map as Map
14+import qualified Data.Text.Encoding as Text
15+import qualified Data.Time.Clock as Time
16+
17+import qualified Elm.Compiler as Compiler
18+import qualified Elm.Compiler.Module as Module
19+import qualified Elm.Package as Pkg
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 Module.Raw [FilePath]
33+ | RootNameless FilePath
34+ | DependencyProblems Problem [Problem]
35+ | BadKernelHeader FilePath
36+
37+
38+data Problem
39+ = ModuleNotFound Origin Module.Raw [FilePath]
40+ | ModuleAmbiguous Origin Module.Raw [FilePath] [Pkg.Package]
41+ | BadHeader FilePath Time.UTCTime BS.ByteString Compiler.Error
42+ | ModuleNameReservedForKernel Origin Module.Raw
43+ | ModuleNameMissing FilePath Module.Raw
44+ | ModuleNameMismatch
45+ FilePath
46+ Module.Raw -- expected
47+ Module.Raw -- actual
48+ | PortsInPackage FilePath Module.Raw
49+ | EffectsUnexpected FilePath Module.Raw
50+
51+
52+data Origin
53+ = ElmJson
54+ | File FilePath
55+ | Module FilePath Module.Raw
56+
57+
58+
59+-- TO REPORT
60+
61+
62+toReport :: Exit -> Help.Report
63+toReport exit =
64+ case exit of
65+ RootFileNotFound path ->
66+ Help.report "FILE NOT FOUND" Nothing
67+ "You want me to compile this file:"
68+ [ D.indent 4 $ D.dullyellow $ D.fromString path
69+ , "I cannot find it though! Is there a typo?"
70+ ]
71+
72+ RootModuleNameDuplicate name paths ->
73+ Help.report "DUPLICATE NAMES" Nothing
74+ "I am trying to compile multiple modules with the same name:"
75+ [ D.indent 4 $ D.dullyellow $ D.vcat $
76+ map D.fromString paths
77+ , D.fillSep $
78+ [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
79+ , "to", "be", "named", D.dullyellow (D.fromString (Module.nameToString name)) <> "."
80+ , "Change", "them", "to", "have", "unique", "names", "and", "you"
81+ , "should", "be", "all", "set!"
82+ ]
83+ ]
84+
85+ RootNameless path ->
86+ namelessToDoc path "Main"
87+
88+ DependencyProblems problem otherProblems ->
89+ case otherProblems of
90+ [] ->
91+ problemToReport problem
92+
93+ _ ->
94+ problemToReport problem
95+ -- error "TODO handle multiple dependency errors"
96+
97+ BadKernelHeader filePath ->
98+ Help.report "BAD KERNEL HEADER" Nothing
99+ "I ran into a bad header in this file:"
100+ [ D.indent 4 $ D.dullyellow $ D.fromString filePath
101+ , D.reflow $
102+ "NOTE: Kernel code is only available to core Elm libraries to ensure\
103+ \ the portability and security of the Elm ecosystem. This restriction\
104+ \ also makes it possible to improve code gen (i.e. performance) without\
105+ \ disrupting the ecosystem."
106+ ]
107+
108+
109+
110+-- PROBLEM TO REPORT
111+
112+
113+problemToReport :: Problem -> Help.Report
114+problemToReport problem =
115+ case problem of
116+ ModuleNotFound origin name dirs ->
117+ notFoundToDoc origin name dirs
118+
119+ ModuleAmbiguous origin child paths pkgs ->
120+ ambiguousToDoc origin child paths pkgs
121+
122+ BadHeader path time source compilerError ->
123+ let
124+ compilerExit =
125+ Compile.Exit "???" path time (Text.decodeUtf8 source) [compilerError]
126+ in
127+ Help.compilerReport compilerExit []
128+
129+ ModuleNameMissing path name ->
130+ namelessToDoc path name
131+
132+ ModuleNameMismatch path expected actual ->
133+ Help.report "MODULE NAME MISMATCH" (Just path)
134+ ( "The file at " ++ path ++ " has a typo in the module name. It says:"
135+ )
136+ [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromString (Module.nameToString actual)) <+> "exposing (..)"
137+ , "Looks like a typo or copy/paste error. Instead it needs to say:"
138+ , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromString (Module.nameToString expected)) <+> "exposing (..)"
139+ , "Make the change and you should be all set!"
140+ ]
141+
142+ ModuleNameReservedForKernel origin name ->
143+ kernelNameToDoc origin name
144+
145+ PortsInPackage path name ->
146+ badTagToDoc path name "port" "port-modules" $
147+ "Packages cannot have any `port` modules."
148+
149+ EffectsUnexpected path name ->
150+ badTagToDoc path name "effect" "effect-modules" $
151+ "Creating `effect` modules is relatively experimental. There are a\
152+ \ couple in @elm-lang repos right now, but we have decided to be\
153+ \ very cautious in expanding its usage."
154+
155+
156+badTagToDoc :: FilePath -> Module.Raw -> String -> String -> String -> Help.Report
157+badTagToDoc path name tag hintName summary =
158+ Help.report
159+ ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
160+ (Just path)
161+ summary
162+ [ D.fillSep $
163+ [ "Get", "rid", "of", "all", "the"
164+ , D.red (D.fromString tag)
165+ , "stuff", "in"
166+ , D.dullyellow (D.fromString (Module.nameToString name))
167+ , "to", "proceed."
168+ ]
169+ , D.toSimpleNote $
170+ "You can learn the reasoning behind this design choice at "
171+ ++ D.makeLink hintName
172+ ]
173+
174+
175+
176+-- HELPERS
177+
178+
179+namelessToDoc :: FilePath -> Module.Raw -> Help.Report
180+namelessToDoc path name =
181+ Help.report "UNNAMED MODULE" (Just path)
182+ ( "The `" ++ Module.nameToString name
183+ ++ "` module must start with a line like this:"
184+ )
185+ [ D.indent 4 $ D.dullyellow $ D.fromString $
186+ "module " ++ Module.nameToString name ++ " exposing (..)"
187+ , D.reflow $
188+ "Try adding that as the first line of your file!"
189+ , D.toSimpleNote $
190+ "It is best to replace (..) with an explicit list of types and\
191+ \ functions you want to expose. If you know a value is only used\
192+ \ WITHIN this module, it is extra easy to refactor. This kind of\
193+ \ information is great, especially as your project grows!"
194+ ]
195+
196+
197+notFoundToDoc :: Origin -> Module.Raw -> [FilePath] -> Help.Report
198+notFoundToDoc origin child dirs =
199+ case origin of
200+ ElmJson ->
201+ Help.report "MODULE NOT FOUND" (Just "elm.json")
202+ "Your elm.json says your project has the following module:"
203+ [ D.indent 4 $ D.red $ D.fromString $ Module.nameToString child
204+ , D.reflow $
205+ "When creating packages, all modules must live in the\
206+ \ src/ directory, but I cannot find it there."
207+ ]
208+
209+ File path ->
210+ Help.report "UNKNOWN IMPORT" (Just path)
211+ ("I cannot find a `" ++ Module.nameToString child ++ "` module to import.")
212+ (notFoundDetails child dirs)
213+
214+ Module path parent ->
215+ Help.report "UNKNOWN IMPORT" (Just path)
216+ ("The " ++ Module.nameToString parent ++ " module has a bad import:")
217+ (notFoundDetails child dirs)
218+
219+
220+notFoundDetails :: Module.Raw -> [FilePath] -> [D.Doc]
221+notFoundDetails child dirs =
222+ let
223+ simulatedCode =
224+ D.indent 4 $ D.red $ D.fromString $ "import " ++ Module.nameToString child
225+ in
226+ case Map.lookup child Pkg.suggestions of
227+ Just pkg ->
228+ [ simulatedCode
229+ , D.reflow $
230+ "Do you want the one from the " ++ Pkg.toString pkg
231+ ++ " package? If so, run this command to add that dependency to your elm.json file:"
232+ , D.indent 4 $ D.green $ D.fromString $ "elm install " ++ Pkg.toString pkg
233+ , D.reflow $
234+ "If you want a local file, make sure the directory that contains the `"
235+ ++ Module.nameToString child
236+ ++ "` module is listed in your elm.json \"source-directories\" field."
237+ ]
238+
239+ Nothing ->
240+ [ simulatedCode
241+ , "I cannot find that module! Is there a typo in the module name?"
242+ , D.reflow $
243+ case dirs of
244+ [] ->
245+ "The \"source-directories\" field of your elm.json is empty, so I only\
246+ \ searched in packages. Maybe you need to add a \"src\" directory there?"
247+
248+ [dir] ->
249+ "The \"source-directories\" field of your elm.json tells me to only look in the "
250+ ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
251+
252+ dir:_:_ ->
253+ "The \"source-directories\" field of your elm.json tells me to look in directories like "
254+ ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
255+ ]
256+
257+
258+ambiguousToDoc :: Origin -> Module.Raw -> [FilePath] -> [Pkg.Package] -> Help.Report
259+ambiguousToDoc origin child paths pkgs =
260+ let
261+ pkgToString (Pkg.Package pkg vsn) =
262+ "exposed by " ++ Pkg.toString pkg ++ " " ++ Pkg.versionToString vsn
263+
264+ makeReport maybePath summary yellowString =
265+ Help.report "AMBIGUOUS IMPORT" maybePath summary
266+ [ D.indent 4 $ D.dullyellow $ D.fromString yellowString
267+ , D.reflow $
268+ "I found multiple module with that name though:"
269+ , D.indent 4 $ D.dullyellow $ D.vcat $
270+ map D.fromString $ paths ++ map pkgToString pkgs
271+ , D.reflow $
272+ if null paths then
273+ "It looks like the name clash is in your dependencies, which is\
274+ \ out of your control. Elm does not support this scenario right\
275+ \ now, but it may be worthwhile. Please open an issue describing\
276+ \ your scenario so we can gather more usage information!"
277+ else
278+ "Which is the right one? Try renaming your modules to have unique names."
279+ ]
280+ in
281+ case origin of
282+ ElmJson ->
283+ makeReport
284+ Nothing
285+ "Your elm.json wants the following module:"
286+ (Module.nameToString child)
287+
288+ File path ->
289+ makeReport
290+ (Just path)
291+ ("The file at " ++ path ++ " has an ambiguous import:")
292+ ("import " ++ Module.nameToString child)
293+
294+ Module path parent ->
295+ makeReport
296+ (Just path)
297+ ("The " ++ Module.nameToString parent ++ " module has an ambiguous import:")
298+ ("import " ++ Module.nameToString child)
299+
300+
301+kernelNameToDoc :: Origin -> Module.Raw -> Help.Report
302+kernelNameToDoc origin kernelName =
303+ let
304+ (maybePath, statement) =
305+ case origin of
306+ ElmJson ->
307+ ( Nothing
308+ , "Your elm.json says your project has the following module:"
309+ )
310+
311+ File path ->
312+ ( Just path
313+ , "This file is trying to import the following module:"
314+ )
315+
316+ Module path parent ->
317+ ( Just path
318+ , "Your " ++ Module.nameToString parent ++ " module is trying to import:"
319+ )
320+ in
321+ Help.report "BAD MODULE NAME" maybePath statement
322+ [ D.indent 4 $ D.dullyellow $ D.fromString $ Module.nameToString kernelName
323+ , D.reflow $
324+ "But names like that are reserved for internal use.\
325+ \ Switch to a name outside of the Elm/Kernel/ namespace."
326+ ]
builder/src/Reporting/Exit/Deps.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Deps
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Compiler as Compiler
10+import qualified Elm.Package as Pkg
11+import qualified Elm.Project.Constraint as Con
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+ | AppBadElm Pkg.Version
26+ | PkgBadElm Con.Constraint
27+ | BadDeps
28+ | BuildFailure FilePath Pkg.Name Pkg.Version
29+
30+
31+
32+-- TO DOC
33+
34+
35+toReport :: Exit -> Help.Report
36+toReport exit =
37+ case exit of
38+ CorruptVersionCache elmHome pkg ->
39+ Help.report "CORRUPT CACHE" Nothing
40+ ( "I ran into an unknown package while exploring dependencies:"
41+ )
42+ [ D.indent 4 $ D.dullyellow $ D.fromString $ Pkg.toString pkg
43+ , D.reflow $
44+ "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
45+ \ Maybe some program is messing with it? It is just cached files,\
46+ \ so you can delete it and see if that fixes the issue."
47+ ]
48+
49+ PackageNotFound package suggestions ->
50+ Help.docReport "PACKAGE NOT FOUND" Nothing
51+ ( D.fillSep
52+ ["I","cannot","find","a"
53+ ,D.red (D.fromString (Pkg.toString package))
54+ ,"package","on","the","package","website."
55+ ]
56+ )
57+ [ "Maybe you want one of these instead?"
58+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromString . Pkg.toString) suggestions
59+ , "But check <https://package.elm-lang.org> to see all possibilities!"
60+ ]
61+
62+ AppBadElm version ->
63+ Help.report "ELM VERSION MISMATCH" Nothing
64+ "Your elm.json says this application needs a different version of Elm."
65+ [ D.fillSep
66+ [ "It", "requires"
67+ , D.green (D.fromString (Pkg.versionToString version)) <> ","
68+ , "but", "you", "are", "using"
69+ , D.red (D.fromString (Pkg.versionToString Compiler.version))
70+ , "right", "now."
71+ ]
72+ ]
73+
74+ PkgBadElm constraint ->
75+ Help.report "ELM VERSION MISMATCH" Nothing
76+ "Your elm.json says this package needs a version of Elm in this range:"
77+ [ D.indent 4 $ D.dullyellow $ D.fromString $ Con.toString constraint
78+ , D.fillSep
79+ [ "But", "you", "are", "using", "Elm"
80+ , D.red (D.fromString (Pkg.versionToString Compiler.version))
81+ , "right", "now."
82+ ]
83+ ]
84+
85+ BadDeps ->
86+ Help.report "CLASHING PACKAGE DEPENDENCIES" Nothing
87+ "The dependencies in your elm.json are not compatible."
88+ [ D.reflow $
89+ "Did you change them by hand? Try to change it back! It is much\
90+ \ better to add dependencies with commands like this:"
91+ , D.indent 4 $ D.dullyellow "elm install elm-lang/http"
92+ , D.reflow $
93+ "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
94+ \ you are running into something that seems trickier than this."
95+ ]
96+
97+ BuildFailure elmHome pkg vsn ->
98+ Help.report "CORRUPT DEPENDENCY" Nothing
99+ "I ran into a problem while building the following package:"
100+ [ D.indent 4 $ D.red $ D.fromString $ Pkg.toString pkg ++ " " ++ Pkg.versionToString vsn
101+ , D.fillSep
102+ ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
103+ ,"Try","deleting",D.dullyellow (D.fromString elmHome),"(a","directory","for"
104+ ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
105+ ]
106+ ]
builder/src/Reporting/Exit/Diff.hsnew file+66
@@ -0,0 +1,66 @@
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 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+ | UnknownPackage Pkg.Name [Pkg.Name]
23+ | UnknownVersion Pkg.Name Pkg.Version [Pkg.Version]
24+
25+
26+
27+-- TO DOC
28+
29+
30+toReport :: Exit -> Help.Report
31+toReport exit =
32+ case exit of
33+ Application ->
34+ Help.report "CANNOT DIFF APPLICATIONS" Nothing
35+ "I cannot perform diffs on applications, only packages! If you are\
36+ \ just curious to see a diff, try running this command:"
37+ [ D.indent 4 $ D.green $ "elm diff elm-lang/html 5.1.1 6.0.0"
38+ ]
39+
40+ UnknownPackage pkg suggestions ->
41+ Help.report "UNKNOWN PACKAGE" Nothing
42+ ( "I cannot find a package called:"
43+ )
44+ [ D.indent 4 $ D.red $ D.fromText $ Pkg.toText pkg
45+ , "Maybe you want one of these instead?"
46+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromText . Pkg.toText) suggestions
47+ , "But check <https://package.elm-lang.org> to see all possibilities!"
48+ ]
49+
50+ UnknownVersion _pkg vsn realVersions ->
51+ Help.docReport "UNKNOWN VERSION" Nothing
52+ ( D.fillSep $
53+ [ "Version", D.red (D.fromText (Pkg.versionToText vsn))
54+ , "has", "never", "been", "published,", "so", "I"
55+ , "cannot", "diff", "against", "it."
56+ ]
57+ )
58+ [ "Here are all the versions that HAVE been published:"
59+ , D.indent 4 $ D.dullyellow $ D.vcat $
60+ let
61+ sameMajor v1 v2 = Pkg._major v1 == Pkg._major v2
62+ mkRow vsns = D.hsep $ map (D.fromText . Pkg.versionToText) vsns
63+ in
64+ map mkRow $ List.groupBy sameMajor (List.sort realVersions)
65+ , "Want one of those instead?"
66+ ]
builder/src/Reporting/Exit/Help.hs+18−18
@@ -14,14 +14,14 @@ module Reporting.Exit.Help
1414 where
1515
1616
17+import qualified Data.Text as Text
1718import GHC.IO.Handle (hIsTerminalDevice)
1819import System.IO (Handle, hPutStr, stderr, stdout)
1920
20−import qualified Json.Encode as E
21−import Json.Encode ((==>))
21+import qualified Json.Encode as Encode
2222import Reporting.Doc ((<+>))
2323import qualified Reporting.Doc as D
24−import qualified Reporting.Error as Error
24+import qualified Reporting.Exit.Compile as Compile
2525
2626
2727
@@ -29,7 +29,7 @@ import qualified Reporting.Error as Error
2929
3030
3131data Report
32− = CompilerReport FilePath Error.Module [Error.Module]
32+ = CompilerReport Compile.Exit [Compile.Exit]
3333 | Report
3434 { _title :: String
3535 , _path :: Maybe FilePath
@@ -52,7 +52,7 @@ jsonReport =
5252 Report
5353
5454
55−compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
55+compilerReport :: Compile.Exit -> [Compile.Exit] -> Report
5656compilerReport =
5757 CompilerReport
5858
@@ -64,8 +64,8 @@ compilerReport =
6464reportToDoc :: Report -> D.Doc
6565reportToDoc report_ =
6666 case report_ of
67− CompilerReport root e es ->
68− Error.toDoc root e es
67+ CompilerReport e es ->
68+ Compile.toDoc e es
6969
7070 Report title maybePath message ->
7171 let
@@ -82,7 +82,7 @@ reportToDoc report_ =
8282
8383 errorBar =
8484 D.dullcyan $
85− "--" <+> D.fromChars title <+> D.fromChars errorBarEnd
85+ "--" <+> D.fromString title <+> D.fromString errorBarEnd
8686 in
8787 D.stack [errorBar, message, ""]
8888
@@ -91,21 +91,21 @@ reportToDoc report_ =
9191-- TO JSON
9292
9393
94−reportToJson :: Report -> E.Value
94+reportToJson :: Report -> Encode.Value
9595reportToJson report_ =
9696 case report_ of
97− CompilerReport _ e es ->
98− E.object
99− [ "type" ==> E.chars "compile-errors"
100− , "errors" ==> E.list Error.toJson (e:es)
97+ CompilerReport e es ->
98+ Encode.object
99+ [ ("type", Encode.text "compile-errors")
100+ , ("errors", Encode.list Compile.toJson (e:es))
101101 ]
102102
103103 Report title maybePath message ->
104− E.object
105− [ "type" ==> E.chars "error"
106− , "path" ==> maybe E.null E.chars maybePath
107− , "title" ==> E.chars title
108− , "message" ==> D.encode message
104+ Encode.object
105+ [ ("type", Encode.text "error")
106+ , ("path", maybe Encode.null (Encode.text . Text.pack) maybePath)
107+ , ("title", Encode.text (Text.pack title))
108+ , ("message", D.encode message)
109109 ]
110110
111111
builder/src/Reporting/Exit/Http.hsnew file+101
@@ -0,0 +1,101 @@
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 $
64+ "I was expecting the hash of content to be " ++ expectedHash
65+ ++ ", but it is " ++ actualHash
66+ , D.reflow $
67+ "Most likely the package author may have moved the version\
68+ \ tag, so report it to them and see if that is the issue."
69+ ]
70+
71+
72+
73+-- BAD JSON
74+
75+
76+data BadJson
77+ = BadNewPkg Text.Text
78+ | BadAllPkg Text.Text String
79+ | BadAllVsn Text.Text
80+
81+
82+badJsonToDocs :: BadJson -> [D.Doc]
83+badJsonToDocs badJson =
84+ case badJson of
85+ BadNewPkg txt ->
86+ ["I","ran","into",D.red (D.fromString (show txt)) <> ","
87+ ,"but","I","need","entries","like"
88+ ,D.green "\"elm-lang/core@6.0.0\"" <> "."
89+ ]
90+
91+ BadAllPkg txt suggestion ->
92+ ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
93+ ]
94+ ++ map D.fromString (words suggestion)
95+
96+ BadAllVsn txt ->
97+ ["You","provided",D.red (D.fromString (show txt))
98+ ,"which","is","not","a","valid","version.","I","need","something","like"
99+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
100+ ]
101+
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.Compiler as Compiler
10+import qualified Elm.Package as Pkg
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-lang/http"
36+ , "elm install elm-lang/json"
37+ , "elm install elm-lang/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.fromString 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 " ++ Pkg.versionToString Compiler.version ++ " right now:"
69+ )
70+ [ D.indent 4 $ D.vcat $ map (D.red . D.fromString . 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.Compiler.Module as Module
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 Module.Raw [Module.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 MyThing.elm"
36+ , D.indent 4 $ D.green "elm make This.elm 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.fromString . Module.nameToString) (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.Package as Pkg
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 Pkg.Version
23+ | AlreadyPublished Pkg.Version
24+ | InvalidBump Pkg.Version Pkg.Version
25+ | BadBump Pkg.Version Pkg.Version Magnitude Pkg.Version Magnitude
26+ | NoSummary
27+ | NoExposed
28+ | NoReadme
29+ | ShortReadme
30+ | NoLicense
31+ | MissingTag Pkg.Version
32+ | NoGit
33+ | LocalChanges Pkg.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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString new)) <> ","
104+ ,"indicating","a",D.fromString (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.fromString $
110+ "elm diff " ++ Pkg.versionToString old
111+
112+ , D.fillSep $
113+ ["This","command","says","this","is","a"
114+ ,D.fromString (magnitudeToString realMagnitude)
115+ ,"change,","so","the","next","version","should","be"
116+ ,D.green (D.fromString (Pkg.versionToString 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 = Pkg.versionToString 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.fromString 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.fromString $
185+ [ "git tag -a alpha-" ++ vsn ++ " -m \"preparing for Elm 0.19\""
186+ , "git push origin alpha-" ++ 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 = Pkg.versionToString version in
206+ Help.docReport "LOCAL CHANGES" Nothing
207+ ( D.fillSep $
208+ [ "The", "code", "tagged", "as", D.green (D.fromString 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/Progress.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Reporting.Progress
3+ ( Reporter(..)
4+ , makeReporter
5+ , silentReporter
6+ , Msg(..)
7+ , Progress(..)
8+ , Outcome(..)
9+ , PublishPhase(..)
10+ , BumpPhase(..)
11+ )
12+ where
13+
14+
15+import Control.Concurrent.Chan (Chan, writeChan)
16+import Control.Concurrent.MVar (MVar, readMVar)
17+import qualified Elm.Compiler.Module as Module
18+import Deps.Diff (Magnitude)
19+import Elm.Package (Name, Version)
20+import Reporting.Exit (Exit)
21+
22+
23+
24+-- REPORTER
25+
26+
27+data Reporter =
28+ Reporter
29+ { _tell :: Progress -> IO ()
30+ , _end :: Maybe Exit -> IO ()
31+ }
32+
33+
34+makeReporter :: Chan Msg -> MVar () -> Reporter
35+makeReporter chan mvar =
36+ let
37+ tell progress =
38+ writeChan chan (Progress progress)
39+
40+ end maybeError =
41+ do writeChan chan (End maybeError)
42+ readMVar mvar
43+ in
44+ Reporter tell end
45+
46+
47+silentReporter :: Reporter
48+silentReporter =
49+ Reporter
50+ (\_ -> return ())
51+ (\_ -> return ())
52+
53+
54+
55+-- MESSAGES
56+
57+
58+data Msg = Progress Progress | End (Maybe Exit)
59+
60+
61+data Progress
62+ -- download packages
63+ = DownloadSkip
64+ | DownloadStart [(Name, Version)]
65+ | DownloadPkgStart Name Version
66+ | DownloadPkgEnd Name Version Outcome
67+ | DownloadEnd Outcome
68+
69+ -- build dependencies
70+ | BuildDepsStart Int
71+ | BuildDepsProgress
72+ | BuildDepsEnd
73+
74+ -- compile files
75+ | CompileStart Int
76+ | CompileFileStart Module.Raw
77+ | CompileFileEnd Module.Raw Outcome
78+ | CompileEnd
79+
80+ -- publish
81+ | PublishStart Name Version (Maybe [Version])
82+ | PublishCheckBump Version BumpPhase
83+ | PublishProgress PublishPhase (Maybe Outcome)
84+ | PublishEnd
85+
86+ -- solver
87+ | UnableToLoadLatestPackages
88+
89+
90+data Outcome = Good | Bad
91+
92+
93+data PublishPhase
94+ = CheckReadme
95+ | CheckLicense
96+ | CheckTag Version
97+ | CheckDownload
98+ | CheckBuild
99+ | CheckChanges
100+
101+
102+data BumpPhase
103+ = StatedVersion
104+ | GoodStart
105+ | GoodBump Version Magnitude
106+ | BadBump
builder/src/Reporting/Progress/Bar.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Reporting.Progress.Bar
3+ ( render
4+ , clear
5+ )
6+ where
7+
8+
9+
10+-- PROGRESS BAR
11+
12+
13+width :: Float
14+width =
15+ 50.0
16+
17+
18+render :: Int -> Int -> Int -> String
19+render successes failures total =
20+ let
21+ numDone =
22+ successes + failures
23+
24+ fraction =
25+ fromIntegral numDone / fromIntegral total
26+
27+ unitsDone =
28+ truncate (fraction * width)
29+
30+ unitsLeft =
31+ truncate width - unitsDone
32+ in
33+ "\r["
34+ ++ replicate unitsDone '='
35+ ++ replicate unitsLeft ' '
36+ ++ "] - "
37+ ++ show numDone ++ " / " ++ show total
38+
39+
40+clear :: String
41+clear =
42+ '\r' : replicate (length (render 49999 50000 99999)) ' ' ++ "\r"
43+
builder/src/Reporting/Progress/Json.hsnew file+31
@@ -0,0 +1,31 @@
1+module Reporting.Progress.Json
2+ ( reporter
3+ )
4+ where
5+
6+
7+import qualified Data.ByteString.Builder as B
8+import System.IO (stderr)
9+
10+import qualified Reporting.Exit as Exit
11+import qualified Reporting.Progress as Progress
12+import qualified Json.Encode as Encode
13+
14+
15+
16+-- REPORTER
17+
18+
19+reporter :: Progress.Reporter
20+reporter =
21+ Progress.Reporter (\_ -> return ()) end
22+
23+
24+end :: Maybe Exit.Exit -> IO ()
25+end maybeExit =
26+ case maybeExit of
27+ Just exit ->
28+ B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson exit))
29+
30+ Nothing ->
31+ return ()
builder/src/Reporting/Progress/Repl.hsnew file+27
@@ -0,0 +1,27 @@
1+module Reporting.Progress.Repl
2+ ( reporter
3+ )
4+ where
5+
6+
7+import qualified Reporting.Exit as Exit
8+import qualified Reporting.Progress as Progress
9+
10+
11+
12+-- REPORTER
13+
14+
15+reporter :: Progress.Reporter
16+reporter =
17+ Progress.Reporter (\_ -> return ()) end
18+
19+
20+end :: Maybe Exit.Exit -> IO ()
21+end maybeExit =
22+ case maybeExit of
23+ Just exit ->
24+ Exit.toStderr exit
25+
26+ Nothing ->
27+ return ()
builder/src/Reporting/Progress/Terminal.hsnew file+360
@@ -0,0 +1,360 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Progress.Terminal
3+ ( create
4+ , newPackageOverview
5+ )
6+ where
7+
8+
9+import Control.Concurrent (forkIO)
10+import Control.Concurrent.Chan (Chan, newChan, readChan)
11+import Control.Concurrent.MVar (newEmptyMVar, putMVar)
12+import qualified System.Info as Info
13+import System.IO (hFlush, hPutStr, stdout)
14+import qualified Elm.Package as Pkg
15+import Elm.Package (Name, Version)
16+
17+import qualified Deps.Diff as Diff
18+import Reporting.Doc ((<>), (<+>))
19+import qualified Reporting.Doc as D
20+import qualified Reporting.Exit as Exit
21+import qualified Reporting.Exit.Help as Help
22+import Reporting.Progress (Msg(..), Progress(..), Outcome(..), PublishPhase(..), BumpPhase(..))
23+import qualified Reporting.Progress as Progress
24+import qualified Reporting.Progress.Bar as Bar
25+
26+
27+
28+-- CREATE
29+
30+
31+create :: IO Progress.Reporter
32+create =
33+ do chan <- newChan
34+ mvar <- newEmptyMVar
35+ _ <- forkIO (loop chan (State 0 0 0) >>= putMVar mvar)
36+ return (Progress.makeReporter chan mvar)
37+
38+
39+
40+-- STATE
41+
42+
43+data State =
44+ State
45+ { _total :: !Int
46+ , _good :: !Int
47+ , _bad :: !Int
48+ }
49+
50+
51+
52+-- LOOP
53+
54+
55+loop :: Chan Msg -> State -> IO ()
56+loop chan state =
57+ do msg <- readChan chan
58+ case msg of
59+ End (Just exit) ->
60+ Exit.toStderr exit
61+
62+ End Nothing ->
63+ return ()
64+
65+ Progress progress ->
66+ loopHelp chan progress state
67+
68+
69+loopHelp :: Chan Msg -> Progress -> State -> IO ()
70+loopHelp chan progress state@(State total good bad) =
71+ case progress of
72+
73+
74+ -- DOWNLOADS
75+
76+ DownloadSkip ->
77+ do putStrLn "Dependencies loaded from local cache."
78+ loop chan state
79+
80+ DownloadStart [] ->
81+ loop chan state
82+
83+ DownloadStart _ ->
84+ do putStrLn "Starting downloads...\n"
85+ loop chan state
86+
87+ DownloadPkgStart _name _version ->
88+ loop chan state
89+
90+ DownloadPkgEnd name version outcome ->
91+ do Help.toStdout (makeBullet name version outcome)
92+ loop chan state
93+
94+ DownloadEnd Bad ->
95+ do putStrLn ""
96+ loop chan state
97+
98+ DownloadEnd Good ->
99+ do putStrLn ""
100+ loop chan state
101+
102+
103+ -- BUILD DEPS
104+
105+ BuildDepsStart size ->
106+ do hPutStr stdout "Verifying dependencies..."
107+ hFlush stdout
108+ loop chan (State size 0 0)
109+
110+ BuildDepsProgress ->
111+ do let n = good + 1
112+ let msg = "\rBuilding dependencies (" ++ show n ++ "/" ++ show total ++ ")"
113+ hPutStr stdout msg
114+ hFlush stdout
115+ loop chan (State total n 0)
116+
117+ BuildDepsEnd ->
118+ do putStrLn "\rDependencies ready! "
119+ loop chan (State 0 0 0)
120+
121+
122+ -- COMPILE
123+
124+ CompileStart size ->
125+ loop chan (State size 0 0)
126+
127+ CompileFileStart _ ->
128+ loop chan state
129+
130+ CompileFileEnd _ Good ->
131+ do hPutStr stdout $ Bar.render (good + 1) bad total
132+ hFlush stdout
133+ loop chan (State total (good + 1) bad)
134+
135+ CompileFileEnd _ Bad ->
136+ do hPutStr stdout $ Bar.render good (bad + 1) total
137+ hFlush stdout
138+ loop chan (State total good (bad + 1))
139+
140+ CompileEnd ->
141+ let
142+ message =
143+ case (bad, total) of
144+ (0, 0) -> "Success!"
145+ (0, 1) -> "Success! Compiled 1 module."
146+ (0, n) -> "Success! Compiled " ++ show n ++ " modules."
147+ (1, _) -> "Detected errors in 1 module."
148+ (n, _) -> "Detected errors in " ++ show n ++ " modules."
149+ in
150+ do hPutStr stdout $ Bar.clear
151+ putStrLn message
152+ loop chan (State 0 0 0)
153+
154+
155+ -- PUBLISH
156+
157+ PublishStart name version maybePublishedVersions ->
158+ case maybePublishedVersions of
159+ Nothing ->
160+ do putStrLn newPackageOverview
161+ putStrLn "I will now verify that everything is in order..."
162+ putStrLn ""
163+ loop chan state
164+
165+ Just _ ->
166+ do putStrLn $ unwords [ "Verifying", Pkg.toString name, Pkg.versionToString version, "..." ]
167+ putStrLn ""
168+ loop chan state
169+
170+ PublishCheckBump version bumpPhase ->
171+ do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase
172+ hFlush stdout
173+ loop chan state
174+
175+ PublishProgress phase status ->
176+ do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)
177+ hFlush stdout
178+ loop chan state
179+
180+ PublishEnd ->
181+ do putStrLn "Success!"
182+ loop chan state
183+
184+
185+ -- SOLVER
186+
187+ UnableToLoadLatestPackages ->
188+ do putStrLn ""
189+ Help.toStdout $ D.dullyellow "WARNING:" <+> "I normally check <https://package.elm-lang.org> for new packages\n"
190+ putStrLn "here, but my request failed. Are you offline? I will try to continue anyway.\n"
191+ loop chan state
192+
193+
194+
195+-- BULLETS
196+
197+
198+makeBullet :: Name -> Version -> Outcome -> D.Doc
199+makeBullet name version outcome =
200+ let
201+ nm = D.fromText (Pkg.toText name)
202+ vsn = D.fromText (Pkg.versionToText version)
203+
204+ bullet =
205+ case outcome of
206+ Good -> goodMark
207+ Bad -> badMark
208+ in
209+ D.indent 2 $ bullet <+> nm <+> vsn <> "\n"
210+
211+
212+goodMark :: D.Doc
213+goodMark =
214+ D.green $
215+ if Info.os == "mingw32" then "+" else "●"
216+
217+
218+badMark :: D.Doc
219+badMark =
220+ D.red $
221+ if Info.os == "mingw32" then "X" else "✗"
222+
223+
224+waitingMark :: D.Doc
225+waitingMark =
226+ D.dullyellow $
227+ if Info.os == "mingw32" then "-" else "→"
228+
229+
230+
231+-- OVERVIEW OF VERSIONING
232+
233+
234+newPackageOverview :: String
235+newPackageOverview =
236+ unlines
237+ [ "This package has never been published before. Here's how things work:"
238+ , ""
239+ , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
240+ , ""
241+ , " - All packages start with initial version " ++ Pkg.versionToString Pkg.initialVersion
242+ , ""
243+ , " - Versions are incremented based on how the API changes:"
244+ , ""
245+ , " PATCH = the API is the same, no risk of breaking code"
246+ , " MINOR = values have been added, existing values are unchanged"
247+ , " MAJOR = existing values have been changed or removed"
248+ , ""
249+ , " - I will bump versions for you, automatically enforcing these rules"
250+ , ""
251+ ]
252+
253+
254+
255+-- CHECKLIST
256+
257+
258+toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> D.Doc
259+toChecklistDoc status (ChecklistMessages waiting success failure) =
260+ let
261+ padded message =
262+ message ++ replicate (length waiting - length message) ' '
263+ in
264+ case status of
265+ Nothing ->
266+ " " <> waitingMark <+> D.fromString waiting
267+
268+ Just Good ->
269+ "\r " <> goodMark <+> D.fromString (padded success ++ "\n")
270+
271+ Just Bad ->
272+ "\r " <> badMark <+> D.fromString (padded failure ++ "\n\n")
273+
274+
275+data ChecklistMessages =
276+ ChecklistMessages
277+ { _waiting :: String
278+ , _success :: String
279+ , _failure :: String
280+ }
281+
282+
283+toChecklistMessages :: PublishPhase -> ChecklistMessages
284+toChecklistMessages phase =
285+ case phase of
286+ CheckReadme ->
287+ ChecklistMessages
288+ "Looking for README.md"
289+ "Found README.md"
290+ "Problem with your README.md"
291+
292+ CheckLicense ->
293+ ChecklistMessages
294+ "Looking for LICENSE"
295+ "Found LICENSE"
296+ "Problem with your LICENSE"
297+
298+ CheckTag version ->
299+ ChecklistMessages
300+ ("Is version " ++ Pkg.versionToString version ++ " tagged on GitHub?")
301+ ("Version " ++ Pkg.versionToString version ++ " is tagged on GitHub")
302+ ("Version " ++ Pkg.versionToString version ++ " is not tagged on GitHub!")
303+
304+ CheckDownload ->
305+ ChecklistMessages
306+ "Downloading code from GitHub..."
307+ "Code downloaded successfully from GitHub"
308+ "Could not download code from GitHub!"
309+
310+ CheckBuild ->
311+ ChecklistMessages
312+ "Building downloaded code and generated docs..."
313+ "Downloaded code compiles successfully / docs generated\n"
314+ "Cannot compile downloaded code!"
315+
316+ CheckChanges ->
317+ ChecklistMessages
318+ "Checking for uncommitted changes..."
319+ "No uncommitted changes in local code"
320+ "Your local code is different than the code tagged on GitHub"
321+
322+
323+
324+-- BUMP PHASE
325+
326+
327+bumpPhaseToChecklistDoc :: Pkg.Version -> BumpPhase -> D.Doc
328+bumpPhaseToChecklistDoc version bumpPhase =
329+ let
330+ mkMsgs success =
331+ ChecklistMessages
332+ ("Checking semantic versioning rules. Is " ++ Pkg.versionToString version ++ " correct?")
333+ success
334+ ("Version " ++ Pkg.versionToString version ++ " is not correct!")
335+ in
336+
337+ case bumpPhase of
338+ StatedVersion ->
339+ toChecklistDoc Nothing $ mkMsgs ""
340+
341+ GoodStart ->
342+ toChecklistDoc (Just Good) $ mkMsgs $
343+ "All packages start at version " ++ Pkg.versionToString Pkg.initialVersion
344+
345+ GoodBump old magnitude ->
346+ toChecklistDoc (Just Good) $ mkMsgs $
347+ toCheckVersionSuccessMessage old version magnitude
348+
349+ BadBump ->
350+ toChecklistDoc (Just Bad) $ mkMsgs ""
351+
352+
353+toCheckVersionSuccessMessage :: Pkg.Version -> Pkg.Version -> Diff.Magnitude -> String
354+toCheckVersionSuccessMessage oldVersion newVersion magnitude =
355+ let
356+ old = Pkg.versionToString oldVersion
357+ new = Pkg.versionToString newVersion
358+ mag = Diff.magnitudeToString magnitude
359+ in
360+ "Version number " ++ new ++ " verified (" ++ mag ++ " change, " ++ old ++ " => " ++ new ++ ")"
builder/src/Reporting/Task.hs+165−76
@@ -1,114 +1,203 @@
1−{-# LANGUAGE Rank2Types #-}
1+{-# LANGUAGE OverloadedStrings #-}
22module Reporting.Task
3− ( Task
3+ ( Task, Task_
4+ , try
45 , run
56 , throw
67 , mapError
7− --
8− , io
9− , mio
10− , eio
8+ , Env
9+ , getPackageCacheDir
10+ , getPackageCacheDirFor
11+ , report
12+ , getReporter
13+ , withApproval
14+ , getApproval
15+ , silently
16+ , getSilentRunner
17+ , workerChan
18+ , runHttp
1119 )
1220 where
1321
22+import Control.Concurrent (forkIO)
23+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
24+import Control.Monad (forever, join, replicateM_)
25+import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
26+import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
27+import Control.Monad.Trans (liftIO)
28+import qualified Network.HTTP.Client as Http
29+import qualified Network.HTTP.Client.TLS as Http
30+import qualified System.Directory as Dir
31+import qualified System.Exit as Exit
32+import System.FilePath ((</>))
33+import qualified System.IO as IO
34+
35+import Elm.Package (Name, Version)
36+import qualified Elm.Package as Pkg
37+import qualified Elm.PerUserCache as PerUserCache
38+import qualified Reporting.Exit as Exit
39+import qualified Reporting.Progress as Progress
40+
1441
1542
1643-- TASKS
1744
1845
19−newtype Task x a =
20− Task
21− (
22− forall result. (a -> IO result) -> (x -> IO result) -> IO result
23− )
46+type Task =
47+ Task_ Exit.Exit
48+
49+
50+type Task_ e =
51+ ExceptT e (ReaderT Env IO)
52+
53+
54+data Env =
55+ Env
56+ { _cacheDir :: FilePath
57+ , _worker :: IO () -> IO ()
58+ , _httpManager :: Http.Manager
59+ , _tell :: Progress.Progress -> IO ()
60+ }
61+
62+
63+try :: Progress.Reporter -> Task a -> IO (Maybe a)
64+try (Progress.Reporter tell end) task =
65+ do root <- PerUserCache.getPackageRoot
66+ pool <- initPool 4
67+ httpManager <- Http.newManager Http.tlsManagerSettings
68+ let env = Env root pool httpManager tell
69+ result <- runReaderT (runExceptT task) env
70+ case result of
71+ Left err ->
72+ do end (Just err)
73+ return Nothing
74+
75+ Right answer ->
76+ do end Nothing
77+ return (Just answer)
78+
79+
80+run :: Progress.Reporter -> Task a -> IO ()
81+run reporter task =
82+ do maybeAnswer <- try reporter task
83+ case maybeAnswer of
84+ Nothing -> Exit.exitFailure
85+ Just _ -> return ()
86+
87+
88+throw :: e -> Task_ e a
89+throw =
90+ throwError
91+
92+
93+mapError :: (x -> y) -> Task_ x a -> Task_ y a
94+mapError =
95+ withExceptT
96+
97+
98+
99+-- CACHING
100+
101+
102+getPackageCacheDir :: Task_ e FilePath
103+getPackageCacheDir =
104+ asks _cacheDir
105+
106+
107+getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath
108+getPackageCacheDirFor name version =
109+ do cacheDir <- getPackageCacheDir
110+ let dir = cacheDir </> Pkg.toFilePath name </> Pkg.versionToString version
111+ liftIO (Dir.createDirectoryIfMissing True dir)
112+ return dir
113+
114+
115+
116+-- REPORTER
117+
118+
119+report :: Progress.Progress -> Task_ e ()
120+report progress =
121+ do tell <- asks _tell
122+ liftIO (tell progress)
123+
124+
125+getReporter :: Task (Progress.Progress -> IO ())
126+getReporter =
127+ asks _tell
128+
129+
130+
131+-- APPROVAL
24132
25133
26−run :: Task x a -> IO (Either x a)
27−run (Task task) =
28− task (return . Right) (return . Left)
134+withApproval :: Task_ e () -> Task_ e ()
135+withApproval task =
136+ do approval <- getApproval
137+ if approval then task else return ()
29138
30139
31−throw :: x -> Task x a
32−throw x =
33− Task $ \_ err -> err x
140+getApproval :: Task_ e Bool
141+getApproval =
142+ do liftIO $ IO.hFlush IO.stdout
143+ input <- liftIO getLine
144+ case input of
145+ "" -> return True
146+ "Y" -> return True
147+ "y" -> return True
148+ "n" -> return False
149+ _ ->
150+ do liftIO $ putStr "Must type 'y' for yes or 'n' for no: "
151+ getApproval
34152
35153
36−mapError :: (x -> y) -> Task x a -> Task y a
37−mapError func (Task task) =
38− Task $ \ok err ->
39− task ok (err . func)
40154
155+-- RUNNER
41156
42157
43−-- IO
158+silently :: Task_ e a -> Task_ e a
159+silently task =
160+ do runner <- getSilentRunner
161+ result <- liftIO (runner task)
162+ either throw return result
44163
45164
46−{-# INLINE io #-}
47−io :: IO a -> Task x a
48−io work =
49− Task $ \ok _ -> work >>= ok
165+getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
166+getSilentRunner =
167+ do env <- ask
168+ let silentEnv = env { _tell = \_ -> return () }
169+ return $ \task -> runReaderT (runExceptT task) silentEnv
50170
51171
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
59172
173+-- THREAD POOL
60174
61−eio :: (x -> y) -> IO (Either x a) -> Task y a
62−eio func work =
63− Task $ \ok err ->
64− do result <- work
65− case result of
66− Right a -> ok a
67− Left x -> err (func x)
68175
176+workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
177+workerChan chan task =
178+ do env <- ask
69179
180+ liftIO $ _worker env $
181+ do result <- runReaderT (runExceptT task) env
182+ writeChan chan result
70183
71−-- INSTANCES
72184
185+initPool :: Int -> IO (IO () -> IO ())
186+initPool size =
187+ do chan <- newChan
73188
74−instance Functor (Task x) where
75− {-# INLINE fmap #-}
76− fmap func (Task taskA) =
77− Task $ \ok err ->
78− let
79− okA arg = ok (func arg)
80− in
81− taskA okA err
189+ replicateM_ size $ forkIO $ forever $
190+ join (readChan chan)
82191
192+ return $ writeChan chan
83193
84−instance Applicative (Task x) where
85− {-# INLINE pure #-}
86− pure a =
87− Task $ \ok _ -> ok a
88194
89− {-# INLINE (<*>) #-}
90− (<*>) (Task taskFunc) (Task taskArg) =
91− Task $ \ok err ->
92− let
93− okFunc func =
94− let
95− okArg arg = ok (func arg)
96− in
97− taskArg okArg err
98− in
99− taskFunc okFunc err
100195
196+-- HTTP
101197
102−instance Monad (Task x) where
103− {-# INLINE return #-}
104− return = pure
105198
106− {-# INLINE (>>=) #-}
107− (>>=) (Task taskA) callback =
108− Task $ \ok err ->
109− let
110− okA a =
111− case callback a of
112− Task taskB -> taskB ok err
113− in
114− taskA okA err
199+runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
200+runHttp fetcher =
201+ do (Env _ _ manager tell) <- ask
202+ result <- liftIO $ fetcher manager tell
203+ either throwError return result
builder/src/Reporting/Task/Http.hsnew file+195
@@ -0,0 +1,195 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reporting.Task.Http
4+ ( Fetch
5+ , Handler
6+ , run
7+ , package
8+ , anything
9+ , andThen
10+ , parallel
11+ , report
12+ )
13+ where
14+
15+
16+import Control.Concurrent (forkIO)
17+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
18+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
19+import Control.Exception (Exception, SomeException, catch)
20+import Control.Monad (forever, join, replicateM_, void)
21+import qualified Data.ByteString.Char8 as BS
22+import qualified Network.HTTP as Http (urlEncodeVars)
23+import qualified Network.HTTP.Client as Http
24+import qualified Network.HTTP.Types.Header as Http (hAcceptEncoding, hUserAgent)
25+
26+import qualified Elm.Compiler as Compiler
27+import qualified Elm.Package as Pkg
28+import qualified Reporting.Exit as Exit
29+import qualified Reporting.Exit.Http as E
30+import qualified Reporting.Progress as Progress
31+import qualified Reporting.Task as Task
32+
33+
34+
35+-- FETCH
36+
37+
38+data Fetch a where
39+ Package :: String -> [(String,String)] -> Handler a -> Fetch a
40+ Anything :: String -> Handler a -> Fetch a
41+ AndThen :: Fetch a -> (a -> Fetch b) -> Fetch b
42+ Parallel :: [Fetch a] -> Fetch [a]
43+ Report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
44+
45+
46+type Handler a =
47+ Http.Request -> Http.Manager -> IO (Either E.Exit a)
48+
49+
50+package :: String -> [(String,String)] -> Handler a -> Fetch a
51+package =
52+ Package
53+
54+
55+anything :: String -> Handler a -> Fetch a
56+anything =
57+ Anything
58+
59+
60+andThen :: Fetch a -> (a -> Fetch b) -> Fetch b
61+andThen =
62+ AndThen
63+
64+
65+parallel :: [Fetch a] -> Fetch [a]
66+parallel =
67+ Parallel
68+
69+
70+report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
71+report =
72+ Report
73+
74+
75+
76+-- RUN
77+
78+
79+run :: Fetch a -> Task.Task a
80+run fetch =
81+ Task.runHttp $ \manager tell ->
82+ do chan <- newChan
83+ replicateM_ 4 $ forkIO $ forever $ join (readChan chan)
84+ readMVar =<< runHelp chan manager tell fetch
85+
86+
87+runHelp :: Chan (IO ()) -> Http.Manager -> (Progress.Progress -> IO ()) -> Fetch a -> IO (MVar (Either Exit.Exit a))
88+runHelp chan manager tell fetch =
89+ case fetch of
90+ Package path params handler ->
91+ do mvar <- newEmptyMVar
92+ let url = makePackageUrl path params
93+ writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
94+ return mvar
95+
96+ Anything url handler ->
97+ do mvar <- newEmptyMVar
98+ writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
99+ return mvar
100+
101+ AndThen subFetch callback ->
102+ do subMVar <- runHelp chan manager tell subFetch
103+ mvar <- newEmptyMVar
104+ void $ forkIO $
105+ do result <- readMVar subMVar
106+ putMVar mvar =<<
107+ case result of
108+ Left err ->
109+ return (Left err)
110+ Right value ->
111+ readMVar =<< runHelp chan manager tell (callback value)
112+ return mvar
113+
114+ Parallel fetches ->
115+ do mvars <- mapM (runHelp chan manager tell) fetches
116+ mvar <- newEmptyMVar
117+ void $ forkIO $
118+ do results <- mapM readMVar mvars
119+ putMVar mvar (sequence results)
120+ return mvar
121+
122+ Report start toEnd subFetch ->
123+ do tell start
124+ subMVar <- runHelp chan manager tell subFetch
125+ mvar <- newEmptyMVar
126+ void $ forkIO $
127+ do result <- readMVar subMVar
128+ tell $ toEnd $
129+ either (\_ -> Progress.Bad) (\_ -> Progress.Good) result
130+ putMVar mvar result
131+ return mvar
132+
133+
134+
135+-- PACKAGE URLS
136+
137+
138+packageDomain :: String
139+packageDomain =
140+ "https://alpha.elm-lang.org"
141+
142+
143+makePackageUrl :: String -> [(String,String)] -> String
144+makePackageUrl path params =
145+ let
146+ query =
147+ if null params then
148+ ""
149+ else
150+ "?" ++ Http.urlEncodeVars params
151+ in
152+ packageDomain ++ "/" ++ path ++ query
153+
154+
155+
156+-- HTTP HELP
157+
158+
159+fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
160+fetchSafe url manager handler =
161+ fetchUnsafe url manager handler
162+ `catch` \e -> handleAnyError url (e :: SomeException)
163+
164+
165+fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
166+fetchUnsafe url manager handler =
167+ do request <- Http.parseUrlThrow url
168+ result <- handler (addHeaders request) manager
169+ case result of
170+ Right value ->
171+ return (Right value)
172+
173+ Left problem ->
174+ return (Left (Exit.BadHttp url problem))
175+
176+
177+handleAnyError :: (Exception e) => String -> e -> IO (Either Exit.Exit a)
178+handleAnyError url exception =
179+ return $ Left $ Exit.BadHttp url $ E.Unknown $ show exception
180+
181+
182+addHeaders :: Http.Request -> Http.Request
183+addHeaders request =
184+ request
185+ { Http.requestHeaders =
186+ [ (Http.hUserAgent, userAgent)
187+ , (Http.hAcceptEncoding, "gzip")
188+ ]
189+ }
190+
191+
192+{-# NOINLINE userAgent #-}
193+userAgent :: BS.ByteString
194+userAgent =
195+ BS.pack ("elm/" ++ Pkg.versionToString Compiler.version)
builder/src/Stuff.hsdeleted−179
@@ -1,179 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Stuff
3− ( details
4− , interfaces
5− , objects
6− , prepublishDir
7− , elmi
8− , elmo
9− , temp
10− , findRoot
11− , withRootLock
12− , withRegistryLock
13− , PackageCache
14− , getPackageCache
15− , registry
16− , package
17− , getReplCache
18− , getElmHome
19− )
20− where
21−
22−
23−import qualified System.Directory as Dir
24−import qualified System.Environment as Env
25−import qualified System.FileLock as Lock
26−import qualified System.FilePath as FP
27−import System.FilePath ((</>), (<.>))
28−
29−import qualified Elm.ModuleName as ModuleName
30−import qualified Elm.Package as Pkg
31−import qualified Elm.Version as V
32−
33−
34−
35−-- PATHS
36−
37−
38−stuff :: FilePath -> FilePath
39−stuff root =
40− root </> "elm-stuff" </> compilerVersion
41−
42−
43−details :: FilePath -> FilePath
44−details root =
45− stuff root </> "d.dat"
46−
47−
48−interfaces :: FilePath -> FilePath
49−interfaces root =
50− stuff root </> "i.dat"
51−
52−
53−objects :: FilePath -> FilePath
54−objects root =
55− stuff root </> "o.dat"
56−
57−
58−prepublishDir :: FilePath -> FilePath
59−prepublishDir root =
60− stuff root </> "prepublish"
61−
62−
63−compilerVersion :: FilePath
64−compilerVersion =
65− V.toChars V.compiler
66−
67−
68−
69−-- ELMI and ELMO
70−
71−
72−elmi :: FilePath -> ModuleName.Raw -> FilePath
73−elmi root name =
74− toArtifactPath root name "elmi"
75−
76−
77−elmo :: FilePath -> ModuleName.Raw -> FilePath
78−elmo root name =
79− toArtifactPath root name "elmo"
80−
81−
82−toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath
83−toArtifactPath root name ext =
84− stuff root </> ModuleName.toHyphenPath name <.> ext
85−
86−
87−
88−-- TEMP
89−
90−
91−temp :: FilePath -> String -> FilePath
92−temp root ext =
93− stuff root </> "temp" <.> ext
94−
95−
96−
97−-- ROOT
98−
99−
100−findRoot :: IO (Maybe FilePath)
101−findRoot =
102− do dir <- Dir.getCurrentDirectory
103− findRootHelp (FP.splitDirectories dir)
104−
105−
106−findRootHelp :: [String] -> IO (Maybe FilePath)
107−findRootHelp dirs =
108− case dirs of
109− [] ->
110− return Nothing
111−
112− _:_ ->
113− do exists <- Dir.doesFileExist (FP.joinPath dirs </> "elm.json")
114− if exists
115− then return (Just (FP.joinPath dirs))
116− else findRootHelp (init dirs)
117−
118−
119−
120−-- LOCKS
121−
122−
123−withRootLock :: FilePath -> IO a -> IO a
124−withRootLock root work =
125− do let dir = stuff root
126− Dir.createDirectoryIfMissing True dir
127− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
128−
129−
130−withRegistryLock :: PackageCache -> IO a -> IO a
131−withRegistryLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
133−
134−
135−
136−-- PACKAGE CACHES
137−
138−
139−newtype PackageCache = PackageCache FilePath
140−
141−
142−getPackageCache :: IO PackageCache
143−getPackageCache =
144− PackageCache <$> getCacheDir "packages"
145−
146−
147−registry :: PackageCache -> FilePath
148−registry (PackageCache dir) =
149− dir </> "registry.dat"
150−
151−
152−package :: PackageCache -> Pkg.Name -> V.Version -> FilePath
153−package (PackageCache dir) name version =
154− dir </> Pkg.toFilePath name </> V.toChars version
155−
156−
157−
158−-- CACHE
159−
160−
161−getReplCache :: IO FilePath
162−getReplCache =
163− getCacheDir "repl"
164−
165−
166−getCacheDir :: FilePath -> IO FilePath
167−getCacheDir projectName =
168− do home <- getElmHome
169− let root = home </> compilerVersion </> projectName
170− Dir.createDirectoryIfMissing True root
171− return root
172−
173−
174−getElmHome :: IO FilePath
175−getElmHome =
176− do maybeCustomHome <- Env.lookupEnv "ELM_HOME"
177− case maybeCustomHome of
178− Just customHome -> return customHome
179− Nothing -> Dir.getAppUserDataDirectory "elm"
builder/src/Stuff/Paths.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Stuff.Paths
3+ ( docs
4+ , solution
5+ , summary
6+ , prepublishDir
7+ , removeStuff
8+ , elmi
9+ , elmo
10+ , moduleDocs
11+ , temp
12+ )
13+ where
14+
15+
16+import Control.Monad.Trans (liftIO)
17+import qualified System.Directory as Dir
18+import System.FilePath ((</>), (<.>))
19+
20+import qualified Elm.Compiler as Compiler
21+import qualified Elm.Compiler.Module as Module
22+import qualified Elm.Package as Pkg
23+import qualified Reporting.Task as Task
24+
25+
26+
27+-- PATHS
28+
29+
30+stuff :: FilePath
31+stuff =
32+ "elm-stuff" </> Pkg.versionToString Compiler.version
33+
34+
35+docs :: FilePath
36+docs =
37+ stuff </> "docs.json"
38+
39+
40+solution :: FilePath
41+solution =
42+ stuff </> "solution.dat"
43+
44+
45+summary :: FilePath
46+summary =
47+ stuff </> "summary.dat"
48+
49+
50+prepublishDir :: FilePath
51+prepublishDir =
52+ stuff </> "prepublish"
53+
54+
55+
56+-- REMOVE STUFF
57+
58+
59+removeStuff :: FilePath -> Task.Task_ e ()
60+removeStuff root =
61+ liftIO $
62+ do let dir = root </> "elm-stuff"
63+ exists <- Dir.doesDirectoryExist dir
64+ if exists
65+ then Dir.removeDirectoryRecursive dir
66+ else return ()
67+
68+
69+
70+-- ELMI and ELMO
71+
72+
73+elmi :: FilePath -> Module.Raw -> FilePath
74+elmi root name =
75+ toArtifactPath root name "elmi"
76+
77+
78+elmo :: FilePath -> Module.Raw -> FilePath
79+elmo root name =
80+ toArtifactPath root name "elmo"
81+
82+
83+moduleDocs :: FilePath -> Module.Raw -> FilePath
84+moduleDocs root name =
85+ toArtifactPath root name "json"
86+
87+
88+toArtifactPath :: FilePath -> Module.Raw -> String -> FilePath
89+toArtifactPath root name ext =
90+ root </> stuff </> Module.nameToHyphenPath name <.> ext
91+
92+
93+
94+-- TEMP
95+
96+
97+temp :: String -> FilePath
98+temp ext =
99+ stuff </> "temp" <.> ext
builder/src/Stuff/Verify.hsnew file+96
@@ -0,0 +1,96 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Stuff.Verify
3+ ( verify
4+ )
5+ where
6+
7+
8+import Prelude hiding (read)
9+import qualified Data.Map as Map
10+import Data.Map (Map)
11+
12+import Elm.Package (Name, Version)
13+
14+import qualified Deps.Verify as Verify
15+import Elm.Project.Json (Project(..), PkgInfo(..))
16+import qualified Elm.Project.Json as Project
17+import qualified Elm.Project.Constraint as Con
18+import qualified Elm.Project.Summary as Summary
19+import qualified File.IO as IO
20+import qualified Reporting.Task as Task
21+import qualified Stuff.Paths as Path
22+
23+
24+
25+-- VERIFY
26+
27+
28+verify :: FilePath -> Project -> Task.Task Summary.Summary
29+verify root project =
30+ do fresh <-
31+ IO.andM
32+ [ IO.exists Path.solution
33+ , IO.exists Path.summary
34+ , checkSolution project
35+ ]
36+
37+ if fresh
38+ then read root project
39+ else rebuildCache root project
40+
41+
42+rebuildCache :: FilePath -> Project -> Task.Task Summary.Summary
43+rebuildCache root project =
44+ do IO.remove Path.solution
45+ IO.remove Path.summary
46+
47+ (solution, summary) <- Verify.verify root project
48+
49+ IO.writeBinary Path.solution solution
50+ write summary
51+ return summary
52+
53+
54+
55+-- READ / WRITE
56+
57+
58+read :: FilePath -> Project -> Task.Task Summary.Summary
59+read root project =
60+ do (exposed, ifaces, graph) <- IO.readBinary Path.summary
61+ return (Summary.Summary root project exposed ifaces graph)
62+
63+
64+write :: Summary.Summary -> Task.Task ()
65+write (Summary.Summary _ _ exposed ifaces graph) =
66+ IO.writeBinary Path.summary ( exposed, ifaces, graph )
67+
68+
69+
70+-- CHECK SOLUTION
71+
72+
73+checkSolution :: Project -> Task.Task Bool
74+checkSolution project =
75+ checkSolutionHelp project <$> IO.readBinary Path.solution
76+
77+
78+checkSolutionHelp :: Project -> Map Name Version -> Bool
79+checkSolutionHelp project solution =
80+ case project of
81+ App info ->
82+ solution == Project.appSolution info
83+
84+ Pkg info ->
85+ allGood (_pkg_test_deps info) solution
86+ && allGood (_pkg_deps info) solution
87+
88+
89+allGood :: Map Name Con.Constraint -> Map Name Version -> Bool
90+allGood cons vsns =
91+ let
92+ bools =
93+ Map.intersectionWith Con.satisfies cons vsns
94+ in
95+ Map.size cons == Map.size bools
96+ && Map.foldr (&&) True bools
cabal.configdeleted−2
@@ -1,2 +0,0 @@
1−profiling: False
2−library-profiling: True
compiler/src/AST/Canonical.hs+73−68
@@ -23,6 +23,7 @@ module AST.Canonical
2323 , Binop(..)
2424 , Union(..)
2525 , Ctor(..)
26+ , Docs(..)
2627 , Exports(..)
2728 , Export(..)
2829 , Effects(..)
@@ -32,7 +33,7 @@ module AST.Canonical
3233 where
3334
3435{- Creating a canonical AST means finding the home module for all variables.
35−So if you have L.map, you need to figure out that it is from the elm/core
36+So if you have L.map, you need to figure out that it is from the elm-lang/core
3637package in the List module.
3738
3839In later phases (e.g. type inference, exhaustiveness checking, optimization)
@@ -53,18 +54,18 @@ So it is clear why the data is kept around.
5354
5455import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
5556import Data.Binary
57+import qualified Data.ByteString as B
5658import qualified Data.List as List
5759import qualified Data.Map as Map
58−import Data.Name (Name)
60+import Data.Text (Text)
5961
60−import qualified AST.Source as Src
6162import qualified AST.Utils.Binop as Binop
63+import qualified AST.Module.Name as ModuleName
6264import qualified AST.Utils.Shader as Shader
6365import qualified Data.Index as Index
64−import qualified Elm.Float as EF
65−import qualified Elm.ModuleName as ModuleName
66−import qualified Elm.String as ES
66+import qualified Elm.Name as N
6767import qualified Reporting.Annotation as A
68+import qualified Reporting.Region as R
6869
6970
7071
@@ -77,20 +78,20 @@ type Expr =
7778
7879-- CACHE Annotations for type inference
7980data Expr_
80− = VarLocal Name
81− | VarTopLevel ModuleName.Canonical Name
82− | VarKernel Name Name
83− | VarForeign ModuleName.Canonical Name Annotation
84− | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
85− | VarDebug ModuleName.Canonical Name Annotation
86− | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
87− | Chr ES.String
88− | Str ES.String
81+ = VarLocal N.Name
82+ | VarTopLevel ModuleName.Canonical N.Name
83+ | VarKernel N.Name N.Name
84+ | VarForeign ModuleName.Canonical N.Name Annotation
85+ | VarCtor CtorOpts ModuleName.Canonical N.Name Index.ZeroBased Annotation
86+ | VarDebug ModuleName.Canonical N.Name Annotation
87+ | VarOperator N.Name ModuleName.Canonical N.Name Annotation -- CACHE real name for optimization
88+ | Chr Text
89+ | Str Text
8990 | Int Int
90− | Float EF.Float
91+ | Float Double
9192 | List [Expr]
9293 | Negate Expr
93− | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
94+ | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr -- CACHE real name for optimization
9495 | Lambda [Pattern] Expr
9596 | Call Expr [Expr]
9697 | If [(Expr, Expr)] Expr
@@ -98,13 +99,13 @@ data Expr_
9899 | LetRec [Def] Expr
99100 | LetDestruct Pattern Expr Expr
100101 | Case Expr [CaseBranch]
101− | Accessor Name
102− | Access Expr (A.Located Name)
103− | Update Name Expr (Map.Map Name FieldUpdate)
104− | Record (Map.Map Name Expr)
102+ | Accessor N.Name
103+ | Access Expr (A.Located N.Name)
104+ | Update N.Name Expr (Map.Map N.Name FieldUpdate)
105+ | Record (Map.Map N.Name Expr)
105106 | Unit
106107 | Tuple Expr Expr (Maybe Expr)
107− | Shader Shader.Source Shader.Types
108+ | Shader Text Text Shader.Shader
108109
109110
110111data CaseBranch =
@@ -112,7 +113,7 @@ data CaseBranch =
112113
113114
114115data FieldUpdate =
115− FieldUpdate A.Region Expr
116+ FieldUpdate R.Region Expr
116117
117118
118119
@@ -120,8 +121,8 @@ data FieldUpdate =
120121
121122
122123data Def
123− = Def (A.Located Name) [Pattern] Expr
124− | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type
124+ = Def (A.Located N.Name) [Pattern] Expr
125+ | TypedDef (A.Located N.Name) FreeVars [(Pattern, Type)] Expr Type
125126
126127
127128
@@ -130,7 +131,7 @@ data Def
130131
131132data Decls
132133 = Declare Def Decls
133− | DeclareRec Def [Def] Decls
134+ | DeclareRec [Def] Decls
134135 | SaveTheEnvironment
135136
136137
@@ -144,22 +145,21 @@ type Pattern =
144145
145146data Pattern_
146147 = PAnything
147− | PVar Name
148− | PRecord [Name]
149− | PAlias Pattern Name
148+ | PVar N.Name
149+ | PRecord [N.Name]
150+ | PAlias Pattern N.Name
150151 | PUnit
151152 | PTuple Pattern Pattern (Maybe Pattern)
152153 | PList [Pattern]
153154 | PCons Pattern Pattern
154− | PBool Union Bool
155− | PChr ES.String
156− | PStr ES.String
155+ | PChr Text
156+ | PStr Text
157157 | PInt Int
158158 | PCtor
159159 { _p_home :: ModuleName.Canonical
160− , _p_type :: Name
160+ , _p_type :: N.Name
161161 , _p_union :: Union
162− , _p_name :: Name
162+ , _p_name :: N.Name
163163 , _p_index :: Index.ZeroBased
164164 , _p_args :: [PatternCtorArg]
165165 }
@@ -182,38 +182,35 @@ data PatternCtorArg =
182182
183183
184184data Annotation = Forall FreeVars Type
185− deriving (Eq)
186185
187186
188−type FreeVars = Map.Map Name ()
187+type FreeVars = Map.Map N.Name ()
189188
190189
191190data Type
192191 = TLambda Type Type
193− | TVar Name
194− | TType ModuleName.Canonical Name [Type]
195− | TRecord (Map.Map Name FieldType) (Maybe Name)
192+ | TVar N.Name
193+ | TType ModuleName.Canonical N.Name [Type]
194+ | TRecord (Map.Map N.Name FieldType) (Maybe N.Name)
196195 | TUnit
197196 | TTuple Type Type (Maybe Type)
198− | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType
199− deriving (Eq)
197+ | TAlias ModuleName.Canonical N.Name [(N.Name, Type)] AliasType
200198
201199
202200data AliasType
203201 = Holey Type
204202 | Filled Type
205− deriving (Eq)
206203
207204
208−data FieldType = FieldType {-# UNPACK #-} !Word16 Type
209− deriving (Eq)
205+data FieldType =
206+ FieldType {-# UNPACK #-} !Word16 Type
210207
211208
212209-- NOTE: The Word16 marks the source order, but it may not be available
213210-- for every canonical type. For example, if the canonical type is inferred
214211-- the orders will all be zeros.
215212--
216−fieldsToList :: Map.Map Name FieldType -> [(Name, Type)]
213+fieldsToList :: Map.Map N.Name FieldType -> [(N.Name, Type)]
217214fieldsToList fields =
218215 let
219216 getIndex (_, FieldType index _) =
@@ -232,32 +229,27 @@ fieldsToList fields =
232229data Module =
233230 Module
234231 { _name :: ModuleName.Canonical
232+ , _docs :: Docs
235233 , _exports :: Exports
236− , _docs :: Src.Docs
237234 , _decls :: Decls
238− , _unions :: Map.Map Name Union
239− , _aliases :: Map.Map Name Alias
240− , _binops :: Map.Map Name Binop
235+ , _unions :: Map.Map N.Name Union
236+ , _aliases :: Map.Map N.Name Alias
237+ , _binops :: Map.Map N.Name Binop
241238 , _effects :: Effects
242239 }
243240
244241
245−data Alias = Alias [Name] Type
246− deriving (Eq)
247−
248−
249−data Binop = Binop_ Binop.Associativity Binop.Precedence Name
250− deriving (Eq)
242+data Alias = Alias [N.Name] Type
243+data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name
251244
252245
253246data Union =
254247 Union
255− { _u_vars :: [Name]
248+ { _u_vars :: [N.Name]
256249 , _u_alts :: [Ctor]
257250 , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking
258251 , _u_opts :: CtorOpts -- CACHE which optimizations are available
259252 }
260− deriving (Eq)
261253
262254
263255data CtorOpts
@@ -267,8 +259,21 @@ data CtorOpts
267259 deriving (Eq, Ord)
268260
269261
270−data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args
271− deriving (Eq)
262+data Ctor =
263+ Ctor N.Name Index.ZeroBased Int [Type] -- CACHE length args
264+
265+
266+
267+-- DOCS
268+
269+
270+data Docs
271+ = NoDocs R.Region
272+ | YesDocs
273+ { _region :: R.Region
274+ , _overview :: B.ByteString
275+ , _comments :: Map.Map N.Name Text
276+ }
272277
273278
274279
@@ -276,8 +281,8 @@ data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args
276281
277282
278283data Exports
279− = ExportEverything A.Region
280− | Export (Map.Map Name (A.Located Export))
284+ = ExportEverything R.Region
285+ | Export (Map.Map N.Name (A.Located Export))
281286
282287
283288data Export
@@ -295,8 +300,8 @@ data Export
295300
296301data Effects
297302 = NoEffects
298− | Ports (Map.Map Name Port)
299− | Manager A.Region A.Region A.Region Manager
303+ | Ports (Map.Map N.Name Port)
304+ | Manager R.Region R.Region R.Region Manager
300305
301306
302307data Port
@@ -305,9 +310,9 @@ data Port
305310
306311
307312data Manager
308− = Cmd Name
309− | Sub Name
310− | Fx Name Name
313+ = Cmd N.Name
314+ | Sub N.Name
315+ | Fx N.Name N.Name
311316
312317
313318
@@ -342,7 +347,7 @@ instance Binary CtorOpts where
342347 0 -> return Normal
343348 1 -> return Enum
344349 2 -> return Unbox
345− _ -> fail "binary encoding of CtorOpts was corrupted"
350+ _ -> error "binary encoding of CtorOpts was corrupted"
346351
347352
348353instance Binary Annotation where
@@ -393,7 +398,7 @@ instance Binary AliasType where
393398 case n of
394399 0 -> liftM Holey get
395400 1 -> liftM Filled get
396− _ -> fail "binary encoding of AliasType was corrupted"
401+ _ -> error "binary encoding of AliasType was corrupted"
397402
398403
399404instance Binary FieldType where
compiler/src/AST/Module/Name.hsnew file+208
@@ -0,0 +1,208 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module AST.Module.Name
4+ ( Canonical(..)
5+ , basics, char, string
6+ , maybe, result, list, array, dict, tuple
7+ , platform, cmd, sub
8+ , virtualDom, debug, bitwise
9+ , jsonDecode, jsonEncode
10+ , webgl, texture, vector2, vector3, vector4, matrix4
11+ , isKernel, getKernel, canonicalIsKernel
12+ )
13+ where
14+
15+
16+import Prelude hiding (maybe)
17+import Control.Monad (liftM2)
18+import Data.Binary
19+
20+import qualified Elm.Name as N
21+import qualified Elm.Package as Pkg
22+
23+
24+
25+-- NAMES
26+
27+
28+data Canonical =
29+ Canonical
30+ { _package :: !Pkg.Name
31+ , _module :: !N.Name
32+ }
33+ deriving (Ord)
34+
35+
36+instance Eq Canonical where
37+ (==) (Canonical pkg home) (Canonical pkg' home') =
38+ home == home' && pkg == pkg'
39+
40+
41+
42+-- PRIMITIVES
43+
44+
45+{-# NOINLINE basics #-}
46+basics :: Canonical
47+basics = Canonical Pkg.core "Basics"
48+
49+
50+{-# NOINLINE char #-}
51+char :: Canonical
52+char = Canonical Pkg.core N.char
53+
54+
55+{-# NOINLINE string #-}
56+string :: Canonical
57+string = Canonical Pkg.core N.string
58+
59+
60+
61+-- CONTAINERS
62+
63+
64+{-# NOINLINE maybe #-}
65+maybe :: Canonical
66+maybe = Canonical Pkg.core N.maybe
67+
68+
69+{-# NOINLINE result #-}
70+result :: Canonical
71+result = Canonical Pkg.core N.result
72+
73+
74+{-# NOINLINE list #-}
75+list :: Canonical
76+list = Canonical Pkg.core N.list
77+
78+
79+{-# NOINLINE array #-}
80+array :: Canonical
81+array = Canonical Pkg.core N.array
82+
83+
84+{-# NOINLINE dict #-}
85+dict :: Canonical
86+dict = Canonical Pkg.core N.dict
87+
88+
89+{-# NOINLINE tuple #-}
90+tuple :: Canonical
91+tuple = Canonical Pkg.core N.tuple
92+
93+
94+
95+-- EFFECTS
96+
97+
98+{-# NOINLINE platform #-}
99+platform :: Canonical
100+platform = Canonical Pkg.core N.platform
101+
102+
103+{-# NOINLINE cmd #-}
104+cmd :: Canonical
105+cmd = Canonical Pkg.core "Platform.Cmd"
106+
107+
108+{-# NOINLINE sub #-}
109+sub :: Canonical
110+sub = Canonical Pkg.core "Platform.Sub"
111+
112+
113+
114+-- MISC
115+
116+
117+{-# NOINLINE virtualDom #-}
118+virtualDom :: Canonical
119+virtualDom = Canonical Pkg.virtualDom N.virtualDom
120+
121+
122+{-# NOINLINE debug #-}
123+debug :: Canonical
124+debug = Canonical Pkg.core N.debug
125+
126+
127+{-# NOINLINE bitwise #-}
128+bitwise :: Canonical
129+bitwise = Canonical Pkg.core N.bitwise
130+
131+
132+
133+-- JSON
134+
135+
136+{-# NOINLINE jsonDecode #-}
137+jsonDecode :: Canonical
138+jsonDecode = Canonical Pkg.json "Json.Decode"
139+
140+
141+{-# NOINLINE jsonEncode #-}
142+jsonEncode :: Canonical
143+jsonEncode = Canonical Pkg.json "Json.Encode"
144+
145+
146+
147+-- WEBGL
148+
149+
150+{-# NOINLINE webgl #-}
151+webgl :: Canonical
152+webgl = Canonical Pkg.webgl "WebGL"
153+
154+
155+{-# NOINLINE texture #-}
156+texture :: Canonical
157+texture = Canonical Pkg.webgl "WebGL.Texture"
158+
159+
160+{-# NOINLINE vector2 #-}
161+vector2 :: Canonical
162+vector2 = Canonical Pkg.linearAlgebra "Math.Vector2"
163+
164+
165+{-# NOINLINE vector3 #-}
166+vector3 :: Canonical
167+vector3 = Canonical Pkg.linearAlgebra "Math.Vector3"
168+
169+
170+{-# NOINLINE vector4 #-}
171+vector4 :: Canonical
172+vector4 = Canonical Pkg.linearAlgebra "Math.Vector4"
173+
174+
175+{-# NOINLINE matrix4 #-}
176+matrix4 :: Canonical
177+matrix4 = Canonical Pkg.linearAlgebra "Math.Matrix4"
178+
179+
180+
181+-- IS KERNEL
182+
183+
184+isKernel :: N.Name -> Bool
185+isKernel name =
186+ N.startsWith "Elm.Kernel." name
187+
188+
189+getKernel :: N.Name -> N.Name
190+getKernel name =
191+ N.drop 11 name
192+
193+
194+canonicalIsKernel :: Canonical -> Bool
195+canonicalIsKernel (Canonical _ name) =
196+ isKernel name
197+
198+
199+
200+-- BINARY
201+
202+
203+instance Binary Canonical where
204+ put (Canonical a b) =
205+ put a >> put b
206+
207+ get =
208+ liftM2 Canonical get get
compiler/src/AST/Optimized.hs+104−141
@@ -3,41 +3,35 @@ module AST.Optimized
33 ( Def(..)
44 , Expr(..)
55 , Global(..)
6+ , kernel
67 , Path(..)
78 , Destructor(..)
89 , Decider(..)
910 , Choice(..)
10− , GlobalGraph(..)
11− , LocalGraph(..)
11+ , Graph(..)
1212 , Main(..)
1313 , Node(..)
1414 , EffectsType(..)
15− , empty
16− , addGlobalGraph
17− , addLocalGraph
18− , addKernel
19− , toKernelGlobal
15+ , KContent(..)
16+ , KChunk(..)
2017 )
2118 where
2219
2320
2421import Control.Monad (liftM, liftM2, liftM3, liftM4)
25−import Data.Binary (Binary, get, put, getWord8, putWord8)
22+import Data.Binary
23+import qualified Data.ByteString as BS
2624import qualified Data.Map as Map
27−import qualified Data.Name as Name
28−import Data.Name (Name)
2925import qualified Data.Set as Set
26+import Data.Text (Text)
3027
3128import qualified AST.Canonical as Can
32−import qualified AST.Utils.Shader as Shader
29+import qualified AST.Module.Name as ModuleName
3330import qualified Data.Index as Index
34−import qualified Elm.Float as EF
35−import qualified Elm.Kernel as K
36−import qualified Elm.ModuleName as ModuleName
31+import qualified Elm.Name as N
3732import qualified Elm.Package as Pkg
38−import qualified Elm.String as ES
3933import qualified Optimize.DecisionTree as DT
40−import qualified Reporting.Annotation as A
34+import qualified Reporting.Region as R
4135
4236
4337
@@ -46,35 +40,43 @@ import qualified Reporting.Annotation as A
4640
4741data Expr
4842 = Bool Bool
49− | Chr ES.String
50− | Str ES.String
43+ | Chr Text
44+ | Str Text
5145 | Int Int
52− | Float EF.Float
53− | VarLocal Name
46+ | Float Double
47+ | VarLocal N.Name
5448 | VarGlobal Global
5549 | VarEnum Global Index.ZeroBased
5650 | VarBox Global
57− | VarCycle ModuleName.Canonical Name
58− | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)
59− | VarKernel Name Name
51+ | VarCycle ModuleName.Canonical N.Name
52+ | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)
53+ | VarKernel N.Name N.Name
6054 | List [Expr]
61− | Function [Name] Expr
55+ | Function [N.Name] Expr
6256 | Call Expr [Expr]
63− | TailCall Name [(Name, Expr)]
57+ | TailCall N.Name [(N.Name, Expr)]
6458 | If [(Expr, Expr)] Expr
6559 | Let Def Expr
6660 | Destruct Destructor Expr
67− | Case Name Name (Decider Choice) [(Int, Expr)]
68− | Accessor Name
69− | Access Expr Name
70− | Update Expr (Map.Map Name Expr)
71− | Record (Map.Map Name Expr)
61+ | Case N.Name N.Name (Decider Choice) [(Int, Expr)]
62+ | Accessor N.Name
63+ | Access Expr N.Name
64+ | Update Expr (Map.Map N.Name Expr)
65+ | Record (Map.Map N.Name Expr)
7266 | Unit
7367 | Tuple Expr Expr (Maybe Expr)
74− | Shader Shader.Source (Set.Set Name) (Set.Set Name)
68+ | Shader Text
7569
7670
77−data Global = Global ModuleName.Canonical Name
71+data Global = Global ModuleName.Canonical N.Name
72+ deriving (Eq, Ord)
73+
74+
75+-- Provide "List" not "Elm.Kernel.List"
76+--
77+kernel :: N.Name -> Global
78+kernel home =
79+ Global (ModuleName.Canonical Pkg.kernel home) N.dollar
7880
7981
8082
@@ -82,19 +84,19 @@ data Global = Global ModuleName.Canonical Name
8284
8385
8486data Def
85− = Def Name Expr
86− | TailDef Name [Name] Expr
87+ = Def N.Name Expr
88+ | TailDef N.Name [N.Name] Expr
8789
8890
8991data Destructor =
90− Destructor Name Path
92+ Destructor N.Name Path
9193
9294
9395data Path
9496 = Index Index.ZeroBased Path
95− | Field Name Path
97+ | Field N.Name Path
9698 | Unbox Path
97− | Root Name
99+ | Root N.Name
98100
99101
100102
@@ -125,18 +127,11 @@ data Choice
125127-- OBJECT GRAPH
126128
127129
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
130+data Graph =
131+ Graph
132+ { _mains :: Map.Map ModuleName.Canonical Main
133+ , _nodes :: Map.Map Global Node
134+ , _fields :: Map.Map N.Name Int
140135 }
141136
142137
@@ -150,14 +145,14 @@ data Main
150145
151146data Node
152147 = Define Expr (Set.Set Global)
153− | DefineTailFunc [Name] Expr (Set.Set Global)
148+ | DefineTailFunc [N.Name] Expr (Set.Set Global)
154149 | Ctor Index.ZeroBased Int
155150 | Enum Index.ZeroBased
156151 | Box
157152 | Link Global
158− | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)
153+ | Cycle [(N.Name, Expr)] (Set.Set Global)
159154 | Manager EffectsType
160− | Kernel [K.Chunk] (Set.Set Global)
155+ | Kernel KContent (Maybe KContent)
161156 | PortIncoming Expr (Set.Set Global)
162157 | PortOutgoing Expr (Set.Set Global)
163158
@@ -165,77 +160,19 @@ data Node
165160data EffectsType = Cmd | Sub | Fx
166161
167162
163+data KContent =
164+ KContent [KChunk] (Set.Set Global)
168165
169−-- GRAPHS
170−
171−
172−{-# NOINLINE empty #-}
173−empty :: GlobalGraph
174−empty =
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−
193−
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
222−
223−
224−
225−-- INSTANCES
226166
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
167+data KChunk
168+ = JS BS.ByteString
169+ | ElmVar ModuleName.Canonical N.Name
170+ | JsVar N.Name N.Name
171+ | ElmField N.Name
172+ | JsField Int
173+ | JsEnum Int
174+ | Debug
175+ | Prod
239176
240177
241178
@@ -276,7 +213,7 @@ instance Binary Expr where
276213 Record a -> putWord8 23 >> put a
277214 Unit -> putWord8 24
278215 Tuple a b c -> putWord8 25 >> put a >> put b >> put c
279− Shader a b c -> putWord8 26 >> put a >> put b >> put c
216+ Shader a -> putWord8 26 >> put a
280217
281218 get =
282219 do word <- getWord8
@@ -307,8 +244,8 @@ instance Binary Expr where
307244 23 -> liftM Record get
308245 24 -> pure Unit
309246 25 -> liftM3 Tuple get get get
310− 26 -> liftM3 Shader get get get
311− _ -> fail "problem getting Opt.Expr binary"
247+ 26 -> liftM Shader get
248+ _ -> error "problem getting Opt.Expr binary"
312249
313250
314251instance Binary Def where
@@ -322,7 +259,7 @@ instance Binary Def where
322259 case word of
323260 0 -> liftM2 Def get get
324261 1 -> liftM3 TailDef get get get
325− _ -> fail "problem getting Opt.Def binary"
262+ _ -> error "problem getting Opt.Def binary"
326263
327264
328265instance Binary Destructor where
@@ -345,7 +282,7 @@ instance Binary Path where
345282 1 -> liftM2 Field get get
346283 2 -> liftM Unbox get
347284 3 -> liftM Root get
348− _ -> fail "problem getting Opt.Path binary"
285+ _ -> error "problem getting Opt.Path binary"
349286
350287
351288instance (Binary a) => Binary (Decider a) where
@@ -361,7 +298,7 @@ instance (Binary a) => Binary (Decider a) where
361298 0 -> liftM Leaf get
362299 1 -> liftM3 Chain get get get
363300 2 -> liftM3 FanOut get get get
364− _ -> fail "problem getting Opt.Decider binary"
301+ _ -> error "problem getting Opt.Decider binary"
365302
366303
367304instance Binary Choice where
@@ -375,18 +312,13 @@ instance Binary Choice where
375312 case word of
376313 0 -> liftM Inline get
377314 1 -> liftM Jump get
378− _ -> fail "problem getting Opt.Choice binary"
379−
315+ _ -> error "problem getting Opt.Choice binary"
380316
381317
382−instance Binary GlobalGraph where
383− get = liftM2 GlobalGraph get get
384− put (GlobalGraph a b) = put a >> put b
385318
386−
387−instance Binary LocalGraph where
388− get = liftM3 LocalGraph get get get
389− put (LocalGraph a b c) = put a >> put b >> put c
319+instance Binary Graph where
320+ get = liftM3 Graph get get get
321+ put (Graph a b c) = put a >> put b >> put c
390322
391323
392324instance Binary Main where
@@ -400,7 +332,7 @@ instance Binary Main where
400332 case word of
401333 0 -> return Static
402334 1 -> liftM2 Dynamic get get
403− _ -> fail "problem getting Opt.Main binary"
335+ _ -> error "problem getting Opt.Main binary"
404336
405337
406338instance Binary Node where
@@ -412,7 +344,7 @@ instance Binary Node where
412344 Enum a -> putWord8 3 >> put a
413345 Box -> putWord8 4
414346 Link a -> putWord8 5 >> put a
415− Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d
347+ Cycle a b -> putWord8 6 >> put a >> put b
416348 Manager a -> putWord8 7 >> put a
417349 Kernel a b -> putWord8 8 >> put a >> put b
418350 PortIncoming a b -> putWord8 9 >> put a >> put b
@@ -427,12 +359,12 @@ instance Binary Node where
427359 3 -> liftM Enum get
428360 4 -> return Box
429361 5 -> liftM Link get
430− 6 -> liftM4 Cycle get get get get
362+ 6 -> liftM2 Cycle get get
431363 7 -> liftM Manager get
432364 8 -> liftM2 Kernel get get
433365 9 -> liftM2 PortIncoming get get
434366 10 -> liftM2 PortOutgoing get get
435− _ -> fail "problem getting Opt.Node binary"
367+ _ -> error "problem getting Opt.Node binary"
436368
437369
438370instance Binary EffectsType where
@@ -448,4 +380,35 @@ instance Binary EffectsType where
448380 0 -> return Cmd
449381 1 -> return Sub
450382 2 -> return Fx
451− _ -> fail "problem getting Opt.EffectsType binary"
383+ _ -> error "problem getting Opt.EffectsType binary"
384+
385+
386+instance Binary KContent where
387+ get = liftM2 KContent get get
388+ put (KContent a b) = put a >> put b
389+
390+
391+instance Binary KChunk where
392+ put chunk =
393+ case chunk of
394+ JS a -> putWord8 0 >> put a
395+ ElmVar a b -> putWord8 1 >> put a >> put b
396+ JsVar a b -> putWord8 2 >> put a >> put b
397+ ElmField a -> putWord8 3 >> put a
398+ JsField a -> putWord8 4 >> put a
399+ JsEnum a -> putWord8 5 >> put a
400+ Debug -> putWord8 6
401+ Prod -> putWord8 7
402+
403+ get =
404+ do word <- getWord8
405+ case word of
406+ 0 -> liftM JS get
407+ 1 -> liftM2 ElmVar get get
408+ 2 -> liftM2 JsVar get get
409+ 3 -> liftM ElmField get
410+ 4 -> liftM JsField get
411+ 5 -> liftM JsEnum get
412+ 6 -> return Debug
413+ 7 -> return Prod
414+ _ -> error "problem deserializing AST.Optimized.KChunk"
compiler/src/AST/Source.hs+72−88
@@ -1,22 +1,16 @@
11{-# OPTIONS_GHC -Wall #-}
22module AST.Source
33 ( Expr, Expr_(..), VarType(..)
4+ , Decl, Decl_(..)
45 , Def(..)
56 , Pattern, Pattern_(..)
67 , Type, Type_(..)
78 , Module(..)
8− , getName
9− , getImportName
9+ , Header(..)
10+ , Docs(..)
1011 , Import(..)
11− , Value(..)
12− , Union(..)
13− , Alias(..)
14− , Infix(..)
15− , Port(..)
1612 , Effects(..)
1713 , Manager(..)
18− , Docs(..)
19− , Comment(..)
2014 , Exposing(..)
2115 , Exposed(..)
2216 , Privacy(..)
@@ -24,15 +18,14 @@ module AST.Source
2418 where
2519
2620
27−import Data.Name (Name)
28−import qualified Data.Name as Name
21+import qualified Data.ByteString as B
22+import Data.Text (Text)
2923
3024import qualified AST.Utils.Binop as Binop
3125import 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
26+import qualified Elm.Name as N
3527import qualified Reporting.Annotation as A
28+import qualified Reporting.Region as R
3629
3730
3831
@@ -43,31 +36,31 @@ type Expr = A.Located Expr_
4336
4437
4538data Expr_
46− = Chr ES.String
47− | Str ES.String
39+ = Chr Text
40+ | Str Text
4841 | Int Int
49− | Float EF.Float
50− | Var VarType Name
51− | VarQual VarType Name Name
42+ | Float Double
43+ | Var VarType N.Name
44+ | VarQual VarType N.Name N.Name
5245 | List [Expr]
53− | Op Name
46+ | Op N.Name
5447 | Negate Expr
55− | Binops [(Expr, A.Located Name)] Expr
48+ | Binops [(Expr, A.Located N.Name)] Expr
5649 | Lambda [Pattern] Expr
5750 | Call Expr [Expr]
5851 | If [(Expr, Expr)] Expr
5952 | Let [A.Located Def] Expr
6053 | Case Expr [(Pattern, Expr)]
61− | Accessor Name
62− | Access Expr (A.Located Name)
63− | Update (A.Located Name) [(A.Located Name, Expr)]
64− | Record [(A.Located Name, Expr)]
54+ | Accessor N.Name
55+ | Access Expr (A.Located N.Name)
56+ | Update (A.Located N.Name) [(A.Located N.Name, Expr)]
57+ | Record [(A.Located N.Name, Expr)]
6558 | Unit
6659 | Tuple Expr Expr [Expr]
67− | Shader Shader.Source Shader.Types
60+ | Shader Text Text Shader.Shader
6861
6962
70−data VarType = LowVar | CapVar
63+data VarType = Value | Ctor
7164
7265
7366
@@ -75,7 +68,8 @@ data VarType = LowVar | CapVar
7568
7669
7770data Def
78− = Define (A.Located Name) [Pattern] Expr (Maybe Type)
71+ = Annotate N.Name Type
72+ | Define (A.Located N.Name) [Pattern] Expr
7973 | Destruct Pattern Expr
8074
8175
@@ -88,17 +82,17 @@ type Pattern = A.Located Pattern_
8882
8983data Pattern_
9084 = PAnything
91− | PVar Name
92− | PRecord [A.Located Name]
93− | PAlias Pattern (A.Located Name)
85+ | PVar N.Name
86+ | PRecord [A.Located N.Name]
87+ | PAlias Pattern (A.Located N.Name)
9488 | PUnit
9589 | PTuple Pattern Pattern [Pattern]
96− | PCtor A.Region Name [Pattern]
97− | PCtorQual A.Region Name Name [Pattern]
90+ | PCtor R.Region N.Name [Pattern]
91+ | PCtorQual R.Region N.Name N.Name [Pattern]
9892 | PList [Pattern]
9993 | PCons Pattern Pattern
100− | PChr ES.String
101− | PStr ES.String
94+ | PChr Text
95+ | PStr Text
10296 | PInt Int
10397
10498
@@ -112,81 +106,71 @@ type Type =
112106
113107data Type_
114108 = TLambda Type Type
115− | TVar Name
116− | TType A.Region Name [Type]
117− | TTypeQual A.Region Name Name [Type]
118− | TRecord [(A.Located Name, Type)] (Maybe (A.Located Name))
109+ | TVar N.Name
110+ | TType R.Region N.Name [Type]
111+ | TTypeQual R.Region N.Name N.Name [Type]
112+ | TRecord [(A.Located N.Name, Type)] (Maybe (A.Located N.Name))
119113 | TUnit
120114 | TTuple Type Type [Type]
121115
122116
123117
124−-- MODULE
118+-- DECLARATIONS
125119
126120
127−data Module =
128− Module
129− { _name :: Maybe (A.Located Name)
130− , _exports :: A.Located Exposing
131− , _docs :: Docs
132− , _imports :: [Import]
133− , _values :: [A.Located Value]
134− , _unions :: [A.Located Union]
135− , _aliases :: [A.Located Alias]
136− , _binops :: [A.Located Infix]
137− , _effects :: Effects
138− }
121+type Decl = A.Located Decl_
139122
140123
141−getName :: Module -> Name
142−getName (Module maybeName _ _ _ _ _ _ _ _) =
143− case maybeName of
144− Just (A.At _ name) ->
145− name
124+data Decl_
125+ = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type])]
126+ | Alias (A.Located N.Name) [A.Located N.Name] Type
127+ | Binop N.Name Binop.Associativity Binop.Precedence N.Name
128+ | Port (A.Located N.Name) Type
129+ | Docs Text
130+ | Annotation (A.Located N.Name) Type
131+ | Definition (A.Located N.Name) [Pattern] Expr
132+
133+
134+
135+-- MODULE
146136
147− Nothing ->
148− Name._Main
149137
138+data Module decls =
139+ Module (Maybe Header) [Import] decls
150140
151−getImportName :: Import -> Name
152−getImportName (Import (A.At _ name) _ _) =
153− name
141+
142+data Header
143+ = Header
144+ { _name :: N.Name
145+ , _effects :: Effects
146+ , _exports :: A.Located Exposing
147+ , _docs :: Docs
148+ }
154149
155150
156151data Import =
157152 Import
158− { _import :: A.Located Name
159− , _alias :: Maybe Name
153+ { _import :: A.Located N.Name
154+ , _alias :: Maybe N.Name
160155 , _exposing :: Exposing
161156 }
162157
163158
164−data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
165−data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
166−data Alias = Alias (A.Located Name) [A.Located Name] Type
167−data Infix = Infix Name Binop.Associativity Binop.Precedence Name
168−data Port = Port (A.Located Name) Type
159+data Docs
160+ = NoDocs R.Region
161+ | YesDocs R.Region B.ByteString
169162
170163
171164data Effects
172165 = NoEffects
173− | Ports [Port]
174− | Manager A.Region Manager
166+ | Ports R.Region
167+ | Manager R.Region Manager
175168
176169
177170data Manager
178− = Cmd (A.Located Name)
179− | Sub (A.Located Name)
180− | Fx (A.Located Name) (A.Located Name)
181−
182−
183−data Docs
184− = NoDocs A.Region
185− | YesDocs Comment [(Name, Comment)]
186−
187−
188−newtype Comment =
189− Comment P.Snippet
171+ = Cmd (A.Located N.Name)
172+ | Sub (A.Located N.Name)
173+ | Fx (A.Located N.Name) (A.Located N.Name)
190174
191175
192176
@@ -195,15 +179,15 @@ newtype Comment =
195179
196180data Exposing
197181 = Open
198− | Explicit [Exposed]
182+ | Explicit ![A.Located Exposed]
199183
200184
201185data Exposed
202− = Lower (A.Located Name)
203− | Upper (A.Located Name) Privacy
204− | Operator A.Region Name
186+ = Lower !N.Name
187+ | Upper !N.Name !Privacy
188+ | Operator !N.Name
205189
206190
207191data Privacy
208− = Public A.Region
192+ = Public
209193 | 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+10−65
@@ -1,42 +1,29 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE EmptyDataDecls #-}
32module AST.Utils.Shader
4− ( Source
5− , Types(..)
3+ ( Shader(..)
64 , Type(..)
7− , fromChars
8− , toJsStringBuilder
95 )
106 where
117
128
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
189import qualified Data.Map as Map
19−import qualified Data.Name as Name
10+import qualified Elm.Name as N
2011
2112
2213
23−-- SOURCE
24−
25−
26−newtype Source =
27− Source BS.ByteString
14+-- SHADERS
2815
2916
17+data Shader =
18+ Shader
19+ { _attribute :: Map.Map N.Name Type
20+ , _uniform :: Map.Map N.Name Type
21+ , _varying :: Map.Map N.Name Type
22+ }
3023
31−-- TYPES
3224
3325
34−data Types =
35− Types
36− { _attribute :: Map.Map Name.Name Type
37− , _uniform :: Map.Map Name.Name Type
38− , _varying :: Map.Map Name.Name Type
39− }
26+-- GL TYPES
4027
4128
4229data Type
@@ -47,45 +34,3 @@ data Type
4734 | V4
4835 | M4
4936 | 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+5−4
@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module AST.Utils.Type
34 ( delambda
45 , dealias
@@ -9,9 +10,9 @@ module AST.Utils.Type
910
1011
1112import qualified Data.Map as Map
12−import qualified Data.Name as Name
1313
1414import AST.Canonical (Type(..), AliasType(..), FieldType(..))
15+import qualified Elm.Name as N
1516
1617
1718
@@ -32,7 +33,7 @@ delambda tipe =
3233-- DEALIAS
3334
3435
35−dealias :: [(Name.Name, Type)] -> AliasType -> Type
36+dealias :: [(N.Name, Type)] -> AliasType -> Type
3637dealias args aliasType =
3738 case aliasType of
3839 Holey tipe ->
@@ -42,7 +43,7 @@ dealias args aliasType =
4243 tipe
4344
4445
45−dealiasHelp :: Map.Map Name.Name Type -> Type -> Type
46+dealiasHelp :: Map.Map N.Name Type -> Type -> Type
4647dealiasHelp typeTable tipe =
4748 case tipe of
4849 TLambda a b ->
@@ -72,7 +73,7 @@ dealiasHelp typeTable tipe =
7273 (fmap (dealiasHelp typeTable) maybeC)
7374
7475
75−dealiasField :: Map.Map Name.Name Type -> FieldType -> FieldType
76+dealiasField :: Map.Map N.Name Type -> FieldType -> FieldType
7677dealiasField typeTable (FieldType index tipe) =
7778 FieldType index (dealiasHelp typeTable tipe)
7879
compiler/src/AST/Valid.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module AST.Valid
4+ ( Expr, Expr_(..)
5+ , Def(..)
6+ , Module(..)
7+ , Decl(..)
8+ , Union(..)
9+ , Alias(..)
10+ , Binop(..)
11+ , Effects(..)
12+ , Port(..)
13+ , Manager(..)
14+ , defaultModule
15+ )
16+ where
17+
18+
19+import qualified Data.Map as Map
20+import Data.Text (Text)
21+
22+import qualified AST.Utils.Binop as Binop
23+import qualified AST.Source as Src
24+import qualified AST.Utils.Shader as Shader
25+import qualified Elm.Name as N
26+import qualified Reporting.Annotation as A
27+import qualified Reporting.Region as R
28+
29+
30+
31+-- EXPRESSIONS
32+
33+
34+type Expr = A.Located Expr_
35+
36+
37+data Expr_
38+ = Chr Text
39+ | Str Text
40+ | Int Int
41+ | Float Double
42+ | Var Src.VarType N.Name
43+ | VarQual Src.VarType N.Name N.Name
44+ | List [Expr]
45+ | Op N.Name
46+ | Negate Expr
47+ | Binops [(Expr, A.Located N.Name)] Expr
48+ | Lambda [Src.Pattern] Expr
49+ | Call Expr [Expr]
50+ | If [(Expr, Expr)] Expr
51+ | Let [Def] Expr
52+ | Case Expr [(Src.Pattern, Expr)]
53+ | Accessor N.Name
54+ | Access Expr (A.Located N.Name)
55+ | Update (A.Located N.Name) [(A.Located N.Name, Expr)]
56+ | Record [(A.Located N.Name, Expr)]
57+ | Unit
58+ | Tuple Expr Expr [Expr]
59+ | Shader Text Text Shader.Shader
60+
61+
62+
63+-- DEFINITIONS
64+
65+
66+data Def
67+ = Define R.Region (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)
68+ | Destruct R.Region Src.Pattern Expr
69+
70+
71+
72+-- MODULE
73+
74+
75+data Module =
76+ Module
77+ { _name :: N.Name
78+ , _overview :: Src.Docs
79+ , _docs :: Map.Map N.Name Text
80+ , _exports :: A.Located Src.Exposing
81+ , _imports :: [Src.Import]
82+ , _decls :: [A.Located Decl]
83+ , _unions :: [Union]
84+ , _aliases :: [Alias]
85+ , _binop :: [Binop]
86+ , _effects :: Effects
87+ }
88+
89+
90+data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)
91+data Union = Union R.Region (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Src.Type])]
92+data Alias = Alias R.Region (A.Located N.Name) [A.Located N.Name] Src.Type
93+data Binop = Binop N.Name Binop.Associativity Binop.Precedence N.Name
94+
95+
96+data Effects
97+ = NoEffects
98+ | Ports [Port]
99+ | Manager R.Region Manager
100+
101+
102+data Manager
103+ = Cmd (A.Located N.Name)
104+ | Sub (A.Located N.Name)
105+ | Fx (A.Located N.Name) (A.Located N.Name)
106+
107+
108+data Port = Port (A.Located N.Name) Src.Type
109+
110+
111+defaultModule :: Map.Map N.Name Text -> [Src.Import] -> [A.Located Decl] -> [Union] -> [Alias] -> [Binop] -> Module
112+defaultModule docs imports decls unions aliases binop =
113+ Module
114+ { _name = "Main"
115+ , _overview = Src.NoDocs R.one
116+ , _docs = docs
117+ , _exports = A.At R.one Src.Open
118+ , _imports = imports
119+ , _decls = decls
120+ , _unions = unions
121+ , _aliases = aliases
122+ , _binop = binop
123+ , _effects = NoEffects
124+ }
compiler/src/Canonicalize/Effects.hs+37−36
@@ -8,16 +8,17 @@ module Canonicalize.Effects
88
99import qualified Data.Foldable as F
1010import qualified Data.Map as Map
11−import qualified Data.Name as Name
1211
1312import qualified AST.Canonical as Can
14−import qualified AST.Source as Src
13+import qualified AST.Valid as Valid
14+import qualified AST.Module.Name as ModuleName
1515import qualified AST.Utils.Type as Type
1616import qualified Canonicalize.Environment as Env
1717import qualified Canonicalize.Type as Type
18−import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Name as N
1919import qualified Reporting.Annotation as A
2020import qualified Reporting.Error.Canonicalize as Error
21+import qualified Reporting.Region as R
2122import qualified Reporting.Result as Result
2223
2324
@@ -35,38 +36,38 @@ type Result i w a =
3536
3637canonicalize
3738 :: Env.Env
38− -> [A.Located Src.Value]
39− -> Map.Map Name.Name union
40− -> Src.Effects
39+ -> [A.Located Valid.Decl]
40+ -> Map.Map N.Name union
41+ -> Valid.Effects
4142 -> Result i w Can.Effects
42−canonicalize env values unions effects =
43+canonicalize env decls unions effects =
4344 case effects of
44− Src.NoEffects ->
45+ Valid.NoEffects ->
4546 Result.ok Can.NoEffects
4647
47− Src.Ports ports ->
48+ Valid.Ports ports ->
4849 do pairs <- traverse (canonicalizePort env) ports
4950 return $ Can.Ports (Map.fromList pairs)
5051
51− Src.Manager region manager ->
52− let dict = Map.fromList (map toNameRegion values) in
52+ Valid.Manager region manager ->
53+ let dict = Map.fromList (map toNameRegion decls) in
5354 Can.Manager
5455 <$> verifyManager region dict "init"
5556 <*> verifyManager region dict "onEffects"
5657 <*> verifyManager region dict "onSelfMsg"
5758 <*>
5859 case manager of
59− Src.Cmd cmdType ->
60+ Valid.Cmd cmdType ->
6061 Can.Cmd
6162 <$> verifyEffectType cmdType unions
6263 <* verifyManager region dict "cmdMap"
6364
64− Src.Sub subType ->
65+ Valid.Sub subType ->
6566 Can.Sub
6667 <$> verifyEffectType subType unions
6768 <* verifyManager region dict "subMap"
6869
69− Src.Fx cmdType subType ->
70+ Valid.Fx cmdType subType ->
7071 Can.Fx
7172 <$> verifyEffectType cmdType unions
7273 <*> verifyEffectType subType unions
@@ -78,12 +79,12 @@ canonicalize env values unions effects =
7879-- CANONICALIZE PORT
7980
8081
81−canonicalizePort :: Env.Env -> Src.Port -> Result i w (Name.Name, Can.Port)
82−canonicalizePort env (Src.Port (A.At region portName) tipe) =
82+canonicalizePort :: Env.Env -> Valid.Port -> Result i w (N.Name, Can.Port)
83+canonicalizePort env (Valid.Port (A.At region portName) tipe) =
8384 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
8485 case reverse (Type.delambda (Type.deepDealias ctipe)) of
8586 Can.TType home name [msg] : revArgs
86− | home == ModuleName.cmd && name == Name.cmd ->
87+ | home == ModuleName.cmd && name == N.cmd ->
8788 case revArgs of
8889 [] ->
8990 Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg)
@@ -104,7 +105,7 @@ canonicalizePort env (Src.Port (A.At region portName) tipe) =
104105 _ ->
105106 Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs)))
106107
107− | home == ModuleName.sub && name == Name.sub ->
108+ | home == ModuleName.sub && name == N.sub ->
108109 case revArgs of
109110 [Can.TLambda incomingType (Can.TVar msg1)] ->
110111 case msg of
@@ -130,7 +131,7 @@ canonicalizePort env (Src.Port (A.At region portName) tipe) =
130131-- VERIFY MANAGER
131132
132133
133−verifyEffectType :: A.Located Name.Name -> Map.Map Name.Name a -> Result i w Name.Name
134+verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result i w N.Name
134135verifyEffectType (A.At region name) unions =
135136 if Map.member name unions then
136137 Result.ok name
@@ -138,14 +139,14 @@ verifyEffectType (A.At region name) unions =
138139 Result.throw (Error.EffectNotFound region name)
139140
140141
141−toNameRegion :: A.Located Src.Value -> (Name.Name, A.Region)
142−toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) =
142+toNameRegion :: A.Located Valid.Decl -> (N.Name, R.Region)
143+toNameRegion (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
143144 (name, region)
144145
145146
146−verifyManager :: A.Region -> Map.Map Name.Name A.Region -> Name.Name -> Result i w A.Region
147−verifyManager tagRegion values name =
148− case Map.lookup name values of
147+verifyManager :: R.Region -> Map.Map N.Name R.Region -> N.Name -> Result i w R.Region
148+verifyManager tagRegion decls name =
149+ case Map.lookup name decls of
149150 Just region ->
150151 Result.ok region
151152
@@ -209,43 +210,43 @@ checkFieldPayload (Can.FieldType _ tipe) =
209210 checkPayload tipe
210211
211212
212−isIntFloatBool :: ModuleName.Canonical -> Name.Name -> Bool
213+isIntFloatBool :: ModuleName.Canonical -> N.Name -> Bool
213214isIntFloatBool home name =
214215 home == ModuleName.basics
215216 &&
216− (name == Name.int || name == Name.float || name == Name.bool)
217+ (name == N.int || name == N.float || name == N.bool)
217218
218219
219−isString :: ModuleName.Canonical -> Name.Name -> Bool
220+isString :: ModuleName.Canonical -> N.Name -> Bool
220221isString home name =
221222 home == ModuleName.string
222223 &&
223− name == Name.string
224+ name == N.string
224225
225226
226−isJson :: ModuleName.Canonical -> Name.Name -> Bool
227+isJson :: ModuleName.Canonical -> N.Name -> Bool
227228isJson home name =
228229 home == ModuleName.jsonEncode
229230 &&
230− name == Name.value
231+ name == N.value
231232
232233
233−isList :: ModuleName.Canonical -> Name.Name -> Bool
234+isList :: ModuleName.Canonical -> N.Name -> Bool
234235isList home name =
235236 home == ModuleName.list
236237 &&
237− name == Name.list
238+ name == N.list
238239
239240
240−isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
241+isMaybe :: ModuleName.Canonical -> N.Name -> Bool
241242isMaybe home name =
242243 home == ModuleName.maybe
243244 &&
244− name == Name.maybe
245+ name == N.maybe
245246
246247
247−isArray :: ModuleName.Canonical -> Name.Name -> Bool
248+isArray :: ModuleName.Canonical -> N.Name -> Bool
248249isArray home name =
249250 home == ModuleName.array
250251 &&
251− name == Name.array
252+ name == N.array
compiler/src/Canonicalize/Environment.hs+42−72
@@ -4,8 +4,6 @@ module Canonicalize.Environment
44 ( Env(..)
55 , Exposed
66 , Qualified
7− , Info(..)
8− , mergeInfo
97 , Var(..)
108 , Type(..)
119 , Ctor(..)
@@ -22,15 +20,15 @@ module Canonicalize.Environment
2220
2321import qualified Data.Map.Merge.Strict as Map
2422import qualified Data.Map.Strict as Map
25−import qualified Data.Name as Name
26−import qualified Data.OneOrMore as OneOrMore
23+import qualified Data.Map.Strict.Internal as I
2724
2825import qualified AST.Utils.Binop as Binop
2926import qualified AST.Canonical as Can
27+import qualified AST.Module.Name as ModuleName
3028import qualified Data.Index as Index
31−import qualified Elm.ModuleName as ModuleName
32−import qualified Reporting.Annotation as A
29+import qualified Elm.Name as N
3330import qualified Reporting.Error.Canonicalize as Error
31+import qualified Reporting.Region as R
3432import qualified Reporting.Result as Result
3533
3634
@@ -49,7 +47,7 @@ type Result i w a =
4947data Env =
5048 Env
5149 { _home :: ModuleName.Canonical
52− , _vars :: Map.Map Name.Name Var
50+ , _vars :: Map.Map N.Name Var
5351 , _types :: Exposed Type
5452 , _ctors :: Exposed Ctor
5553 , _binops :: Exposed Binop
@@ -60,34 +58,11 @@ data Env =
6058
6159
6260type Exposed a =
63− Map.Map Name.Name (Info a)
61+ Map.Map N.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 N.Name (Map.Map N.Name (Map.Map ModuleName.Canonical a))
9166
9267
9368
@@ -95,10 +70,9 @@ mergeInfo info1 info2 =
9570
9671
9772data Var
98− = Local A.Region
99− | TopLevel A.Region
100− | Foreign ModuleName.Canonical Can.Annotation
101− | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
73+ = Local R.Region
74+ | TopLevel R.Region
75+ | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
10276
10377
10478
@@ -106,7 +80,7 @@ data Var
10680
10781
10882data Type
109− = Alias Int ModuleName.Canonical [Name.Name] Can.Type
83+ = Alias Int ModuleName.Canonical [N.Name] Can.Type
11084 | Union Int ModuleName.Canonical
11185
11286
@@ -115,10 +89,10 @@ data Type
11589
11690
11791data Ctor
118− = RecordCtor ModuleName.Canonical [Name.Name] Can.Type
92+ = RecordCtor ModuleName.Canonical [N.Name] Can.Type
11993 | Ctor
12094 { _c_home :: ModuleName.Canonical
121− , _c_type :: Name.Name
95+ , _c_type :: N.Name
12296 , _c_union :: Can.Union
12397 , _c_index :: Index.ZeroBased
12498 , _c_args :: [Can.Type]
@@ -131,9 +105,9 @@ data Ctor
131105
132106data Binop =
133107 Binop
134− { _op :: Name.Name
108+ { _op :: N.Name
135109 , _op_home :: ModuleName.Canonical
136− , _op_name :: Name.Name
110+ , _op_name :: N.Name
137111 , _op_annotation :: Can.Annotation
138112 , _op_associativity :: Binop.Associativity
139113 , _op_precedence :: Binop.Precedence
@@ -144,7 +118,7 @@ data Binop =
144118-- VARIABLE -- ADD LOCALS
145119
146120
147−addLocals :: Map.Map Name.Name A.Region -> Env -> Result i w Env
121+addLocals :: Map.Map N.Name R.Region -> Env -> Result i w Env
148122addLocals names (Env home vars ts cs bs qvs qts qcs) =
149123 do newVars <-
150124 Map.mergeA
@@ -157,18 +131,15 @@ addLocals names (Env home vars ts cs bs qvs qts qcs) =
157131 Result.ok (Env home newVars ts cs bs qvs qts qcs)
158132
159133
160−addLocalLeft :: Name.Name -> A.Region -> Var
134+addLocalLeft :: N.Name -> R.Region -> Var
161135addLocalLeft _ region =
162136 Local region
163137
164138
165−addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
139+addLocalBoth :: N.Name -> R.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,33 +150,32 @@ addLocalBoth name region var =
179150
180151
181152
182−
183153-- FIND TYPE
184154
185155
186−findType :: A.Region -> Env -> Name.Name -> Result i w Type
156+findType :: R.Region -> Env -> N.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))
197167
198168
199−findTypeQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Type
169+findTypeQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Type
200170findTypeQual 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))
@@ -218,49 +188,49 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
218188-- FIND CTOR
219189
220190
221−findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
191+findCtor :: R.Region -> Env -> N.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.AmbiguousCtor region Nothing name (Map.keys homes))
229199
230200 Nothing ->
231− Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
201+ Result.throw (Error.NotFoundCtor region Nothing name (toPossibleNames cs qcs))
232202
233203
234−findCtorQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Ctor
204+findCtorQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Ctor
235205findCtorQual 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.AmbiguousCtor region (Just prefix) name (Map.keys homes))
244214
245215 Nothing ->
246− Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
216+ Result.throw (Error.NotFoundCtor region (Just prefix) name (toPossibleNames cs qcs))
247217
248218 Nothing ->
249− Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
219+ Result.throw (Error.NotFoundCtor region (Just prefix) name (toPossibleNames cs qcs))
250220
251221
252222
253223-- FIND BINOP
254224
255225
256−findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
226+findBinop :: R.Region -> Env -> N.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+16−18
@@ -15,11 +15,12 @@ module Canonicalize.Environment.Dups
1515
1616
1717import qualified Data.Map as Map
18−import qualified Data.Name as Name
1918
2019import qualified Data.OneOrMore as OneOrMore
20+import qualified Elm.Name as N
2121import qualified Reporting.Annotation as A
2222import qualified Reporting.Error.Canonicalize as Error
23+import qualified Reporting.Region as R
2324import qualified Reporting.Result as Result
2425
2526
@@ -28,12 +29,12 @@ import qualified Reporting.Result as Result
2829
2930
3031type Dict value =
31− Map.Map Name.Name (OneOrMore.OneOrMore (Info value))
32+ Map.Map N.Name (OneOrMore.OneOrMore (Info value))
3233
3334
3435data Info value =
3536 Info
36− { _region :: A.Region
37+ { _region :: R.Region
3738 , _value :: value
3839 }
3940
@@ -43,25 +44,22 @@ data Info value =
4344
4445
4546type ToError =
46− Name.Name -> A.Region -> A.Region -> Error.Error
47+ N.Name -> R.Region -> R.Region -> Error.Error
4748
4849
49−detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name a)
50+detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map N.Name a)
5051detect toError dict =
5152 Map.traverseWithKey (detectHelp toError) dict
5253
5354
54−detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a
55+detectHelp :: ToError -> N.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a
5556detectHelp toError name values =
5657 case values of
5758 OneOrMore.One (Info _ value) ->
5859 return value
5960
60− OneOrMore.More left right ->
61− let
62− (Info r1 _, Info r2 _) =
63− OneOrMore.getFirstTwo left right
64− in
61+ OneOrMore.More _ _ ->
62+ let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in
6563 Result.throw (toError name r1 r2)
6664
6765
@@ -69,22 +67,22 @@ detectHelp toError name values =
6967-- CHECK FIELDS
7068
7169
72−checkFields :: [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name a)
70+checkFields :: [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name a)
7371checkFields fields =
7472 detect Error.DuplicateField (foldr addField none fields)
7573
7674
77−addField :: (A.Located Name.Name, a) -> Dict a -> Dict a
75+addField :: (A.Located N.Name, a) -> Dict a -> Dict a
7876addField (A.At region name, value) dups =
7977 Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups
8078
8179
82−checkFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name b)
80+checkFields' :: (R.Region -> a -> b) -> [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name b)
8381checkFields' toValue fields =
8482 detect Error.DuplicateField (foldr (addField' toValue) none fields)
8583
8684
87−addField' :: (A.Region -> a -> b) -> (A.Located Name.Name, a) -> Dict b -> Dict b
85+addField' :: (R.Region -> a -> b) -> (A.Located N.Name, a) -> Dict b -> Dict b
8886addField' toValue (A.At region name, value) dups =
8987 Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups
9088
@@ -98,14 +96,14 @@ none =
9896 Map.empty
9997
10098
101−one :: Name.Name -> A.Region -> value -> Dict value
99+one :: N.Name -> R.Region -> value -> Dict value
102100one name region value =
103101 Map.singleton name (OneOrMore.one (Info region value))
104102
105103
106−insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
104+insert :: N.Name -> R.Region -> a -> Dict a -> Dict a
107105insert name region value dict =
108− Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
106+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
109107
110108
111109union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+92−90
@@ -8,17 +8,15 @@ module Canonicalize.Environment.Foreign
88
99
1010import Control.Monad (foldM)
11−import qualified Data.List as List
1211import qualified Data.Map.Strict as Map
13−import Data.Map.Strict ((!))
14−import qualified Data.Name as Name
1512
1613import qualified AST.Canonical as Can
1714import qualified AST.Source as Src
15+import qualified AST.Module.Name as ModuleName
1816import qualified Canonicalize.Environment as Env
17+import qualified Data.List as List
1918import qualified Elm.Interface as I
20−import qualified Elm.ModuleName as ModuleName
21−import qualified Elm.Package as Pkg
19+import qualified Elm.Name as N
2220import qualified Reporting.Annotation as A
2321import qualified Reporting.Error.Canonicalize as Error
2422import qualified Reporting.Result as Result
@@ -32,17 +30,24 @@ type Result i w a =
3230 Result.Result i w Error.Error a
3331
3432
35−createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
36−createInitialEnv home ifaces imports =
37− 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)
3933
34+-- CREATE ENVIRONMENT
35+
36+
37+type ImportDict =
38+ Map.Map N.Name ModuleName.Canonical
4039
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
40+
41+createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Result i w Env.Env
42+createInitialEnv home importDict interfaces sourceImports =
43+ do imports <- traverse (verifyImport importDict interfaces) (filter isNotKernel sourceImports)
44+ (State vs ts cs bs qvs qts qcs) <- foldM addImport emptyState imports
45+ Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
46+
47+
48+isNotKernel :: Src.Import -> Bool
49+isNotKernel (Src.Import (A.At _ name) _ _) =
50+ not (ModuleName.isKernel name)
4651
4752
4853
@@ -68,49 +73,23 @@ emptyState =
6873
6974emptyTypes :: Env.Exposed Env.Type
7075emptyTypes =
71− Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
72−
73−
74−
75−-- TO SAFE IMPORTS
76−
77−
78−toSafeImports :: ModuleName.Canonical -> [Src.Import] -> [Src.Import]
79−toSafeImports (ModuleName.Canonical pkg _) imports =
80− if Pkg.isKernel pkg
81− then filter isNormal imports
82− else imports
83−
84−
85−isNormal :: Src.Import -> Bool
86−isNormal (Src.Import (A.At _ name) maybeAlias _) =
87− if Name.isKernel name
88− then
89− case maybeAlias of
90− Nothing -> False
91− Just _ -> error "kernel imports cannot use `as`"
92− else
93− True
76+ Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
9477
9578
9679
9780-- ADD IMPORTS
9881
9982
100−addImport :: Map.Map ModuleName.Raw I.Interface -> State -> Src.Import -> Result i w State
101−addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybeAlias exposing) =
83+addImport :: State -> Import -> Result i w State
84+addImport (State vs ts cs bs qvs qts qcs) (Import home (I.Interface defs unions aliases binops) prefix exposing) =
10285 let
103− (I.Interface pkg defs unions aliases binops) = ifaces ! name
104− !prefix = maybe name id maybeAlias
105− !home = ModuleName.Canonical pkg name
106−
10786 !rawTypeInfo =
10887 Map.union
10988 (Map.mapMaybeWithKey (unionToType home) unions)
11089 (Map.mapMaybeWithKey (aliasToType home) aliases)
11190
112− !vars = Map.map (Env.Specific home) defs
113− !types = Map.map (Env.Specific home . fst) rawTypeInfo
91+ !vars = Map.map (Map.singleton home) defs
92+ !types = Map.map (Map.singleton home . fst) rawTypeInfo
11493 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
11594
11695 !qvs2 = addQualified prefix vars qvs
@@ -136,10 +115,10 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
136115
137116addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
138117addExposed =
139− Map.unionWith Env.mergeInfo
118+ Map.unionWith Map.union
140119
141120
142−addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
121+addQualified :: N.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
143122addQualified prefix exposed qualified =
144123 Map.insertWith addExposed prefix exposed qualified
145124
@@ -148,16 +127,16 @@ addQualified prefix exposed qualified =
148127-- UNION
149128
150129
151−unionToType :: ModuleName.Canonical -> Name.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor)
130+unionToType :: ModuleName.Canonical -> N.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor)
152131unionToType home name union =
153132 unionToTypeHelp home name <$> I.toPublicUnion union
154133
155134
156−unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
135+unionToTypeHelp :: ModuleName.Canonical -> N.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
157136unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
158137 let
159138 addCtor dict (Can.Ctor ctor index _ args) =
160− Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
139+ Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
161140 in
162141 ( Env.Union (length vars) home
163142 , List.foldl' addCtor Map.empty ctors
@@ -168,12 +147,12 @@ unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
168147-- ALIAS
169148
170149
171−aliasToType :: ModuleName.Canonical -> Name.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor)
150+aliasToType :: ModuleName.Canonical -> N.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor)
172151aliasToType home name alias =
173152 aliasToTypeHelp home name <$> I.toPublicAlias alias
174153
175154
176−aliasToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
155+aliasToTypeHelp :: ModuleName.Canonical -> N.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
177156aliasToTypeHelp home name (Can.Alias vars tipe) =
178157 (
179158 Env.Alias (length vars) home vars tipe
@@ -188,7 +167,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
188167 (Can.TAlias home name avars (Can.Filled tipe))
189168 (Can.fieldsToList fields)
190169 in
191− Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
170+ Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
192171
193172 _ ->
194173 Map.empty
@@ -199,9 +178,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
199178-- BINOP
200179
201180
202−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
181+binopToBinop :: ModuleName.Canonical -> N.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
203182binopToBinop home op (I.Binop name annotation associativity precedence) =
204− Env.Specific home (Env.Binop op home name annotation associativity precedence)
183+ Map.singleton home (Env.Binop op home name annotation associativity precedence)
205184
206185
207186
@@ -211,22 +190,22 @@ binopToBinop home op (I.Binop name annotation associativity precedence) =
211190addExposedValue
212191 :: ModuleName.Canonical
213192 -> Env.Exposed Can.Annotation
214− -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
215− -> Map.Map Name.Name I.Binop
193+ -> Map.Map N.Name (Env.Type, Env.Exposed Env.Ctor)
194+ -> Map.Map N.Name I.Binop
216195 -> State
217− -> Src.Exposed
196+ -> A.Located Src.Exposed
218197 -> Result i w State
219−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
198+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
220199 case exposed of
221− Src.Lower (A.At region name) ->
200+ Src.Lower name ->
222201 case Map.lookup name vars of
223202 Just info ->
224− Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
203+ Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
225204
226205 Nothing ->
227206 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
228207
229− Src.Upper (A.At region name) privacy ->
208+ Src.Upper name privacy ->
230209 case privacy of
231210 Src.Private ->
232211 case Map.lookup name types of
@@ -234,43 +213,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
234213 case tipe of
235214 Env.Union _ _ ->
236215 let
237− !ts2 = Map.insert name (Env.Specific home tipe) ts
216+ !ts2 = Map.insert name (Map.singleton home tipe) ts
238217 in
239218 Result.ok (State vs ts2 cs bs qvs qts qcs)
240219
241220 Env.Alias _ _ _ _ ->
242221 let
243− !ts2 = Map.insert name (Env.Specific home tipe) ts
222+ !ts2 = Map.insert name (Map.singleton home tipe) ts
244223 !cs2 = addExposed cs ctors
245224 in
246225 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
247226
248227 Nothing ->
249− case checkForCtorMistake name types of
250− tipe:_ ->
228+ case Map.lookup name (toCtors types) of
229+ Just tipe ->
251230 Result.throw $ Error.ImportCtorByName region name tipe
252231
253− [] ->
232+ Nothing ->
254233 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
255234
256− Src.Public dotDotRegion ->
235+ Src.Public ->
257236 case Map.lookup name types of
258237 Just (tipe, ctors) ->
259238 case tipe of
260239 Env.Union _ _ ->
261240 let
262− !ts2 = Map.insert name (Env.Specific home tipe) ts
241+ !ts2 = Map.insert name (Map.singleton home tipe) ts
263242 !cs2 = addExposed cs ctors
264243 in
265244 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
266245
267246 Env.Alias _ _ _ _ ->
268− Result.throw (Error.ImportOpenAlias dotDotRegion name)
247+ Result.throw (Error.ImportOpenAlias region name)
269248
270249 Nothing ->
271250 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
272251
273− Src.Operator region op ->
252+ Src.Operator op ->
274253 case Map.lookup op binops of
275254 Just binop ->
276255 let
@@ -282,23 +261,46 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
282261 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
283262
284263
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
264+
265+toCtors :: Map.Map N.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map N.Name N.Name
266+toCtors types =
267+ Map.foldr addCtors Map.empty types
288268 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
269+ addCtors (_, exposedCtors) dict =
270+ Map.foldrWithKey addCtor dict exposedCtors
271+
272+ addCtor ctorName homes dict =
273+ case Map.elems homes of
274+ [Env.Ctor _ tipeName _ _ _] ->
275+ Map.insert ctorName tipeName dict
276+
277+ _ ->
278+ dict
279+
280+
281+
282+-- VERIFY IMPORT
283+
284+
285+data Import =
286+ Import
287+ { _name :: ModuleName.Canonical
288+ , _interface :: I.Interface
289+ , _prefix :: N.Name
290+ , _exposing :: Src.Exposing
291+ }
292+
293+
294+verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Result i w Import
295+verifyImport importDict interfaces (Src.Import (A.At region name) alias exposing) =
296+ case Map.lookup name importDict of
297+ Just canonicalName ->
298+ case Map.lookup canonicalName interfaces of
299+ Just interface ->
300+ Result.ok (Import canonicalName interface (maybe name id alias) exposing)
301+
302+ Nothing ->
303+ Result.throw $ Error.ImportNotFound region name (Map.keys interfaces)
304+
305+ Nothing ->
306+ Result.throw $ Error.ImportNotFound region name (Map.elems importDict)
compiler/src/Canonicalize/Environment/Local.hs+54−52
@@ -10,17 +10,19 @@ import Control.Monad (foldM)
1010import qualified Data.Graph as Graph
1111import qualified Data.List as List
1212import qualified Data.Map.Strict as Map
13−import qualified Data.Name as Name
1413
1514import qualified AST.Canonical as Can
1615import qualified AST.Source as Src
16+import qualified AST.Valid as Valid
17+import qualified AST.Module.Name as ModuleName
1718import qualified Canonicalize.Environment as Env
1819import qualified Canonicalize.Environment.Dups as Dups
1920import qualified Canonicalize.Type as Type
2021import qualified Data.Index as Index
21−import qualified Elm.ModuleName as ModuleName
22+import qualified Elm.Name as N
2223import qualified Reporting.Annotation as A
2324import qualified Reporting.Error.Canonicalize as Error
25+import qualified Reporting.Region as R
2426import qualified Reporting.Result as Result
2527
2628
@@ -32,11 +34,11 @@ type Result i w a =
3234 Result.Result i w Error.Error a
3335
3436
35−type Unions = Map.Map Name.Name Can.Union
36−type Aliases = Map.Map Name.Name Can.Alias
37+type Unions = Map.Map N.Name Can.Union
38+type Aliases = Map.Map N.Name Can.Alias
3739
3840
39−add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
41+add :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
4042add module_ env =
4143 addCtors module_ =<< addVars module_ =<< addTypes module_ env
4244
@@ -45,7 +47,7 @@ add module_ env =
4547-- ADD VARS
4648
4749
48−addVars :: Src.Module -> Env.Env -> Result i w Env.Env
50+addVars :: Valid.Module -> Env.Env -> Result i w Env.Env
4951addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
5052 do topLevelVars <- collectVars module_
5153 let vs2 = Map.union topLevelVars vs
@@ -53,38 +55,38 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
5355 Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
5456
5557
56−collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57−collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
58+collectVars :: Valid.Module -> Result i w (Map.Map N.Name Env.Var)
59+collectVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
5860 let
59− addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
61+ addDecl dict (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
6062 Dups.insert name region (Env.TopLevel region) dict
6163 in
6264 Dups.detect Error.DuplicateDecl $
63− List.foldl' addDecl (toEffectDups effects) values
65+ List.foldl' addDecl (toEffectDups effects) decls
6466
6567
66−toEffectDups :: Src.Effects -> Dups.Dict Env.Var
68+toEffectDups :: Valid.Effects -> Dups.Dict Env.Var
6769toEffectDups effects =
6870 case effects of
69− Src.NoEffects ->
71+ Valid.NoEffects ->
7072 Dups.none
7173
72− Src.Ports ports ->
74+ Valid.Ports ports ->
7375 let
74− addPort dict (Src.Port (A.At region name) _) =
76+ addPort dict (Valid.Port (A.At region name) _) =
7577 Dups.insert name region (Env.TopLevel region) dict
7678 in
7779 List.foldl' addPort Dups.none ports
7880
79− Src.Manager _ manager ->
81+ Valid.Manager _ manager ->
8082 case manager of
81− Src.Cmd (A.At region _) ->
83+ Valid.Cmd (A.At region _) ->
8284 Dups.one "command" region (Env.TopLevel region)
8385
84− Src.Sub (A.At region _) ->
86+ Valid.Sub (A.At region _) ->
8587 Dups.one "subscription" region (Env.TopLevel region)
8688
87− Src.Fx (A.At regionCmd _) (A.At regionSub _) ->
89+ Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->
8890 Dups.union
8991 (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
9092 (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
@@ -94,11 +96,11 @@ toEffectDups effects =
9496-- ADD TYPES
9597
9698
97−addTypes :: 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) =
99+addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env
100+addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
99101 let
100− addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101− addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
102+ addAliasDups dups (Valid.Alias _ (A.At region name) _ _) = Dups.insert name region () dups
103+ addUnionDups dups (Valid.Union _ (A.At region name) _ _) = Dups.insert name region () dups
102104 typeNameDups =
103105 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
104106 in
@@ -107,10 +109,10 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs
107109 addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
108110
109111
110−addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111−addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112+addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)
113+addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =
112114 do arity <- checkUnionFreeVars union
113− let one = Env.Specific home (Env.Union arity home)
115+ let one = Map.singleton home (Env.Union arity home)
114116 Result.ok $ Map.insert name one types
115117
116118
@@ -118,7 +120,7 @@ addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
118120-- ADD TYPE ALIASES
119121
120122
121−addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env
123+addAliases :: [Valid.Alias] -> Env.Env -> Result i w Env.Env
122124addAliases aliases env =
123125 let
124126 nodes = map toNode aliases
@@ -127,22 +129,22 @@ addAliases aliases env =
127129 foldM addAlias env sccs
128130
129131
130−addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env
132+addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env
131133addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
132134 case scc of
133− Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
135+ Graph.AcyclicSCC alias@(Valid.Alias _ (A.At _ name) _ tipe) ->
134136 do args <- checkAliasFreeVars alias
135137 ctype <- Type.canonicalize env tipe
136− let one = Env.Specific home (Env.Alias (length args) home args ctype)
138+ let one = Map.singleton home (Env.Alias (length args) home args ctype)
137139 let ts1 = Map.insert name one ts
138140 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139141
140142 Graph.CyclicSCC [] ->
141143 Result.ok env
142144
143− Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) ->
145+ Graph.CyclicSCC (alias@(Valid.Alias _ (A.At region name1) _ tipe) : others) ->
144146 do args <- checkAliasFreeVars alias
145− let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name
147+ let toName (Valid.Alias _ (A.At _ name) _ _) = name
146148 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
147149
148150
@@ -150,12 +152,12 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
150152-- DETECT TYPE ALIAS CYCLES
151153
152154
153−toNode :: A.Located Src.Alias -> (A.Located Src.Alias, Name.Name, [Name.Name])
154−toNode alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) =
155+toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])
156+toNode alias@(Valid.Alias _ (A.At _ name) _ tipe) =
155157 ( alias, name, getEdges [] tipe )
156158
157159
158−getEdges :: [Name.Name] -> Src.Type -> [Name.Name]
160+getEdges :: [N.Name] -> Src.Type -> [N.Name]
159161getEdges edges (A.At _ tipe) =
160162 case tipe of
161163 Src.TLambda arg result ->
@@ -184,8 +186,8 @@ getEdges edges (A.At _ tipe) =
184186-- CHECK FREE VARIABLES
185187
186188
187−checkUnionFreeVars :: A.Located Src.Union -> Result i w Int
188−checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =
189+checkUnionFreeVars :: Valid.Union -> Result i w Int
190+checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =
189191 let
190192 addArg (A.At region arg) dict =
191193 Dups.insert arg region region dict
@@ -204,8 +206,8 @@ checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =
204206 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds
205207
206208
207−checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name]
208−checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =
209+checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]
210+checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =
209211 let
210212 addArg (A.At region arg) dict =
211213 Dups.insert arg region region dict
@@ -223,7 +225,7 @@ checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =
223225 (Map.toList (Map.difference freeVars boundVars))
224226
225227
226−addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region
228+addFreeVars :: Map.Map N.Name R.Region -> Src.Type -> Map.Map N.Name R.Region
227229addFreeVars freeVars (A.At region tipe) =
228230 case tipe of
229231 Src.TLambda arg result ->
@@ -261,8 +263,8 @@ addFreeVars freeVars (A.At region tipe) =
261263-- ADD CTORS
262264
263265
264−addCtors :: 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) =
266+addCtors :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
267+addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266268 do unionInfo <- traverse (canonicalizeUnion env) unions
267269 aliasInfo <- traverse (canonicalizeAlias env) aliases
268270
@@ -281,15 +283,15 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs
281283 )
282284
283285
284−type CtorDups = Dups.Dict (Env.Info Env.Ctor)
286+type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
285287
286288
287289
288290-- CANONICALIZE ALIAS
289291
290292
291−canonicalizeAlias :: Env.Env -> A.Located Src.Alias -> Result i w ( (Name.Name, Can.Alias), CtorDups )
292−canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At region name) args tipe)) =
293+canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )
294+canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region name) args tipe) =
293295 do let vars = map A.toValue args
294296 ctipe <- Type.canonicalize env tipe
295297 Result.ok
@@ -297,13 +299,13 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297299 ,
298300 case ctipe of
299301 Can.TRecord fields Nothing ->
300− Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
302+ Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
301303
302304 _ ->
303305 Dups.none
304306 )
305307
306−toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor
308+toRecordCtor :: ModuleName.Canonical -> N.Name -> [N.Name] -> Map.Map N.Name Can.FieldType -> Env.Ctor
307309toRecordCtor home name vars fields =
308310 let
309311 avars = map (\var -> (var, Can.TVar var)) vars
@@ -320,8 +322,8 @@ toRecordCtor home name vars fields =
320322-- CANONICALIZE UNION
321323
322324
323−canonicalizeUnion :: Env.Env -> A.Located Src.Union -> Result i w ( (Name.Name, Can.Union), CtorDups )
324−canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Union (A.At _ name) avars ctors)) =
325+canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )
326+canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name) avars ctors) =
325327 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
326328 let vars = map A.toValue avars
327329 let alts = map A.toValue cctors
@@ -332,14 +334,14 @@ canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Union (A.At _ na
332334 )
333335
334336
335−canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
337+canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located N.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
336338canonicalizeCtor env index (A.At region ctor, tipes) =
337339 do ctipes <- traverse (Type.canonicalize env) tipes
338340 Result.ok $ A.At region $
339341 Can.Ctor ctor index (length ctipes) ctipes
340342
341343
342−toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts
344+toOpts :: [(A.Located N.Name, [Src.Type])] -> Can.CtorOpts
343345toOpts ctors =
344346 case ctors of
345347 [ (_,[_]) ] ->
@@ -349,7 +351,7 @@ toOpts ctors =
349351 if all (null . snd) ctors then Can.Enum else Can.Normal
350352
351353
352−toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
354+toCtor :: ModuleName.Canonical -> N.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353355toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Env.Specific home $
356+ Dups.one name region $ Map.singleton home $
355357 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+73−71
@@ -14,21 +14,23 @@ 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.Name as Name
17+import qualified Data.Map.Strict.Internal as I
1818
1919import qualified AST.Canonical as Can
2020import qualified AST.Source as Src
21+import qualified AST.Module.Name as ModuleName
2122import qualified AST.Utils.Binop as Binop
2223import qualified AST.Utils.Type as Type
24+import qualified AST.Valid as Valid
2325import qualified Canonicalize.Environment as Env
2426import qualified Canonicalize.Environment.Dups as Dups
2527import qualified Canonicalize.Pattern as Pattern
2628import qualified Canonicalize.Type as Type
2729import qualified Data.Index as Index
28−import qualified Elm.ModuleName as ModuleName
29−import qualified Elm.Package as Pkg
30+import qualified Elm.Name as N
3031import qualified Reporting.Annotation as A
3132import qualified Reporting.Error.Canonicalize as Error
33+import qualified Reporting.Region as R
3234import qualified Reporting.Result as Result
3335import qualified Reporting.Warning as W
3436
@@ -42,7 +44,7 @@ type Result i w a =
4244
4345
4446type FreeLocals =
45− Map.Map Name.Name Uses
47+ Map.Map N.Name Uses
4648
4749
4850data Uses =
@@ -56,46 +58,46 @@ data Uses =
5658-- CANONICALIZE
5759
5860
59−canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
61+canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
6062canonicalize env (A.At region expression) =
6163 A.At region <$>
6264 case expression of
63− Src.Str string ->
65+ Valid.Str string ->
6466 Result.ok (Can.Str string)
6567
66− Src.Chr char ->
68+ Valid.Chr char ->
6769 Result.ok (Can.Chr char)
6870
69− Src.Int int ->
71+ Valid.Int int ->
7072 Result.ok (Can.Int int)
7173
72− Src.Float float ->
74+ Valid.Float float ->
7375 Result.ok (Can.Float float)
7476
75− Src.Var varType name ->
77+ Valid.Var varType name ->
7678 case varType of
77− Src.LowVar -> findVar region env name
78− Src.CapVar -> toVarCtor name <$> Env.findCtor region env name
79+ Src.Value -> findVar region env name
80+ Src.Ctor -> toVarCtor name <$> Env.findCtor region env name
7981
80− Src.VarQual varType prefix name ->
82+ Valid.VarQual varType prefix name ->
8183 case varType of
82− Src.LowVar -> findVarQual region env prefix name
83− Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name
84+ Src.Value -> findVarQual region env prefix name
85+ Src.Ctor -> toVarCtor name <$> Env.findCtorQual region env prefix name
8486
85− Src.List exprs ->
87+ Valid.List exprs ->
8688 Can.List <$> traverse (canonicalize env) exprs
8789
88− Src.Op op ->
90+ Valid.Op op ->
8991 do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op
9092 return (Can.VarOperator op home name annotation)
9193
92− Src.Negate expr ->
94+ Valid.Negate expr ->
9395 Can.Negate <$> canonicalize env expr
9496
95− Src.Binops ops final ->
97+ Valid.Binops ops final ->
9698 A.toValue <$> canonicalizeBinops region env ops final
9799
98− Src.Lambda srcArgs body ->
100+ Valid.Lambda srcArgs body ->
99101 delayedUsage $
100102 do (args, bindings) <-
101103 Pattern.verify Error.DPLambdaArgs $
@@ -109,33 +111,33 @@ canonicalize env (A.At region expression) =
109111
110112 return (Can.Lambda args cbody, freeLocals)
111113
112− Src.Call func args ->
114+ Valid.Call func args ->
113115 Can.Call
114116 <$> canonicalize env func
115117 <*> traverse (canonicalize env) args
116118
117− Src.If branches finally ->
119+ Valid.If branches finally ->
118120 Can.If
119121 <$> traverse (canonicalizeIfBranch env) branches
120122 <*> canonicalize env finally
121123
122− Src.Let defs expr ->
124+ Valid.Let defs expr ->
123125 A.toValue <$> canonicalizeLet region env defs expr
124126
125− Src.Case expr branches ->
127+ Valid.Case expr branches ->
126128 Can.Case
127129 <$> canonicalize env expr
128130 <*> traverse (canonicalizeCaseBranch env) branches
129131
130− Src.Accessor field ->
132+ Valid.Accessor field ->
131133 Result.ok $ Can.Accessor field
132134
133− Src.Access record field ->
135+ Valid.Access record field ->
134136 Can.Access
135137 <$> canonicalize env record
136138 <*> Result.ok field
137139
138− Src.Update (A.At reg name) fields ->
140+ Valid.Update (A.At reg name) fields ->
139141 let
140142 makeCanFields =
141143 Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields
@@ -144,28 +146,28 @@ canonicalize env (A.At region expression) =
144146 <$> (A.At reg <$> findVar reg env name)
145147 <*> (sequenceA =<< makeCanFields)
146148
147− Src.Record fields ->
149+ Valid.Record fields ->
148150 do fieldDict <- Dups.checkFields fields
149151 Can.Record <$> traverse (canonicalize env) fieldDict
150152
151− Src.Unit ->
153+ Valid.Unit ->
152154 Result.ok Can.Unit
153155
154− Src.Tuple a b cs ->
156+ Valid.Tuple a b cs ->
155157 Can.Tuple
156158 <$> canonicalize env a
157159 <*> canonicalize env b
158160 <*> canonicalizeTupleExtras region env cs
159161
160− Src.Shader src tipe ->
161− Result.ok (Can.Shader src tipe)
162+ Valid.Shader uid src tipe ->
163+ Result.ok (Can.Shader uid src tipe)
162164
163165
164166
165167-- CANONICALIZE TUPLE EXTRAS
166168
167169
168−canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
170+canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
169171canonicalizeTupleExtras region env extras =
170172 case extras of
171173 [] ->
@@ -182,7 +184,7 @@ canonicalizeTupleExtras region env extras =
182184-- CANONICALIZE IF BRANCH
183185
184186
185−canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
187+canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
186188canonicalizeIfBranch env (condition, branch) =
187189 (,)
188190 <$> canonicalize env condition
@@ -193,7 +195,7 @@ canonicalizeIfBranch env (condition, branch) =
193195-- CANONICALIZE CASE BRANCH
194196
195197
196−canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
198+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
197199canonicalizeCaseBranch env (pattern, expr) =
198200 directUsage $
199201 do (cpattern, bindings) <-
@@ -211,7 +213,7 @@ canonicalizeCaseBranch env (pattern, expr) =
211213-- CANONICALIZE BINOPS
212214
213215
214−canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
216+canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
215217canonicalizeBinops overallRegion env ops final =
216218 let
217219 canonicalizeHelp (expr, A.At region op) =
@@ -232,7 +234,7 @@ data Step
232234 | Error Env.Binop Env.Binop
233235
234236
235−runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr
237+runBinopStepper :: R.Region -> Step -> Result FreeLocals w Can.Expr
236238runBinopStepper overallRegion step =
237239 case step of
238240 Done expr ->
@@ -294,7 +296,7 @@ toBinop (Env.Binop op home name annotation _ _) left right =
294296-- CANONICALIZE LET
295297
296298
297−canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
299+canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
298300canonicalizeLet letRegion env defs body =
299301 directUsage $
300302 do bindings <-
@@ -313,17 +315,17 @@ canonicalizeLet letRegion env defs body =
313315-- ADD BINDINGS
314316
315317
316−addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region
317−addBindings bindings (A.At _ def) =
318+addBindings :: Dups.Dict R.Region -> Valid.Def -> Dups.Dict R.Region
319+addBindings bindings def =
318320 case def of
319− Src.Define (A.At region name) _ _ _ ->
321+ Valid.Define _ (A.At region name) _ _ _ ->
320322 Dups.insert name region region bindings
321323
322− Src.Destruct pattern _ ->
324+ Valid.Destruct _ pattern _ ->
323325 addBindingsHelp bindings pattern
324326
325327
326−addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region
328+addBindingsHelp :: Dups.Dict R.Region -> Src.Pattern -> Dups.Dict R.Region
327329addBindingsHelp bindings (A.At region pattern) =
328330 case pattern of
329331 Src.PAnything ->
@@ -376,19 +378,19 @@ addBindingsHelp bindings (A.At region pattern) =
376378
377379
378380type Node =
379− (Binding, Name.Name, [Name.Name])
381+ (Binding, N.Name, [N.Name])
380382
381383
382384data Binding
383385 = Define Can.Def
384− | Edge (A.Located Name.Name)
386+ | Edge (A.Located N.Name)
385387 | Destruct Can.Pattern Can.Expr
386388
387389
388−addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node]
389−addDefNodes env nodes (A.At _ def) =
390+addDefNodes :: Env.Env -> [Node] -> Valid.Def -> Result FreeLocals [W.Warning] [Node]
391+addDefNodes env nodes def =
390392 case def of
391− Src.Define aname@(A.At _ name) srcArgs body maybeType ->
393+ Valid.Define _ aname@(A.At _ name) srcArgs body maybeType ->
392394 case maybeType of
393395 Nothing ->
394396 do (args, argBindings) <-
@@ -421,7 +423,7 @@ addDefNodes env nodes (A.At _ def) =
421423 let node = ( Define cdef, name, Map.keys freeLocals )
422424 logLetLocals args freeLocals (node:nodes)
423425
424− Src.Destruct pattern body ->
426+ Valid.Destruct _ pattern body ->
425427 do (cpattern, _bindings) <-
426428 Pattern.verify Error.DPDestruct $
427429 Pattern.canonicalize env pattern
@@ -436,7 +438,7 @@ addDefNodes env nodes (A.At _ def) =
436438 (\freeLocals warnings cbody ->
437439 let
438440 names = getPatternNames [] pattern
439− name = Name.fromManyNames (map A.toValue names)
441+ name = N.toCompositeName (map A.toValue names)
440442 node = ( Destruct cpattern cbody, name, Map.keys freeLocals )
441443 in
442444 good
@@ -459,12 +461,12 @@ logLetLocals args letLocals value =
459461 value
460462
461463
462−addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node]
464+addEdge :: [N.Name] -> [Node] -> A.Located N.Name -> [Node]
463465addEdge edges nodes aname@(A.At _ name) =
464466 (Edge aname, name, edges) : nodes
465467
466468
467−getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name]
469+getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]
468470getPatternNames names (A.At region pattern) =
469471 case pattern of
470472 Src.PAnything -> names
@@ -488,7 +490,7 @@ getPatternNames names (A.At region pattern) =
488490
489491gatherTypedArgs
490492 :: Env.Env
491− -> Name.Name
493+ -> N.Name
492494 -> [Src.Pattern]
493495 -> Can.Type
494496 -> Index.ZeroBased
@@ -509,14 +511,14 @@ gatherTypedArgs env name srcArgs tipe index revTypedArgs =
509511 _ ->
510512 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
511513 Result.throw $
512− Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs)
514+ Error.AnnotationTooShort (R.merge start end) name index (length srcArgs)
513515
514516
515517
516518-- DETECT CYCLES
517519
518520
519−detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
521+detectCycles :: R.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
520522detectCycles letRegion sccs body =
521523 case sccs of
522524 [] ->
@@ -572,7 +574,7 @@ checkCycle bindings defs =
572574 checkCycle otherBindings defs
573575
574576
575−toNames :: [Binding] -> [Can.Def] -> [Name.Name]
577+toNames :: [Binding] -> [Can.Def] -> [N.Name]
576578toNames bindings revDefs =
577579 case bindings of
578580 [] ->
@@ -585,7 +587,7 @@ toNames bindings revDefs =
585587 Destruct _ _ -> toNames otherBindings revDefs
586588
587589
588−getDefName :: Can.Def -> Name.Name
590+getDefName :: Can.Def -> N.Name
589591getDefName def =
590592 case def of
591593 Can.Def (A.At _ name) _ _ ->
@@ -599,7 +601,7 @@ getDefName def =
599601-- LOG VARIABLE USES
600602
601603
602−logVar :: Name.Name -> a -> Result FreeLocals w a
604+logVar :: N.Name -> a -> Result FreeLocals w a
603605logVar name value =
604606 Result.Result $ \freeLocals warnings _ good ->
605607 good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
@@ -654,7 +656,7 @@ verifyBindings context bindings (Result.Result k) =
654656 )
655657
656658
657−addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning]
659+addUnusedWarning :: W.Context -> [W.Warning] -> N.Name -> R.Region -> [W.Warning]
658660addUnusedWarning context warnings name region =
659661 W.UnusedVariable region context name : warnings
660662
@@ -684,7 +686,7 @@ delayedUsage (Result.Result k) =
684686-- FIND VARIABLE
685687
686688
687−findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_
689+findVar :: R.Region -> Env.Env -> N.Name -> Result FreeLocals w Can.Expr_
688690findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
689691 case Map.lookup name vs of
690692 Just var ->
@@ -695,46 +697,46 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
695697 Env.TopLevel _ ->
696698 logVar name (Can.VarTopLevel localHome name)
697699
698− Env.Foreign home annotation ->
700+ Env.Foreign (I.Bin 1 home annotation _ _) ->
699701 Result.ok $
700702 if home == ModuleName.debug then
701703 Can.VarDebug localHome name annotation
702704 else
703705 Can.VarForeign home name annotation
704706
705− Env.Foreigns h hs ->
706− Result.throw (Error.AmbiguousVar region Nothing name h hs)
707+ Env.Foreign homes ->
708+ Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
707709
708710 Nothing ->
709711 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
710712
711713
712−findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_
714+findVarQual :: R.Region -> Env.Env -> N.Name -> N.Name -> Result FreeLocals w Can.Expr_
713715findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
714716 case Map.lookup prefix qvs of
715717 Just qualified ->
716718 case Map.lookup name qualified of
717− Just (Env.Specific home annotation) ->
719+ Just (I.Bin 1 home annotation _ _) ->
718720 Result.ok $
719721 if home == ModuleName.debug then
720722 Can.VarDebug localHome name annotation
721723 else
722724 Can.VarForeign home name annotation
723725
724− Just (Env.Ambiguous h hs) ->
725− Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
726+ Just homes ->
727+ Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
726728
727729 Nothing ->
728730 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
729731
730732 Nothing ->
731− if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then
732− Result.ok $ Can.VarKernel (Name.getKernel prefix) name
733+ if ModuleName.isKernel prefix then
734+ Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name
733735 else
734736 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
735737
736738
737−toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames
739+toPossibleNames :: Map.Map N.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames
738740toPossibleNames exposed qualified =
739741 Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)
740742
@@ -743,7 +745,7 @@ toPossibleNames exposed qualified =
743745-- FIND CTOR
744746
745747
746−toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_
748+toVarCtor :: N.Name -> Env.Ctor -> Can.Expr_
747749toVarCtor name ctor =
748750 case ctor of
749751 Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->
compiler/src/Canonicalize/Module.hs+74−65
@@ -7,10 +7,11 @@ module Canonicalize.Module
77
88import qualified Data.Graph as Graph
99import qualified Data.Map as Map
10−import qualified Data.Name as Name
1110
1211import qualified AST.Canonical as Can
1312import qualified AST.Source as Src
13+import qualified AST.Valid as Valid
14+import qualified AST.Module.Name as ModuleName
1415import qualified Canonicalize.Effects as Effects
1516import qualified Canonicalize.Environment as Env
1617import qualified Canonicalize.Environment.Dups as Dups
@@ -21,10 +22,11 @@ import qualified Canonicalize.Pattern as Pattern
2122import qualified Canonicalize.Type as Type
2223import qualified Data.Index as Index
2324import qualified Elm.Interface as I
24−import qualified Elm.ModuleName as ModuleName
25+import qualified Elm.Name as N
2526import qualified Elm.Package as Pkg
2627import qualified Reporting.Annotation as A
2728import qualified Reporting.Error.Canonicalize as Error
29+import qualified Reporting.Region as R
2830import qualified Reporting.Result as Result
2931import qualified Reporting.Warning as W
3032
@@ -41,28 +43,47 @@ type Result i w a =
4143-- MODULES
4244
4345
44−canonicalize :: 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) =
46− do let home = ModuleName.Canonical pkg (Src.getName modul)
46+canonicalize
47+ :: Pkg.Name
48+ -> Map.Map N.Name ModuleName.Canonical
49+ -> I.Interfaces
50+ -> Valid.Module
51+ -> Result i [W.Warning] Can.Module
52+canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls _ _ binops effects) =
53+ do let home = ModuleName.Canonical pkg name
4754 let cbinops = Map.fromList (map canonicalizeBinop binops)
4855
4956 (env, cunions, caliases) <-
50− Local.add modul =<<
51− Foreign.createInitialEnv home ifaces imports
57+ Local.add module_ =<<
58+ Foreign.createInitialEnv home importDict interfaces imports
5259
53− cvalues <- canonicalizeValues env values
54− ceffects <- Effects.canonicalize env values cunions effects
55− cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
60+ cdecls <- canonicalizeDecls env decls
61+ ceffects <- Effects.canonicalize env decls cunions effects
62+ cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
5663
57− return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
64+ return $ Can.Module home (toDocs module_) cexports cdecls cunions caliases cbinops ceffects
65+
66+
67+
68+-- DOCUMENTATION
69+
70+
71+toDocs :: Valid.Module -> Can.Docs
72+toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =
73+ case docs of
74+ Src.NoDocs region ->
75+ Can.NoDocs region
76+
77+ Src.YesDocs region overview ->
78+ Can.YesDocs region overview comments
5879
5980
6081
6182-- CANONICALIZE BINOP
6283
6384
64−canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65−canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
85+canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
86+canonicalizeBinop (Valid.Binop op associativity precedence func) =
6687 ( op, Can.Binop_ associativity precedence func )
6788
6889
@@ -76,9 +97,9 @@ canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
7697--
7798
7899
79−canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls
80−canonicalizeValues env values =
81− do nodes <- traverse (toNodeOne env) values
100+canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls
101+canonicalizeDecls env decls =
102+ do nodes <- traverse (toNodeOne env) decls
82103 detectCycles (Graph.stronglyConnComp nodes)
83104
84105
@@ -93,11 +114,13 @@ detectCycles sccs =
93114 Graph.AcyclicSCC (def, _, _) ->
94115 Can.Declare def <$> detectCycles otherSccs
95116
117+ Graph.CyclicSCC [] ->
118+ detectCycles otherSccs
119+
96120 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
121+ Can.DeclareRec
122+ <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
123+ <*> detectCycles otherSccs
101124
102125
103126detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
@@ -106,22 +129,8 @@ detectBadCycles scc =
106129 Graph.AcyclicSCC def ->
107130 Result.ok def
108131
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
132+ Graph.CyclicSCC cyclicValueDefs ->
133+ Result.throw (Error.RecursiveDecl cyclicValueDefs)
125134
126135
127136
@@ -133,17 +142,17 @@ extractDefName def =
133142-- Phase one nodes track ALL dependencies.
134143-- This allows us to find cyclic values for type inference.
135144type NodeOne =
136− (NodeTwo, Name.Name, [Name.Name])
145+ (NodeTwo, N.Name, [N.Name])
137146
138147
139148-- Phase two nodes track DIRECT dependencies.
140149-- This allows us to detect cycles that definitely do not terminate.
141150type NodeTwo =
142− (Can.Def, Name.Name, [Name.Name])
151+ (Can.Def, N.Name, [N.Name])
143152
144153
145−toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne
146−toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) =
154+toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne
155+toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
147156 case maybeType of
148157 Nothing ->
149158 do (args, argBindings) <-
@@ -184,7 +193,7 @@ toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) =
184193 )
185194
186195
187−toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
196+toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
188197toNodeTwo name args def freeLocals =
189198 case args of
190199 [] ->
@@ -194,7 +203,7 @@ toNodeTwo name args def freeLocals =
194203 (def, name, [])
195204
196205
197−addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name]
206+addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]
198207addDirects name (Expr.Uses directUses _) directDeps =
199208 if directUses > 0 then
200209 name:directDeps
@@ -207,41 +216,41 @@ addDirects name (Expr.Uses directUses _) directDeps =
207216
208217
209218canonicalizeExports
210− :: [A.Located Src.Value]
211− -> Map.Map Name.Name union
212− -> Map.Map Name.Name alias
213− -> Map.Map Name.Name binop
219+ :: [A.Located Valid.Decl]
220+ -> Map.Map N.Name union
221+ -> Map.Map N.Name alias
222+ -> Map.Map N.Name binop
214223 -> Can.Effects
215224 -> A.Located Src.Exposing
216225 -> Result i w Can.Exports
217−canonicalizeExports values unions aliases binops effects (A.At region exposing) =
226+canonicalizeExports decls unions aliases binops effects (A.At region exposing) =
218227 case exposing of
219228 Src.Open ->
220229 Result.ok (Can.ExportEverything region)
221230
222231 Src.Explicit exposeds ->
223− do let names = Map.fromList (map valueToName values)
232+ do let names = Map.fromList (map declToName decls)
224233 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
225234 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
226235
227236
228−valueToName :: A.Located Src.Value -> ( Name.Name, () )
229−valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) =
237+declToName :: A.Located Valid.Decl -> ( N.Name, () )
238+declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =
230239 ( name, () )
231240
232241
233242checkExposed
234− :: Map.Map Name.Name value
235− -> Map.Map Name.Name union
236− -> Map.Map Name.Name alias
237− -> Map.Map Name.Name binop
243+ :: Map.Map N.Name decl
244+ -> Map.Map N.Name union
245+ -> Map.Map N.Name alias
246+ -> Map.Map N.Name binop
238247 -> Can.Effects
239− -> Src.Exposed
248+ -> A.Located Src.Exposed
240249 -> Result i w (Dups.Dict (A.Located Can.Export))
241−checkExposed values unions aliases binops effects exposed =
250+checkExposed decls unions aliases binops effects (A.At region exposed) =
242251 case exposed of
243− Src.Lower (A.At region name) ->
244− if Map.member name values then
252+ Src.Lower name ->
253+ if Map.member name decls then
245254 ok name region Can.ExportValue
246255 else
247256 case checkPorts effects name of
@@ -250,25 +259,25 @@ checkExposed values unions aliases binops effects exposed =
250259
251260 Just ports ->
252261 Result.throw $ Error.ExportNotFound region Error.BadVar name $
253− ports ++ Map.keys values
262+ ports ++ Map.keys decls
254263
255− Src.Operator region name ->
264+ Src.Operator name ->
256265 if Map.member name binops then
257266 ok name region Can.ExportBinop
258267 else
259268 Result.throw $ Error.ExportNotFound region Error.BadOp name $
260269 Map.keys binops
261270
262− Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
271+ Src.Upper name Src.Public ->
263272 if Map.member name unions then
264273 ok name region Can.ExportUnionOpen
265274 else if Map.member name aliases then
266− Result.throw $ Error.ExportOpenAlias dotDotRegion name
275+ Result.throw $ Error.ExportOpenAlias region name
267276 else
268277 Result.throw $ Error.ExportNotFound region Error.BadType name $
269278 Map.keys unions ++ Map.keys aliases
270279
271− Src.Upper (A.At region name) Src.Private ->
280+ Src.Upper name Src.Private ->
272281 if Map.member name unions then
273282 ok name region Can.ExportUnionClosed
274283 else if Map.member name aliases then
@@ -278,7 +287,7 @@ checkExposed values unions aliases binops effects exposed =
278287 Map.keys unions ++ Map.keys aliases
279288
280289
281−checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name]
290+checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
282291checkPorts effects name =
283292 case effects of
284293 Can.NoEffects ->
@@ -291,6 +300,6 @@ checkPorts effects name =
291300 Just []
292301
293302
294−ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
303+ok :: N.Name -> R.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
295304ok name region export =
296305 Result.ok $ Dups.one name region (A.At region export)
compiler/src/Canonicalize/Pattern.hs+12−16
@@ -8,18 +8,17 @@ module Canonicalize.Pattern
88 where
99
1010
11−import qualified Data.List as List
1211import qualified Data.Map.Strict as Map
13−import qualified Data.Name as Name
1412
1513import qualified AST.Canonical as Can
1614import qualified AST.Source as Src
1715import qualified Canonicalize.Environment as Env
1816import qualified Canonicalize.Environment.Dups as Dups
1917import qualified Data.Index as Index
20−import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Name as N
2119import qualified Reporting.Annotation as A
2220import qualified Reporting.Error.Canonicalize as Error
21+import qualified Reporting.Region as R
2322import qualified Reporting.Result as Result
2423
2524
@@ -32,7 +31,7 @@ type Result i w a =
3231
3332
3433type Bindings =
35− Map.Map Name.Name A.Region
34+ Map.Map N.Name R.Region
3635
3736
3837
@@ -60,7 +59,7 @@ verify context (Result.Result k) =
6059
6160
6261type DupsDict =
63− Dups.Dict A.Region
62+ Dups.Dict R.Region
6463
6564
6665canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
@@ -113,7 +112,7 @@ canonicalize env (A.At region pattern) =
113112 Result.ok (Can.PInt int)
114113
115114
116−canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
115+canonicalizeCtor :: Env.Env -> R.Region -> N.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
117116canonicalizeCtor env region name patterns ctor =
118117 case ctor of
119118 Env.Ctor home tipe union index args ->
@@ -124,19 +123,16 @@ canonicalizeCtor env region name patterns ctor =
124123 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
125124 case verifiedList of
126125 Index.LengthMatch cargs ->
127− if tipe == Name.bool && home == ModuleName.basics then
128− Result.ok (Can.PBool union (name == Name.true))
129− else
130− Result.ok (Can.PCtor home tipe union name index cargs)
126+ Result.ok (Can.PCtor home tipe union name index cargs)
131127
132128 Index.LengthMismatch actualLength expectedLength ->
133− Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)
129+ Result.throw (Error.BadArity region Error.PatternArity name actualLength expectedLength)
134130
135131 Env.RecordCtor _ _ _ ->
136132 Result.throw (Error.PatternHasRecordCtor region name)
137133
138134
139−canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
135+canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
140136canonicalizeTuple tupleRegion env extras =
141137 case extras of
142138 [] ->
@@ -165,17 +161,17 @@ canonicalizeList env list =
165161-- LOG BINDINGS
166162
167163
168−logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a
164+logVar :: N.Name -> R.Region -> a -> Result DupsDict w a
169165logVar name region value =
170166 Result.Result $ \bindings warnings _ ok ->
171167 ok (Dups.insert name region region bindings) warnings value
172168
173169
174−logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
170+logFields :: [A.Located N.Name] -> a -> Result DupsDict w a
175171logFields fields value =
176172 let
177− addField dict (A.At region name) =
173+ addField (A.At region name) dict =
178174 Dups.insert name region region dict
179175 in
180176 Result.Result $ \bindings warnings _ ok ->
181− ok (List.foldl' addField bindings fields) warnings value
177+ ok (foldr addField bindings fields) warnings value
compiler/src/Canonicalize/Type.hs+7−6
@@ -9,14 +9,15 @@ module Canonicalize.Type
99
1010import qualified Data.List as List
1111import qualified Data.Map as Map
12−import qualified Data.Name as Name
1312
1413import qualified AST.Canonical as Can
1514import qualified AST.Source as Src
1615import qualified Canonicalize.Environment as Env
1716import qualified Canonicalize.Environment.Dups as Dups
17+import qualified Elm.Name as N
1818import qualified Reporting.Annotation as A
1919import qualified Reporting.Error.Canonicalize as Error
20+import qualified Reporting.Region as R
2021import qualified Reporting.Result as Result
2122
2223
@@ -84,7 +85,7 @@ canonicalize env (A.At typeRegion tipe) =
8485 Result.throw $ Error.TupleLargerThanThree typeRegion
8586
8687
87−canonicalizeFields :: Env.Env -> [(A.Located Name.Name, Src.Type)] -> [(A.Located Name.Name, Result i w Can.FieldType)]
88+canonicalizeFields :: Env.Env -> [(A.Located N.Name, Src.Type)] -> [(A.Located N.Name, Result i w Can.FieldType)]
8889canonicalizeFields env fields =
8990 let
9091 len = fromIntegral (length fields)
@@ -98,7 +99,7 @@ canonicalizeFields env fields =
9899-- CANONICALIZE TYPE
99100
100101
101−canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type
102+canonicalizeType :: Env.Env -> R.Region -> N.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type
102103canonicalizeType env region name args info =
103104 do cargs <- traverse (canonicalize env) args
104105 case info of
@@ -111,7 +112,7 @@ canonicalizeType env region name args info =
111112 Can.TType home name cargs
112113
113114
114−checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer
115+checkArity :: Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer
115116checkArity expected region name args answer =
116117 let actual = length args in
117118 if expected == actual then
@@ -124,7 +125,7 @@ checkArity expected region name args answer =
124125-- ADD FREE VARS
125126
126127
127−addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name ()
128+addFreeVars :: Map.Map N.Name () -> Can.Type -> Map.Map N.Name ()
128129addFreeVars freeVars tipe =
129130 case tipe of
130131 Can.TLambda arg result ->
@@ -157,6 +158,6 @@ addFreeVars freeVars tipe =
157158 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args
158159
159160
160−addFieldFreeVars :: Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name ()
161+addFieldFreeVars :: Map.Map N.Name () -> Can.FieldType -> Map.Map N.Name ()
161162addFieldFreeVars freeVars (Can.FieldType _ tipe) =
162163 addFreeVars freeVars tipe
compiler/src/Compile.hs+76−41
@@ -1,26 +1,30 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
22module Compile
3− ( Artifacts(..)
3+ ( DocsFlag(..)
44 , compile
5+ , Artifacts(..)
56 )
67 where
78
89
10+import qualified Data.ByteString as BS
911import qualified Data.Map as Map
10−import qualified Data.Name as Name
1112
12−import qualified AST.Source as Src
1313import qualified AST.Canonical as Can
1414import qualified AST.Optimized as Opt
15+import qualified AST.Module.Name as ModuleName
1516import qualified Canonicalize.Module as Canonicalize
17+import qualified Elm.Docs as Docs
1618import qualified Elm.Interface as I
17−import qualified Elm.ModuleName as ModuleName
19+import qualified Elm.Name as N
1820import qualified Elm.Package as Pkg
1921import qualified Nitpick.PatternMatches as PatternMatches
2022import qualified Optimize.Module as Optimize
21−import qualified Reporting.Error as E
22−import qualified Reporting.Result as R
23−import qualified Reporting.Render.Type.Localizer as Localizer
23+import qualified Parse.Parse as Parse
24+import qualified Reporting.Error as Error
25+import qualified Reporting.Render.Type.Localizer as L
26+import qualified Reporting.Result as Result
27+import qualified Reporting.Warning as Warning
2428import qualified Type.Constrain.Module as Type
2529import qualified Type.Solve as Type
2630
@@ -31,62 +35,93 @@ import System.IO.Unsafe (unsafePerformIO)
3135-- COMPILE
3236
3337
38+type Result i a =
39+ Result.Result i [Warning.Warning] Error.Error a
40+
41+
42+type ImportDict =
43+ Map.Map N.Name ModuleName.Canonical
44+
45+
3446data Artifacts =
3547 Artifacts
36− { _modul :: Can.Module
37− , _types :: Map.Map Name.Name Can.Annotation
38− , _graph :: Opt.LocalGraph
48+ { _elmi :: I.Interface
49+ , _elmo :: Opt.Graph
50+ , _docs :: Maybe Docs.Module
3951 }
4052
4153
42−compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
43−compile pkg ifaces modul =
44− do canonical <- canonicalize pkg ifaces modul
45− annotations <- typeCheck modul canonical
46− () <- nitpick canonical
47− objects <- optimize modul annotations canonical
48− return (Artifacts canonical annotations objects)
54+compile :: DocsFlag -> Pkg.Name -> ImportDict -> I.Interfaces -> BS.ByteString -> Result i Artifacts
55+compile flag pkg importDict interfaces source =
56+ do
57+ valid <- Result.mapError Error.Syntax $
58+ Parse.program pkg source
4959
60+ canonical <- Result.mapError Error.Canonicalize $
61+ Canonicalize.canonicalize pkg importDict interfaces valid
5062
63+ let localizer = L.fromModule valid -- TODO should this be strict for GC?
5164
52−-- PHASES
65+ annotations <-
66+ runTypeInference localizer canonical
5367
68+ () <-
69+ exhaustivenessCheck canonical
5470
55−canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
56−canonicalize pkg ifaces modul =
57− case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of
58− Right canonical ->
59− Right canonical
71+ graph <- Result.mapError (Error.Main localizer) $
72+ Optimize.optimize annotations canonical
6073
61− Left errors ->
62− Left $ E.BadNames errors
74+ documentation <-
75+ genarateDocs flag canonical
6376
77+ Result.ok $
78+ Artifacts
79+ { _elmi = I.fromModule annotations canonical
80+ , _elmo = graph
81+ , _docs = documentation
82+ }
6483
65−typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
66−typeCheck modul canonical =
84+
85+
86+-- TYPE INFERENCE
87+
88+
89+runTypeInference :: L.Localizer -> Can.Module -> Result i (Map.Map N.Name Can.Annotation)
90+runTypeInference localizer canonical =
6791 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
6892 Right annotations ->
69− Right annotations
93+ Result.ok annotations
7094
7195 Left errors ->
72− Left (E.BadTypes (Localizer.fromModule modul) errors)
96+ Result.throw (Error.Type localizer errors)
97+
7398
7499
75−nitpick :: Can.Module -> Either E.Error ()
76−nitpick canonical =
100+-- EXHAUSTIVENESS CHECK
101+
102+
103+exhaustivenessCheck :: Can.Module -> Result i ()
104+exhaustivenessCheck canonical =
77105 case PatternMatches.check canonical of
106+ Left errors ->
107+ Result.throw (Error.Pattern errors)
108+
78109 Right () ->
79− Right ()
110+ Result.ok ()
80111
81− Left errors ->
82− Left (E.BadPatterns errors)
83112
84113
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
114+-- DOCUMENTATION
90115
91− Left errors ->
92− Left (E.BadMains (Localizer.fromModule modul) errors)
116+
117+data DocsFlag = YesDocs | NoDocs
118+
119+
120+genarateDocs :: DocsFlag -> Can.Module -> Result.Result i w Error.Error (Maybe Docs.Module)
121+genarateDocs flag modul =
122+ case flag of
123+ NoDocs ->
124+ Result.ok Nothing
125+
126+ YesDocs ->
127+ Just <$> Docs.fromModule modul
compiler/src/Data/Bag.hs+11
@@ -108,3 +108,14 @@ fromList func list =
108108add :: (a -> b) -> Bag b -> a -> Bag b
109109add func bag value =
110110 Two (One (func value)) bag
111+
112+
113+
114+-- MONOID
115+
116+
117+instance Monoid (Bag a) where
118+ {-# INLINE mempty #-}
119+ mempty = Empty
120+ {-# INLINE mappend #-}
121+ mappend = Two
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.hsdeleted−610
@@ -1,610 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3−module Data.Name
4− ( Name
5− --
6− , toChars
7− , toElmString
8− , toBuilder
9− --
10− , fromPtr
11− , fromChars
12− --
13− , getKernel
14− , hasDot
15− , splitDots
16− , isKernel
17− , isNumberType
18− , isComparableType
19− , isAppendableType
20− , isCompappendType
21− , fromVarIndex
22− , fromWords
23− , fromManyNames
24− , fromTypeVariable
25− , fromTypeVariableScheme
26− , sepBy
27− --
28− , int, float, bool, char, string
29− , maybe, result, list, array, dict, tuple, jsArray
30− , task, router, cmd, sub, platform, virtualDom
31− , shader, debug, debugger, bitwise, basics
32− , utils, negate, true, false, value
33− , node, program, _main, _Main, dollar, identity
34− , replModule, replValueToPrint
35− )
36− where
37−
38−
39−import Prelude hiding (length, maybe, negate)
40−import Control.Exception (assert)
41−import qualified Data.Binary as Binary
42−import qualified Data.ByteString.Builder.Internal as B
43−import qualified Data.Coerce as Coerce
44−import qualified Data.List as List
45−import qualified Data.String as Chars
46−import qualified Data.Utf8 as Utf8
47−import GHC.Exts
48− ( Int(I#), Ptr
49− , MutableByteArray#
50− , isTrue#
51− , newByteArray#
52− , sizeofByteArray#
53− , unsafeFreezeByteArray#
54− )
55−import GHC.ST (ST(ST), runST)
56−import GHC.Prim
57−import GHC.Word (Word8(W8#))
58−
59−import qualified Elm.String as ES
60−
61−
62−
63−-- NAME
64−
65−
66−type Name =
67− Utf8.Utf8 ELM_NAME
68−
69−
70−data ELM_NAME
71−
72−
73−
74−-- INSTANCES
75−
76−
77−instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78− fromString = Utf8.fromChars
79−
80−instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81− get = Utf8.getUnder256
82− put = Utf8.putUnder256
83−
84−
85−
86−-- TO
87−
88−
89−toChars :: Name -> [Char]
90−toChars =
91− Utf8.toChars
92−
93−
94−toElmString :: Name -> ES.String
95−toElmString =
96− Coerce.coerce
97−
98−
99−{-# INLINE toBuilder #-}
100−toBuilder :: Name -> B.Builder
101−toBuilder =
102− Utf8.toBuilder
103−
104−
105−
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
117−
118−
119−
120−-- HAS DOT
121−
122−
123−hasDot :: Name -> Bool
124−hasDot name =
125− Utf8.contains 0x2E {- . -} name
126−
127−
128−splitDots :: Name -> [Name]
129−splitDots name =
130− Utf8.split 0x2E {- . -} name
131−
132−
133−
134−-- GET KERNEL
135−
136−
137−getKernel :: Name -> Name
138−getKernel name@(Utf8.Utf8 ba#) =
139− assert (isKernel name)
140− (
141− runST
142− (
143− let
144− !size# = sizeofByteArray# ba# -# 11#
145− in
146− ST $ \s ->
147− case newByteArray# size# s of
148− (# s, mba# #) ->
149− case copyByteArray# ba# 11# mba# 0# size# s of
150− s ->
151− case unsafeFreezeByteArray# mba# s of
152− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
153− )
154− )
155−
156−
157−
158−-- STARTS WITH
159−
160−
161−isKernel :: Name -> Bool
162−isKernel = Utf8.startsWith prefix_kernel
163−
164−isNumberType :: Name -> Bool
165−isNumberType = Utf8.startsWith prefix_number
166−
167−isComparableType :: Name -> Bool
168−isComparableType = Utf8.startsWith prefix_comparable
169−
170−isAppendableType :: Name -> Bool
171−isAppendableType = Utf8.startsWith prefix_appendable
172−
173−isCompappendType :: Name -> Bool
174−isCompappendType = Utf8.startsWith prefix_compappend
175−
176−{-# NOINLINE prefix_kernel #-}
177−prefix_kernel :: Name
178−prefix_kernel = fromChars "Elm.Kernel."
179−
180−{-# NOINLINE prefix_number #-}
181−prefix_number :: Name
182−prefix_number = fromChars "number"
183−
184−{-# NOINLINE prefix_comparable #-}
185−prefix_comparable :: Name
186−prefix_comparable = fromChars "comparable"
187−
188−{-# NOINLINE prefix_appendable #-}
189−prefix_appendable :: Name
190−prefix_appendable = fromChars "appendable"
191−
192−{-# NOINLINE prefix_compappend #-}
193−prefix_compappend :: Name
194−prefix_compappend = fromChars "compappend"
195−
196−
197−
198−-- FROM VAR INDEX
199−
200−
201−fromVarIndex :: Int -> Name
202−fromVarIndex n =
203− runST
204− (
205− do let !size = 2 + getIndexSize n
206− mba <- newByteArray size
207− writeWord8 mba 0 0x5F {- _ -}
208− writeWord8 mba 1 0x76 {- v -}
209− writeDigitsAtEnd mba size n
210− freeze mba
211− )
212−
213−
214−{-# INLINE getIndexSize #-}
215−getIndexSize :: Int -> Int
216−getIndexSize n
217− | n < 10 = 1
218− | n < 100 = 2
219− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
220−
221−
222−
223−writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
224−writeDigitsAtEnd !mba !oldOffset !n =
225− do let (q,r) = quotRem n 10
226− let !newOffset = oldOffset - 1
227− writeWord8 mba newOffset (0x30 + fromIntegral r)
228− if q <= 0
229− then return ()
230− else writeDigitsAtEnd mba newOffset q
231−
232−
233−
234−-- FROM TYPE VARIABLE
235−
236−
237−fromTypeVariable :: Name -> Int -> Name
238−fromTypeVariable name@(Utf8.Utf8 ba#) index =
239− if index <= 0 then
240− name
241− else
242− let
243− len# = sizeofByteArray# ba#
244− end# = indexWord8Array# ba# (len# -# 1#)
245− in
246− if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
247− runST
248− (
249− do let !size = I# len# + 1 + getIndexSize index
250− mba <- newByteArray size
251− copyToMBA name mba
252− writeWord8 mba (I# len#) 0x5F {- _ -}
253− writeDigitsAtEnd mba size index
254− freeze mba
255− )
256− else
257− runST
258− (
259− do let !size = I# len# + getIndexSize index
260− mba <- newByteArray size
261− copyToMBA name mba
262− writeDigitsAtEnd mba size index
263− freeze mba
264− )
265−
266−
267−
268−-- FROM TYPE VARIABLE SCHEME
269−
270−
271−fromTypeVariableScheme :: Int -> Name
272−fromTypeVariableScheme scheme =
273− runST
274− (
275− if scheme < 26 then
276− do mba <- newByteArray 1
277− writeWord8 mba 0 (0x61 + fromIntegral scheme)
278− freeze mba
279− else
280− do let (extra, letter) = quotRem scheme 26
281− let !size = 1 + getIndexSize extra
282− mba <- newByteArray size
283− writeWord8 mba 0 (0x61 + fromIntegral letter)
284− writeDigitsAtEnd mba size extra
285− freeze mba
286− )
287−
288−
289−
290−-- 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)
300−
301−
302−fromManyNames :: [Name] -> Name
303−fromManyNames 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− )
330−
331−
332−{-# NOINLINE blank #-}
333−blank :: Name
334−blank =
335− fromWords [0x5F,0x4D,0x24] {-_M$-}
336−
337−
338−
339−-- FROM WORDS
340−
341−
342−fromWords :: [Word8] -> Name
343−fromWords words =
344− runST
345− (
346− do mba <- newByteArray (List.length words)
347− writeWords mba 0 words
348− freeze mba
349− )
350−
351−
352−writeWords :: MBA s -> Int -> [Word8] -> ST s ()
353−writeWords !mba !i words =
354− case words of
355− [] ->
356− return ()
357−
358− w:ws ->
359− do writeWord8 mba i w
360− writeWords mba (i+1) ws
361−
362−
363−
364−-- SEP BY
365−
366−
367−sepBy :: Word8 -> Name -> Name -> Name
368−sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =
369− let
370− !len1# = sizeofByteArray# ba1#
371− !len2# = sizeofByteArray# ba2#
372− in
373− runST
374− (
375− ST $ \s ->
376− case newByteArray# (len1# +# len2# +# 1#) s of
377− (# s, mba# #) ->
378− case copyByteArray# ba1# 0# mba# 0# len1# s of
379− s ->
380− case writeWord8Array# mba# len1# sep# s of
381− s ->
382− case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
383− s ->
384− case unsafeFreezeByteArray# mba# s of
385− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
386− )
387−
388−
389−
390−-- PRIMITIVES
391−
392−
393−data MBA s =
394− MBA# (MutableByteArray# s)
395−
396−
397−{-# INLINE newByteArray #-}
398−newByteArray :: Int -> ST s (MBA s)
399−newByteArray (I# len#) =
400− ST $ \s ->
401− case newByteArray# len# s of
402− (# s, mba# #) -> (# s, MBA# mba# #)
403−
404−
405−{-# INLINE freeze #-}
406−freeze :: MBA s -> ST s Name
407−freeze (MBA# mba#) =
408− ST $ \s ->
409− case unsafeFreezeByteArray# mba# s of
410− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
411−
412−
413−{-# INLINE writeWord8 #-}
414−writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
415−writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
416− ST $ \s ->
417− case writeWord8Array# mba# offset# w# s of
418− s -> (# s, () #)
419−
420−
421−{-# INLINE copyToMBA #-}
422−copyToMBA :: Name -> MBA s -> ST s ()
423−copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
424− ST $ \s ->
425− case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
426− s -> (# s, () #)
427−
428−
429−
430−-- COMMON NAMES
431−
432−
433−{-# NOINLINE int #-}
434−int :: Name
435−int = fromChars "Int"
436−
437−
438−{-# NOINLINE float #-}
439−float :: Name
440−float = fromChars "Float"
441−
442−
443−{-# NOINLINE bool #-}
444−bool :: Name
445−bool = fromChars "Bool"
446−
447−
448−{-# NOINLINE char #-}
449−char :: Name
450−char = fromChars "Char"
451−
452−
453−{-# NOINLINE string #-}
454−string :: Name
455−string = fromChars "String"
456−
457−
458−{-# NOINLINE maybe #-}
459−maybe :: Name
460−maybe = fromChars "Maybe"
461−
462−
463−{-# NOINLINE result #-}
464−result :: Name
465−result = fromChars "Result"
466−
467−
468−{-# NOINLINE list #-}
469−list :: Name
470−list = fromChars "List"
471−
472−
473−{-# NOINLINE array #-}
474−array :: Name
475−array = fromChars "Array"
476−
477−
478−{-# NOINLINE dict #-}
479−dict :: Name
480−dict = fromChars "Dict"
481−
482−
483−{-# NOINLINE tuple #-}
484−tuple :: Name
485−tuple = fromChars "Tuple"
486−
487−
488−{-# NOINLINE jsArray #-}
489−jsArray :: Name
490−jsArray = fromChars "JsArray"
491−
492−
493−{-# NOINLINE task #-}
494−task :: Name
495−task = fromChars "Task"
496−
497−
498−{-# NOINLINE router #-}
499−router :: Name
500−router = fromChars "Router"
501−
502−
503−{-# NOINLINE cmd #-}
504−cmd :: Name
505−cmd = fromChars "Cmd"
506−
507−
508−{-# NOINLINE sub #-}
509−sub :: Name
510−sub = fromChars "Sub"
511−
512−
513−{-# NOINLINE platform #-}
514−platform :: Name
515−platform = fromChars "Platform"
516−
517−
518−{-# NOINLINE virtualDom #-}
519−virtualDom :: Name
520−virtualDom = fromChars "VirtualDom"
521−
522−
523−{-# NOINLINE shader #-}
524−shader :: Name
525−shader = fromChars "Shader"
526−
527−
528−{-# NOINLINE debug #-}
529−debug :: Name
530−debug = fromChars "Debug"
531−
532−
533−{-# NOINLINE debugger #-}
534−debugger :: Name
535−debugger = fromChars "Debugger"
536−
537−
538−{-# NOINLINE bitwise #-}
539−bitwise :: Name
540−bitwise = fromChars "Bitwise"
541−
542−
543−{-# NOINLINE basics #-}
544−basics :: Name
545−basics = fromChars "Basics"
546−
547−
548−{-# NOINLINE utils #-}
549−utils :: Name
550−utils = fromChars "Utils"
551−
552−
553−{-# NOINLINE negate #-}
554−negate :: Name
555−negate = fromChars "negate"
556−
557−
558−{-# NOINLINE true #-}
559−true :: Name
560−true = fromChars "True"
561−
562−
563−{-# NOINLINE false #-}
564−false :: Name
565−false = fromChars "False"
566−
567−
568−{-# NOINLINE value #-}
569−value :: Name
570−value = fromChars "Value"
571−
572−
573−{-# NOINLINE node #-}
574−node :: Name
575−node = fromChars "Node"
576−
577−
578−{-# NOINLINE program #-}
579−program :: Name
580−program = fromChars "Program"
581−
582−
583−{-# NOINLINE _main #-}
584−_main :: Name
585−_main = fromChars "main"
586−
587−
588−{-# NOINLINE _Main #-}
589−_Main :: Name
590−_Main = fromChars "Main"
591−
592−
593−{-# NOINLINE dollar #-}
594−dollar :: Name
595−dollar = fromChars "$"
596−
597−
598−{-# NOINLINE identity #-}
599−identity :: Name
600−identity = fromChars "identity"
601−
602−
603−{-# NOINLINE replModule #-}
604−replModule :: Name
605−replModule = fromChars "Elm_Repl"
606−
607−
608−{-# NOINLINE replValueToPrint #-}
609−replValueToPrint :: Name
610−replValueToPrint = fromChars "repl_input_value_"
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+16−51
@@ -3,9 +3,8 @@ module Data.OneOrMore
33 ( OneOrMore(..)
44 , one
55 , more
6+ , toList
67 , map
7− , destruct
8− , getFirstTwo
98 )
109 where
1110
@@ -33,67 +32,33 @@ more =
3332
3433
3534
36−-- MAP
37−
38−
39−map :: (a -> b) -> OneOrMore a -> OneOrMore b
40−map func oneOrMore =
41− case oneOrMore of
42− One value ->
43− One (func value)
44−
45− More left right ->
46− More (map func left) (map func right)
47−
48−
49−
50−-- DESTRUCT
51−
52−
53−destruct :: (a -> [a] -> b) -> OneOrMore a -> b
54−destruct func oneOrMore =
55− destructLeft func oneOrMore []
35+-- TO LIST
5636
5737
58−destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
59−destructLeft func oneOrMore xs =
60− case oneOrMore of
61− One x ->
62− func x xs
63−
64− More a b ->
65− destructLeft func a (destructRight b xs)
38+toList :: OneOrMore a -> [a]
39+toList oneOrMore =
40+ toListHelp oneOrMore []
6641
6742
68−destructRight :: OneOrMore a -> [a] -> [a]
69−destructRight oneOrMore xs =
43+toListHelp :: OneOrMore a -> [a] -> [a]
44+toListHelp oneOrMore list =
7045 case oneOrMore of
7146 One x ->
72− x : xs
47+ x : list
7348
7449 More a b ->
75− destructRight a (destructRight b xs)
50+ toListHelp a (toListHelp b list)
7651
7752
7853
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
54+-- MAP
9055
9156
92−getFirstOne :: OneOrMore a -> a
93−getFirstOne oneOrMore =
57+map :: (a -> b) -> OneOrMore a -> OneOrMore b
58+map func oneOrMore =
9459 case oneOrMore of
95− One x ->
96− x
60+ One value ->
61+ One (func value)
9762
98− More left _ ->
99− getFirstOne left
63+ More left right ->
64+ More (map func left) (map func right)
compiler/src/Data/Utf8.hsdeleted−618

This diff is too big to show here.

compiler/src/Elm/Compiler.hsnew file+97

This diff is too big to show here.

compiler/src/Elm/Compiler/Imports.hs+36−24

This diff is too big to show here.

compiler/src/Elm/Compiler/Module.hsnew file+96

This diff is too big to show here.

compiler/src/Elm/Compiler/Objects.hsnew file+108

This diff is too big to show here.

compiler/src/Elm/Compiler/Type.hs+42−40

This diff is too big to show here.

compiler/src/Elm/Compiler/Type/Extract.hs+27−79

This diff is too big to show here.

compiler/src/Elm/Compiler/Version.hsnew file+27

This diff is too big to show here.

compiler/src/Elm/Constraint.hsdeleted−260

This diff is too big to show here.

compiler/src/Elm/Docs.hs+189−243

This diff is too big to show here.

compiler/src/Elm/Float.hsdeleted−51

This diff is too big to show here.

compiler/src/Elm/Header.hsnew file+73

This diff is too big to show here.

compiler/src/Elm/Interface.hs+73−101

This diff is too big to show here.

compiler/src/Elm/Kernel.hs+151−268

This diff is too big to show here.

compiler/src/Elm/Magnitude.hsdeleted−24

This diff is too big to show here.

compiler/src/Elm/ModuleName.hsdeleted−283

This diff is too big to show here.

compiler/src/Elm/Name.hsnew file+337

This diff is too big to show here.

compiler/src/Elm/Package.hs+262−208

This diff is too big to show here.

compiler/src/Elm/String.hsdeleted−133

This diff is too big to show here.

compiler/src/Elm/Version.hsdeleted−196

This diff is too big to show here.

compiler/src/Generate/Html.hsdeleted−54

This diff is too big to show here.

compiler/src/Generate/JavaScript.hs+165−222

This diff is too big to show here.

compiler/src/Generate/JavaScript/Builder.hs+219−209

This diff is too big to show here.

compiler/src/Generate/JavaScript/Expression.hs+213−218

This diff is too big to show here.

compiler/src/Generate/JavaScript/Mode.hsnew file+106

This diff is too big to show here.

compiler/src/Generate/JavaScript/Name.hs+44−50

This diff is too big to show here.

compiler/src/Generate/Mode.hsdeleted−63

This diff is too big to show here.

compiler/src/Json/Decode.hs+209−698

This diff is too big to show here.

compiler/src/Json/Decode/Error.hsnew file+266

This diff is too big to show here.

compiler/src/Json/Decode/Internals.hsnew file+368

This diff is too big to show here.

compiler/src/Json/Encode.hs+58−46

This diff is too big to show here.

compiler/src/Json/String.hsdeleted−192

This diff is too big to show here.

compiler/src/Nitpick/PatternMatches.hs+30−33

This diff is too big to show here.

compiler/src/Optimize/Case.hs+2−2

This diff is too big to show here.

compiler/src/Optimize/DecisionTree.hs+8−29

This diff is too big to show here.

compiler/src/Optimize/Expression.hs+32−46

This diff is too big to show here.

compiler/src/Optimize/Module.hs+91−86

This diff is too big to show here.

compiler/src/Optimize/Names.hs+24−18

This diff is too big to show here.

compiler/src/Optimize/Port.hs+36−36

This diff is too big to show here.

compiler/src/Parse/Declaration.hs+131−200

This diff is too big to show here.

compiler/src/Parse/Expression.hs+363−375

This diff is too big to show here.

compiler/src/Parse/Keyword.hsdeleted−265

This diff is too big to show here.

compiler/src/Parse/Module.hs+220−411

This diff is too big to show here.

compiler/src/Parse/Number.hsdeleted−305

This diff is too big to show here.

compiler/src/Parse/Parse.hsnew file+65

This diff is too big to show here.

compiler/src/Parse/Pattern.hs+159−165

This diff is too big to show here.

compiler/src/Parse/Primitives.hs+142−318

This diff is too big to show here.

compiler/src/Parse/Primitives/Internals.hsnew file+251

This diff is too big to show here.

compiler/src/Parse/Primitives/Kernel.hsnew file+116

This diff is too big to show here.

compiler/src/Parse/Primitives/Keyword.hsnew file+235

This diff is too big to show here.

compiler/src/Parse/Primitives/Number.hsnew file+297

This diff is too big to show here.

compiler/src/Parse/Primitives/Shader.hsnew file+69

This diff is too big to show here.

compiler/src/Parse/Primitives/Symbol.hsnew file+259

This diff is too big to show here.

compiler/src/Parse/Primitives/Utf8.hsnew file+471

This diff is too big to show here.

compiler/src/Parse/Primitives/Variable.hsnew file+376

This diff is too big to show here.

compiler/src/Parse/Primitives/Whitespace.hsnew file+223

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Parse/Shader.hs+31−111

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/String.hsdeleted−343

This diff is too big to show here.

compiler/src/Parse/Symbol.hsdeleted−79

This diff is too big to show here.

compiler/src/Parse/Type.hs+152−127

This diff is too big to show here.

compiler/src/Parse/Variable.hsdeleted−387

This diff is too big to show here.

compiler/src/Reporting/Annotation.hs+24−67

This diff is too big to show here.

compiler/src/Reporting/Doc.hs+63−101

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+249−237

This diff is too big to show here.

compiler/src/Reporting/Error/Docs.hs+36−146

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.hsdeleted−344

This diff is too big to show here.

compiler/src/Reporting/Error/Main.hs+12−13

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+627−5688

This diff is too big to show here.

compiler/src/Reporting/Error/Type.hs+140−155

This diff is too big to show here.

compiler/src/Reporting/Region.hsnew file+93

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hs+44−181

This diff is too big to show here.

compiler/src/Reporting/Render/Type.hs+6−5

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+42−29

This diff is too big to show here.

compiler/src/Reporting/Report.hs+65−2

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/Suggest.hs−17

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Type/Constrain/Expression.hs+36−35

This diff is too big to show here.

compiler/src/Type/Constrain/Module.hs+22−21

This diff is too big to show here.

compiler/src/Type/Constrain/Pattern.hs+11−15

This diff is too big to show here.

compiler/src/Type/Error.hs+183−107

This diff is too big to show here.

compiler/src/Type/Instantiate.hs+4−4

This diff is too big to show here.

compiler/src/Type/Solve.hs+16−24

This diff is too big to show here.

compiler/src/Type/Type.hs+49−42

This diff is too big to show here.

compiler/src/Type/Unify.hs+22−24

This diff is too big to show here.

compiler/src/Validate.hsnew file+334

This diff is too big to show here.

docs/elm.json/application.md+12−18

This diff is too big to show here.

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

This diff is too big to show here.

docs/repl.mdnew file+66

This diff is too big to show here.

docs/upgrade-instructions/0.19.0.mddeleted−164

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+175−149

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.mddeleted−59

This diff is too big to show here.

installers/npm/README.md+23−30

This diff is too big to show here.

installers/npm/UPLOADING.mdnew file+8

This diff is too big to show here.

installers/npm/bin/elmdeleted−54

This diff is too big to show here.

installers/npm/binaries/elmnew file+1

This diff is too big to show here.

installers/npm/binaries/elm-makenew file+1

This diff is too big to show here.

installers/npm/binaries/elm-packagenew file+1

This diff is too big to show here.

installers/npm/binaries/elm-reactornew file+1

This diff is too big to show here.

installers/npm/binaries/elm-replnew file+1

This diff is too big to show here.

installers/npm/download.jsdeleted−114

This diff is too big to show here.

installers/npm/install.js+32−2

This diff is too big to show here.

installers/npm/package.json+24−16

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/elm.jsondeleted−31

This diff is too big to show here.

reactor/src/Deps.elmdeleted−1210

This diff is too big to show here.

reactor/src/mock.txtdeleted−33

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.hsdeleted−169

This diff is too big to show here.

terminal/src/Develop/Generate/Index.hsdeleted−213

This diff is too big to show here.

terminal/src/Develop/StaticFiles/Build.hsdeleted−73

This diff is too big to show here.

terminal/src/Diff.hsdeleted−359

This diff is too big to show here.

terminal/src/Init.hsdeleted−104

This diff is too big to show here.

terminal/src/Install.hsdeleted−425

This diff is too big to show here.

terminal/src/Make.hsdeleted−319

This diff is too big to show here.

terminal/src/Publish.hsdeleted−540

This diff is too big to show here.

terminal/src/Repl.hsdeleted−726

This diff is too big to show here.

reactor/assets/favicon.ico → ui/browser/assets/favicon.icorenamed

Binary file not shown.

reactor/assets/source-code-pro.ttf → ui/browser/assets/source-code-pro.ttfrenamed

Binary file not shown.

reactor/assets/source-sans-pro.ttf → ui/browser/assets/source-sans-pro.ttfrenamed

Binary file not shown.

reactor/assets/styles.css → ui/browser/assets/styles.cssrenamed+90−1

This diff is too big to show here.

ui/browser/assets/waiting.gifnew file

Binary file not shown.

reactor/check.py → ui/browser/check.pyrenamed

The content is the same.

ui/browser/elm.jsonnew file+25

This diff is too big to show here.

reactor/src/Errors.elm → ui/browser/src/Errors.elmrenamed+10−19

This diff is too big to show here.

reactor/src/Index.elm → ui/browser/src/Index.elmrenamed+31−52

This diff is too big to show here.

reactor/src/Index/Icon.elm → ui/browser/src/Index/Icon.elmrenamed

The content is the same.

reactor/src/Index/Navigator.elm → ui/browser/src/Index/Navigator.elmrenamed+1−1

This diff is too big to show here.

reactor/src/Index/Skeleton.elm → ui/browser/src/Index/Skeleton.elmrenamed

The content is the same.

reactor/src/NotFound.elm → ui/browser/src/NotFound.elmrenamed+2−2

This diff is too big to show here.

ui/terminal/src/Bump.hsnew file+19

This diff is too big to show here.

terminal/src/Develop.hs → ui/terminal/src/Develop.hsrenamed+78−70

This diff is too big to show here.

terminal/src/Develop/Generate/Help.hs → ui/terminal/src/Develop/Generate/Help.hsrenamed+4−6

This diff is too big to show here.

ui/terminal/src/Develop/Generate/Index.hsnew file+134

This diff is too big to show here.

terminal/src/Develop/Socket.hs → ui/terminal/src/Develop/Socket.hsrenamed

The content is the same.

terminal/src/Develop/StaticFiles.hs → ui/terminal/src/Develop/StaticFiles.hsrenamed+7−1

This diff is too big to show here.

ui/terminal/src/Develop/StaticFiles/Build.hsnew file+56

This diff is too big to show here.

ui/terminal/src/Diff.hsnew file+17

This diff is too big to show here.

ui/terminal/src/Install.hsnew file+38

This diff is too big to show here.

terminal/src/Main.hs → ui/terminal/src/Main.hsrenamed+52−64

This diff is too big to show here.

ui/terminal/src/Make.hsnew file+94

This diff is too big to show here.

ui/terminal/src/Publish.hsnew file+19

This diff is too big to show here.

ui/terminal/src/Repl.hsnew file+401

This diff is too big to show here.

terminal/impl/Terminal.hs → ui/terminal/src/Terminal/Args.hsrenamed+41−42

This diff is too big to show here.

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

This diff is too big to show here.

terminal/impl/Terminal/Error.hs → ui/terminal/src/Terminal/Args/Error.hsrenamed+19−32

This diff is too big to show here.

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

This diff is too big to show here.

terminal/impl/Terminal/Internal.hs → ui/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/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.