on master help sign in
396 files changed+55600−24348
since splitsnapshots
unifiedsplit
.github/CONTRIBUTING.md+18−20 .github/ISSUE_TEMPLATE.md+14−8 .github/PULL_REQUEST_TEMPLATE.md+18 .github/workflows/set-issue-expectations.yml+21 .github/workflows/set-pull-expectations.yml+19 .gitignore+1 .gitmodules .travis.yml+23−20 ContributorAgreement.pdf How to Request Features.md−93 LICENSE+6−25 README.md+12−15 Setup.hs−2 bench/elm-package.json−16 bench/src/Benchmark.elm−121 bench/src/Main.elm−46 bench/src/Native/Benchmark.js−78 bench/src/Native/BenchmarkJS.js−3919 bench/src/Realistic/Check.elm−65 bench/src/Realistic/Check15.elm−65 bench/src/Realistic/Todo.elm−169 bench/src/Realistic/Todo15.elm−167 bench/src/Syntax/Case.elm−80 bench/src/Syntax/Let.elm−37 bench/src/Syntax/Records.elm−109 bench/src/Syntax/Records15.elm−109 builder/src/BackgroundWriter.hs+42 builder/src/Build.hs+1251 builder/src/Deps/Bump.hs+37 builder/src/Deps/Diff.hs+383 builder/src/Deps/Registry.hs+213 builder/src/Deps/Solver.hs+444 builder/src/Deps/Website.hs+26 builder/src/Elm/Details.hs+833 builder/src/Elm/Outline.hs+407 builder/src/File.hs+231 builder/src/Generate.hs+211 builder/src/Http.hs+244 builder/src/Reporting.hs+474 builder/src/Reporting/Exit.hs+2069 builder/src/Reporting/Exit/Help.hs+136 builder/src/Reporting/Task.hs+114 builder/src/Stuff.hs+179 cabal.config+2 compiler/src/AST/Canonical.hs+401 compiler/src/AST/Optimized.hs+451 compiler/src/AST/Source.hs+209 compiler/src/AST/Utils/Binop.hs+55 compiler/src/AST/Utils/Shader.hs+91 compiler/src/AST/Utils/Type.hs+125 compiler/src/Canonicalize/Effects.hs+251 compiler/src/Canonicalize/Environment.hs+275 compiler/src/Canonicalize/Environment/Dups.hs+118 compiler/src/Canonicalize/Environment/Foreign.hs+304 compiler/src/Canonicalize/Environment/Local.hs+355 compiler/src/Canonicalize/Expression.hs+761 compiler/src/Canonicalize/Module.hs+296 compiler/src/Canonicalize/Pattern.hs+181 compiler/src/Canonicalize/Type.hs+162 compiler/src/Compile.hs+92 compiler/src/Data/Bag.hs+110 compiler/src/Data/Index.hs+132 compiler/src/Data/Map/Utils.hs+43 compiler/src/Data/Name.hs+610 compiler/src/Data/NonEmptyList.hs+78 compiler/src/Data/OneOrMore.hs+99 compiler/src/Data/Utf8.hs+618 compiler/src/Elm/Compiler/Imports.hs+62 compiler/src/Elm/Compiler/Type.hs+194 compiler/src/Elm/Compiler/Type/Extract.hs+285 compiler/src/Elm/Constraint.hs+260 compiler/src/Elm/Docs.hs+587 compiler/src/Elm/Float.hs+51 compiler/src/Elm/Interface.hs+254 compiler/src/Elm/Kernel.hs+365 compiler/src/Elm/Licenses.hs+185 compiler/src/Elm/Magnitude.hs+24 compiler/src/Elm/ModuleName.hs+283 compiler/src/Elm/Package.hs+374 compiler/src/Elm/String.hs+133 compiler/src/Elm/Version.hs+196 compiler/src/Generate/Html.hs+54 compiler/src/Generate/JavaScript.hs+590 compiler/src/Generate/JavaScript/Builder.hs+530 compiler/src/Generate/JavaScript/Expression.hs+1070 compiler/src/Generate/JavaScript/Functions.hs+95 compiler/src/Generate/JavaScript/Name.hs+261 compiler/src/Generate/Mode.hs+63 compiler/src/Json/Decode.hs+799 compiler/src/Json/Encode.hs+310 compiler/src/Json/String.hs+192 compiler/src/Nitpick/Debug.hs+87 compiler/src/Nitpick/PatternMatches.hs+653 src/Optimize/Case.hs → compiler/src/Optimize/Case.hs+18−30 compiler/src/Optimize/DecisionTree.hs+637 compiler/src/Optimize/Expression.hs+490 compiler/src/Optimize/Module.hs+369 compiler/src/Optimize/Names.hs+173 compiler/src/Optimize/Port.hs+327 compiler/src/Parse/Declaration.hs+266 compiler/src/Parse/Expression.hs+577 compiler/src/Parse/Keyword.hs+265 compiler/src/Parse/Module.hs+487 compiler/src/Parse/Number.hs+305 compiler/src/Parse/Pattern.hs+279 compiler/src/Parse/Primitives.hs+404 compiler/src/Parse/Shader.hs+181 compiler/src/Parse/Space.hs+273 compiler/src/Parse/String.hs+343 compiler/src/Parse/Symbol.hs+79 compiler/src/Parse/Type.hs+203 compiler/src/Parse/Variable.hs+387 compiler/src/Reporting/Annotation.hs+103 compiler/src/Reporting/Doc.hs+431 compiler/src/Reporting/Error.hs+210 compiler/src/Reporting/Error/Canonicalize.hs+1261 compiler/src/Reporting/Error/Docs.hs+250 compiler/src/Reporting/Error/Import.hs+162 compiler/src/Reporting/Error/Json.hs+344 compiler/src/Reporting/Error/Main.hs+124 compiler/src/Reporting/Error/Pattern.hs+195 compiler/src/Reporting/Error/Syntax.hs+5848 compiler/src/Reporting/Error/Type.hs+1613 compiler/src/Reporting/Render/Code.hs+288 compiler/src/Reporting/Render/Type.hs+257 compiler/src/Reporting/Render/Type/Localizer.hs+120 compiler/src/Reporting/Report.hs+22 compiler/src/Reporting/Result.hs+129 compiler/src/Reporting/Suggest.hs+52 compiler/src/Reporting/Warning.hs+104 compiler/src/Type/Constrain/Expression.hs+746 compiler/src/Type/Constrain/Module.hs+183 compiler/src/Type/Constrain/Pattern.hs+237 compiler/src/Type/Error.hs+589 compiler/src/Type/Instantiate.hs+77 compiler/src/Type/Occurs.hs+80 compiler/src/Type/Solve.hs+727 compiler/src/Type/Type.hs+726 compiler/src/Type/Unify.hs+695 compiler/src/Type/UnionFind.hs+172 docs/elm.json/application.md+69 docs/elm.json/package.md+93 docs/upgrade-instructions/0.16.md+174 docs/upgrade-instructions/0.17.md+275 docs/upgrade-instructions/0.18.md+161 docs/upgrade-instructions/0.19.0.md+164 docs/upgrade-instructions/0.19.1.md+60 changelog.md → docs/upgrade-instructions/earlier.md elm-compiler.cabal−235 elm.cabal+238 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+20−94 hints/init.md+55 hints/missing-patterns.md+66−69 hints/optimize.md+59 hints/port-modules.md+32 hints/recursive-alias.md+4−3 hints/repl.md+73 hints/shadowing.md+70 hints/tuples.md+19 hints/type-annotations.md+2−8 installers/README.md+32 installers/linux/Dockerfile+39 installers/linux/README.md+93 installers/mac/Distribution.xml+33 installers/mac/README.md+93 installers/mac/Resources/en.lproj/conclusion.rtf+16 installers/mac/Resources/en.lproj/welcome.rtf+12 installers/mac/helper-scripts/elm-startup.sh+3 installers/mac/helper-scripts/uninstall.sh+21 installers/mac/make-installer.sh+81 installers/mac/postinstall+5 installers/mac/preinstall+18 installers/npm/.gitignore+1 installers/npm/.npmignore+3 installers/npm/PUBLISHING.md+59 installers/npm/README.md+45 installers/npm/bin/elm+54 installers/npm/download.js+114 installers/npm/install.js+4 installers/npm/package.json+42 installers/npm/troubleshooting.md+76 installers/win/CreateInternetShortcut.nsh+5 installers/win/Nsisfile.nsi+264 installers/win/README.md+24 installers/win/inst.dat+6 installers/win/logo.ico installers/win/make_installer.cmd+18 installers/win/removefrompath.vbs+17 installers/win/uninst.dat+6 installers/win/updatepath.vbs+14 installers/win/welcome.bmp reactor/assets/favicon.ico reactor/assets/source-code-pro.ttf reactor/assets/source-sans-pro.ttf reactor/assets/styles.css+157 reactor/check.py+48 reactor/elm.json+31 reactor/src/Deps.elm+1210 reactor/src/Errors.elm+207 reactor/src/Index.elm+280 reactor/src/Index/Icon.elm+111 reactor/src/Index/Navigator.elm+63 reactor/src/Index/Skeleton.elm+61 reactor/src/NotFound.elm+29 reactor/src/mock.txt+33 roadmap.md+29 src/AST/Declaration.hs−152 src/AST/Effects.hs−68 src/AST/Expression/Canonical.hs−72 src/AST/Expression/General.hs−112 src/AST/Expression/Optimized.hs−81 src/AST/Expression/Source.hs−31 src/AST/Expression/Valid.hs−30 src/AST/Helpers.hs−32 src/AST/Literal.hs−54 src/AST/Module.hs−222 src/AST/Module/Name.hs−54 src/AST/Pattern.hs−109 src/AST/Type.hs−219 src/AST/Variable.hs−334 src/Canonicalize.hs−481 src/Canonicalize/Body.hs−170 src/Canonicalize/Effects.hs−137 src/Canonicalize/Environment.hs−160 src/Canonicalize/Setup.hs−452 src/Canonicalize/Sort.hs−235 src/Canonicalize/Type.hs−92 src/Canonicalize/Variable.hs−293 src/CommandLineRouter.hs−84 src/Compile.hs−80 src/Docs/AST.hs−44 src/Docs/Centralize.hs−80 src/Docs/Check.hs−181 src/Elm/Compiler.hs−194 src/Elm/Compiler/Imports.hs−39 src/Elm/Compiler/Module.hs−138 src/Elm/Compiler/Type.hs−197 src/Elm/Compiler/Type/Extract.hs−45 src/Elm/Compiler/Version.hs−27 src/Elm/Docs.hs−250 src/Elm/Package.hs−254 src/Elm/Utils.hs−107 src/Generate/JavaScript.hs−91 src/Generate/JavaScript/Builder.hs−528 src/Generate/JavaScript/BuiltIn.hs−135 src/Generate/JavaScript/Expression.hs−545 src/Generate/JavaScript/Foreign.hs−219 src/Generate/JavaScript/Helpers.hs−68 src/Generate/JavaScript/Literal.hs−25 src/Generate/JavaScript/Variable.hs−181 src/Nitpick/Pattern.hs−118 src/Nitpick/PatternMatches.hs−386 src/Nitpick/TopLevelTypes.hs−125 src/Optimize.hs−517 src/Optimize/DecisionTree.hs−467 src/Optimize/Environment.hs−59 src/Optimize/Inline.hs−305 src/Parse/Binop.hs−131 src/Parse/Declaration.hs−99 src/Parse/Expression.hs−330 src/Parse/Helpers.hs−652 src/Parse/Literal.hs−71 src/Parse/Module.hs−178 src/Parse/Parse.hs−140 src/Parse/Pattern.hs−113 src/Parse/Type.hs−105 src/Reporting/Annotation.hs−54 src/Reporting/Bag.hs−101 src/Reporting/Error.hs−89 src/Reporting/Error/Canonicalize.hs−328 src/Reporting/Error/Docs.hs−74 src/Reporting/Error/Helpers.hs−198 src/Reporting/Error/Pattern.hs−92 src/Reporting/Error/Syntax.hs−430 src/Reporting/Error/Type.hs−728 src/Reporting/Region.hs−64 src/Reporting/Render/Code.hs−113 src/Reporting/Render/Type.hs−504 src/Reporting/Report.hs−106 src/Reporting/Result.hs−179 src/Reporting/Warning.hs−67 src/Type/Constrain/Effects.hs−114 src/Type/Constrain/Expression.hs−598 src/Type/Constrain/Literal.hs−48 src/Type/Constrain/Pattern.hs−86 src/Type/Environment.hs−239 src/Type/Fragment.hs−44 src/Type/Inference.hs−108 src/Type/Solve.hs−344 src/Type/State.hs−327 src/Type/Type.hs−457 src/Type/Unify.hs−670 src/Validate.hs−706 terminal/impl/Terminal.hs+375 terminal/impl/Terminal/Chomp.hs+514 terminal/impl/Terminal/Error.hs+457 terminal/impl/Terminal/Helpers.hs+148 terminal/impl/Terminal/Internal.hs+93 terminal/src/Bump.hs+169 terminal/src/Develop.hs+256 terminal/src/Develop/Generate/Help.hs+65 terminal/src/Develop/Generate/Index.hs+213 terminal/src/Develop/Socket.hs+43 terminal/src/Develop/StaticFiles.hs+123 terminal/src/Develop/StaticFiles/Build.hs+73 terminal/src/Diff.hs+359 terminal/src/Init.hs+104 terminal/src/Install.hs+425 terminal/src/Main.hs+338 terminal/src/Make.hs+319 terminal/src/Publish.hs+540 terminal/src/Repl.hs+726 tests/Test.hs−14 tests/Test/Compiler.hs−225 tests/Test/Property.hs−68 tests/Test/Property/Arbitrary.hs−192 tests/test-files/bad/BBTArgs−1 tests/test-files/bad/IncompletePatternMatch.elm−17 tests/test-files/bad/InfiniteType.elm−2 tests/test-files/bad/NonElementMain.elm−2 tests/test-files/bad/RepeatedArgument.elm−4 tests/test-files/bad/Strings/ExtraClose.elm−4 tests/test-files/good-expected-js/Cases/CharCase.elm.js−8 tests/test-files/good-expected-js/Cases/ListZip.elm.js−21 tests/test-files/good-expected-js/CodeGenBugs/CommentInterpretedAsInfix.elm.js−13 tests/test-files/good-expected-js/CodeGenBugs/NestedPatternMatch.elm.js−4 tests/test-files/good-expected-js/CodeGenBugs/Shadowing.elm.js−16 tests/test-files/good-expected-js/CodeGenBugs/Shadowing2.elm.js−13 tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_ListAny.elm.js−20 tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_NameNormalization.elm.js−12 tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_UnsafeLabel.elm.js−23 tests/test-files/good-expected-js/Crash/CrashCase.elm.js−14 tests/test-files/good-expected-js/Crash/CrashIf.elm.js−8 tests/test-files/good-expected-js/Declarations/NoDefinitions.elm.js tests/test-files/good-expected-js/Lists/EmptyList.elm.js−2 tests/test-files/good-expected-js/Lists/ListRange.elm.js−1 tests/test-files/good-expected-js/Lists/NonEmptyList.elm.js−2 tests/test-files/good-expected-js/Records/AliasSubstitution.elm.js−3 tests/test-files/good-expected-js/Records/NonHomogeneousRecords.elm.js−9 tests/test-files/good-expected-js/Soundness/Apply.elm.js−6 tests/test-files/good-expected-js/Soundness/ApplyAnnotated.elm.js−6 tests/test-files/good-expected-js/Soundness/Id.elm.js−6 tests/test-files/good-expected-js/Soundness/IdAnnotated.elm.js−6 tests/test-files/good-expected-js/Soundness/SpecificAnnotationInt.elm.js−3 tests/test-files/good-expected-js/Soundness/SpecificAnnotationNumber.elm.js−3 tests/test-files/good-expected-js/Soundness/TrickyId.elm.js−4 tests/test-files/good-expected-js/Soundness/TrickyIdAnnotated.elm.js−4 tests/test-files/good-expected-js/Strings/Multiline.elm.js−1 tests/test-files/good-expected-js/Strings/MultilineNormal.elm.js−1 tests/test-files/good-expected-js/Strings/QuotesAndComments.elm.js−7 tests/test-files/good/Cases/CharCase.elm−8 tests/test-files/good/Cases/ListZip.elm−17 tests/test-files/good/CodeGenBugs/CommentInterpretedAsInfix.elm−12 tests/test-files/good/CodeGenBugs/NestedPatternMatch.elm−5 tests/test-files/good/CodeGenBugs/Shadowing.elm−22 tests/test-files/good/CodeGenBugs/Shadowing2.elm−25 tests/test-files/good/CodeGenBugs/TailRecursion_ListAny.elm−12 tests/test-files/good/CodeGenBugs/TailRecursion_NameNormalization.elm−8 tests/test-files/good/CodeGenBugs/TailRecursion_UnsafeLabel.elm−20 tests/test-files/good/Crash/CrashCase.elm−9 tests/test-files/good/Crash/CrashIf.elm−8 tests/test-files/good/Declarations/NoDefinitions.elm−3 tests/test-files/good/Lists/EmptyList.elm−2 tests/test-files/good/Lists/ListRange.elm−2 tests/test-files/good/Lists/NonEmptyList.elm−2 tests/test-files/good/Records/AliasSubstitution.elm−13 tests/test-files/good/Records/NonHomogeneousRecords.elm−14 tests/test-files/good/Soundness/Apply.elm−3 tests/test-files/good/Soundness/ApplyAnnotated.elm−4 tests/test-files/good/Soundness/Id.elm−3 tests/test-files/good/Soundness/IdAnnotated.elm−4 tests/test-files/good/Soundness/SpecificAnnotationInt.elm−4 tests/test-files/good/Soundness/SpecificAnnotationNumber.elm−4 tests/test-files/good/Soundness/TrickyId.elm−2 tests/test-files/good/Soundness/TrickyIdAnnotated.elm−3 tests/test-files/good/Strings/Multiline.elm−4 tests/test-files/good/Strings/MultilineNormal.elm−5 tests/test-files/good/Strings/QuotesAndComments.elm−16 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+18−20
@@ -4,10 +4,15 @@ 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
87
9−You need to sign the [contributor agreement](ContributorAgreement.pdf)
10−and send it to <info@elm-lang.org> before opening your pull request.
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+
1116
1217## Style Guide
1318
@@ -17,27 +22,20 @@ and send it to <info@elm-lang.org> before opening your pull request.
1722[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be
1823[js]: https://google.github.io/styleguide/javascriptguide.xml
1924
20−## Branches
2125
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!
26+## Branches
2527
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.
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!
2931
3032[master]: http://github.com/elm-lang/elm/tree/master
31−[stable]: http://github.com/elm-lang/elm/tree/stable
3233
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.
3734
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.
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:
38+
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.
40+
4241
43−[website]: https://github.com/elm-lang/elm-lang.org
.github/ISSUE_TEMPLATE.md+14−8
@@ -1,12 +1,18 @@
1−Thank you for reporting an issue with Elm! Before submitting, please make sure it's not a commonly reported issue:
21
3−- If you're getting a runtime error, make sure you don't have any recursively defined values (see #873).
4−- If you're having trouble with type annotations in a let-expression, see #1214.
5−- If the issue relates to the core libraries (not the compiler) open an issue at https://github.com/elm-lang/core/issues
6−- If you found an unhelpful error message, report it at https://github.com/elm-lang/error-message-catalog/issues
2+**Quick Summary:** ???
73
8−Okay, now look through the "meta" issues to see if they cover your problem: https://github.com/elm-lang/elm-compiler/labels/meta
94
10−If you still don't see your bug or concern, delete this message and write up a report that satisfies the issue checklist!
5+## SSCCE
116
12− https://github.com/process-bot/contribution-checklist/blob/master/issues.md
7+```elm
8+
9+```
10+
11+- **Elm:** ???
12+- **Browser:** ???
13+- **Operating System:** ???
14+
15+
16+## Additional Details
17+
18+???
.github/PULL_REQUEST_TEMPLATE.mdnew file+18
@@ -0,0 +1,18 @@
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.ymlnew file+21
@@ -0,0 +1,21 @@
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.ymlnew file+19
@@ -0,0 +1,19 @@
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,3 +5,4 @@ cabal-dev
55cabal.sandbox.config
66.DS_Store
77*~
8+travis.log
.gitmodulesdeleted

No changes to the content.

.travis.yml+23−20
@@ -1,25 +1,28 @@
1−sudo: false
2−
3−addons:
4− apt:
5− sources:
6− - hvr-ghc
7− packages:
8− - ghc-7.10.1
9− - cabal-install-1.22
10− - happy
11− - alex
1+language: minimal
2+services: docker
123
4+env:
5+ global:
6+ - LINUX_ARCHIVE=binary-for-linux-64-bit.gz
137
148before_install:
15−- export PATH=/opt/ghc/7.10.1/bin:/opt/cabal/1.22/bin:$PATH
16−
17−
18−install:
19− - travis_retry cabal update
20− - cabal install --only-dependencies --enable-tests
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
2112
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
2222
23−script:
24− - cabal configure --enable-tests
25− - cabal test
23+notifications:
24+ email:
25+ recipients:
26+ - rlefevre@dmy.fr
27+ on_success: change
28+ on_failure: change
ContributorAgreement.pdfdeleted

Binary file not shown.

How to Request Features.mddeleted−93
@@ -1,93 +0,0 @@
1−# How to make a Feature Request
2−
3−Adding features is hard work and has long term implications for Elm.
4−If you think your particular feature is important, help make it happen
5−by doing some of the background work that goes into actually adding it.
6−
7−### Before making a Request / Formatting:
8−
9− - Make sure your feature has not already been requested. Look through the
10− email list to find similar requests.
11− - Submit feature requests by emailing the list. This allows the broadest
12− discussion and does not clutter up the GitHub repository with speculative
13− issues. I'd prefer to use the GitHub issue tracker for bug tracking and
14− issues with the existing code base.
15− - Label all feature requests with a subject like "Request: _____". For
16− example, if you want to be the umpteenth person to request type classes,
17− you would use the subject "Request: Type Classes".
18−
19−### Body of the Request:
20−
21−Your request should address all of the following issues:
22−
23−**General Problem:** Clearly define the purpose of adding the feature.
24−What general problem do you want to solve? Why is that problem important?
25−Why is it important for a functional GUI language?
26−
27−**Specific Use-Cases:** What are the specific cases when the general problem
28−is actually an issue? How often does this case come up? Why are these cases
29−important to easily designing graphical user interfaces? Why are existing
30−solutions in Elm unsuitable?
31−
32−**Background Materials:** Are there relevant papers on the topic? Are there
33−languages or libraries that already have this feature? Organize this material
34−and provide a concise and helpful overview.
35−
36−**Alternatives:** What are all the ways to address the general problem or a
37−closely related problem? For example, the semantic flexibility of type classes
38−can be largely replicated with a module system in the style of ML.
39−What are the strengths and weakness of each of the alternative solutions?
40−
41−**Suggested Approach:** Outline your specific approach. How does it address
42−the general problem? How does it work? How hard is it going to be to add?
43−What other language features does it depend on that need to be added first?
44−Try to take a look at the relevant code to see if it would require significant
45−changes. If you are suggesting an API or library changes, include an interface
46−(a list of type signatures) for the functions you would like to add (perhaps
47−multiple interfaces if there are many good approaches).
48−
49−**Known Issues:** Search for issues that people have already found. Think of
50−any other possible downside and list them too. For example, one downside of
51−typeclasses is that they are globally defined for each type, so you cannot
52−have multiple `Ord` instances for Strings. This can lead to namespace pollution
53−within a project. In general you can only implement an "interface" once per
54−type, so it is very tricky to get the flexibility of ML's module functors.
55−
56−**Justification:** Why is the added complexity of your feature worth it? Discuss
57−both implementation complexity in the compiler, and conceptual complexity that
58−users must deal with. Why is your feature better than the alternative solutions?
59−Why is it okay to ignore the known issues? Is there any way to overcome the known
60−issues? Will it be difficult or confusing for users coming from JavaScript?
61−
62−### Some final notes:
63−
64−If for some reason you cannot provide details for some of these categories,
65−explain why the category is not applicable.
66−
67−Re-read before posting. Is your request constructive? Is it well organized?
68−Are there any details you forgot? Can anything be clarified or trimmed down?
69−Considering a request takes time, so be considerate about how much work a
70−reader has to do to take it seriously.
71−
72−A feature request is not an opportunity to be sassy or glib. Try to present
73−the information and argument clearly, concisely, thoroughly, and in an unbiased
74−manner.
75−
76−This is likely to be an iterative process. People will have comments and
77−questions. Everyone please be kind. Commenters, if you think you have a
78−concern, raise it as a question: "But what happens when you do blah?" instead
79−of "This will break when you do blah". Assume you have misunderstood their
80−proposal or only have a shallow understanding of it. Seek clarification, not victory.
81−
82−Comments are not a place for flame wars. Discuss specific issues. Vague
83−complaining and unsupported claims should either be forgotten or developed
84−into specific and well-supported concerns.
85−
86−I am always working hard to add cool stuff to Elm, and it is a lot of work.
87−I must prioritize issues to focus on the things that have the highest impact
88−for improving the quality of Elm, addressing the concerns of current users,
89−and making Elm more appealing for new users. I do not have infinite time,
90−so some things must receive more attention than others. I apologize in advance.
91−
92−And to summarize, just be cool! I want Elm to be really fun and easy to use,
93−and I want your projects to be amazing!
LICENSE+6−25
@@ -1,30 +1,11 @@
1−Copyright (c) 2012-2016, Evan Czaplicki
1+Copyright 2012-present Evan Czaplicki
22
3−All rights reserved.
3+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
44
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
5+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
76
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
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.
108
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.
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.
1510
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.
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.
README.md+12−15
@@ -1,25 +1,22 @@
1−Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
1+# Elm
22
3−[![Build Status](https://travis-ci.org/elm-lang/elm-compiler.svg?branch=master)](https://travis-ci.org/elm-lang/elm-compiler)
3+A delightful language for reliable webapps.
4+
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/)
46
5−## Install
67
7−Follow [these instructions][installer] to use Elm on your machine. Be sure to use
8−the platform specific installers if you are on Mac or Windows. It's way easier!
8+<br>
99
10− [installer]: https://github.com/elm-lang/elm-platform/blob/master/README.md#elm-platform
10+## Install
1111
12−## Build from source / Contribute
12+✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
1313
14−Use [this script][build] to build the entire Elm Platform from source: the compiler,
15−REPL, package manager, and reactor. Be sure to read all the instructions to learn
16−how the script works and what your workflow will be like.
14+For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
1715
18−[build]: https://github.com/elm-lang/elm-platform/blob/master/installers/BuildFromSource.hs
16+<br>
1917
2018## Help
2119
22−If you are stuck, email
23−[the list](https://groups.google.com/forum/?fromgroups#!forum/elm-discuss)
24−or ask a question in the
25−[#Elm IRC channel](http://webchat.freenode.net/?channels=elm).
20+If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
21+
22+[slack]: http://elmlang.herokuapp.com/
Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
bench/elm-package.jsondeleted−16
@@ -1,16 +0,0 @@
1−{
2− "version": "1.0.0",
3− "summary": "Benchmarking based on benchmark.js",
4− "repository": "https://github.com/JoeyEremondi/elm-benchmark.git",
5− "license": "BSD3",
6− "source-directories": [
7− "src"
8− ],
9− "exposed-modules": [],
10− "native-modules": true,
11− "dependencies": {
12− "elm-lang/core": "2.1.0 <= v < 4.0.0",
13− "evancz/elm-html": "4.0.0 <= v < 5.0.0"
14− },
15− "elm-version": "0.15.0 <= v < 0.17.0"
16−}
bench/src/Benchmark.elmdeleted−121
@@ -1,121 +0,0 @@
1−module Benchmark
2− ( Benchmark
3− , test
4− , suite
5− , run
6− , Statistics
7− , view
8− )where
9−{-| A wrapper around benchmark.js that allows benchmarking of pure functions.
10−
11−# Creating Benchmarks
12−@docs Benchmark, test, suite
13−
14−# Run benchmarks
15−@docs run, Statistics
16−-}
17−
18−
19−import Native.Benchmark
20−import Native.BenchmarkJS
21−import String
22−import Task
23−import Html exposing (Html, div, ul, li, p, text)
24−import Html.Attributes exposing (style)
25−
26−
27−
28−-- SET UP BENCHMARK SUITE
29−
30−
31−{-| A set of benchmarks. -}
32−type Benchmark
33− = Test String Thunk
34− | Suite String (List Benchmark)
35−
36−
37−type Thunk = Thunk
38−
39−
40−{-| An individual benchmark with a name. It measures how long it takes to
41−evaluate the given function when it is passed a `()` value.
42−-}
43−test : String -> (() -> result) -> Benchmark
44−test name thunk =
45− Test name (Native.Benchmark.makeThunk thunk)
46−
47−
48−{-| A collection of benchmarks to run together.
49−-}
50−suite : String -> List Benchmark -> Benchmark
51−suite =
52− Suite
53−
54−
55−
56−-- RUN THE BENCHMARKS
57−
58−
59−{-| Statistics -}
60−type Statistics
61− = StatSuite String (List Statistics)
62− | Result String
63− { mean : Float
64− , hz : Float
65− }
66−
67−
68−{-| Run a benchmark.
69−-}
70−run : Benchmark -> Task.Task x Statistics
71−run =
72− Native.Benchmark.run
73−
74−
75−
76−-- TO HTML
77−
78−
79−view : Statistics -> Html
80−view statistics =
81− div [ style [] ]
82− [ viewHelp statistics
83− ]
84−
85−
86−viewHelp : Statistics -> Html
87−viewHelp statistics =
88− case statistics of
89− Result name {hz} ->
90− text (name ++ " - " ++ prettyFloat hz ++ " ops/sec")
91−
92− StatSuite name subStats ->
93− let
94− subResults =
95− List.map viewHelp subStats
96− in
97− p []
98− [ text name
99− , ul [] (List.map (\html -> li [] [html]) subResults)
100− ]
101−
102−
103−prettyFloat : Float -> String
104−prettyFloat float =
105− String.join "," (numberChunker (round float) [])
106−
107−
108−numberChunker : Int -> List String -> List String
109−numberChunker n chunks =
110− let
111− next =
112− n // 1000
113−
114− chunk =
115− n % 1000
116− in
117− if next == 0 then
118− toString chunk :: chunks
119−
120− else
121− numberChunker next (String.padLeft 3 '0' (toString chunk) :: chunks)
bench/src/Main.elmdeleted−46
@@ -1,46 +0,0 @@
1−module Main where
2−
3−import Html exposing (Html, text)
4−import Signal
5−import Task
6−
7−import Benchmark
8−import Syntax.Case as Case
9−import Syntax.Let as Let
10−import Syntax.Records as Records
11−import Realistic.Check as Check
12−import Realistic.Todo as Todo
13−
14−
15−-- COMPILER BENCHMARK
16−
17−compilerBenchmark : Benchmark.Benchmark
18−compilerBenchmark =
19− Benchmark.suite "generated code"
20− [ Benchmark.suite "business logic from the wild"
21− [ Check.benchmark
22− , Todo.benchmark
23− ]
24− , Benchmark.suite "syntax"
25− [ Case.benchmark
26− , Let.benchmark
27− , Records.benchmark
28− ]
29− ]
30−
31−
32−-- DISPLAY THINGS
33−
34−main =
35− results.signal
36−
37−
38−results : Signal.Mailbox Html
39−results =
40− Signal.mailbox (text "Working...")
41−
42−
43−port benchResults : Task.Task x ()
44−port benchResults =
45− Benchmark.run compilerBenchmark
46− `Task.andThen` (Benchmark.view >> Signal.send results.address)
bench/src/Native/Benchmark.jsdeleted−78
@@ -1,78 +0,0 @@
1−Elm.Native.Benchmark = {};
2−Elm.Native.Benchmark.make = function(localRuntime) {
3−
4− localRuntime.Native = localRuntime.Native || {};
5− localRuntime.Native.Benchmark = localRuntime.Native.Benchmark || {};
6− if (localRuntime.Native.Benchmark.values)
7− {
8− return localRuntime.Native.Benchmark.values;
9− }
10−
11− var List = Elm.List.make(localRuntime);
12− var Task = Elm.Native.Task.make(localRuntime);
13−
14−
15− // RUN SOME BENCHMARKS
16−
17− function run(benchmark)
18− {
19− return Task.asyncFunction(function(callback)
20− {
21− var overallSuite = new Benchmark.Suite;
22− var statistics = addTests(overallSuite, benchmark);
23− overallSuite.on('complete', function(event) {
24− callback(Task.succeed(statistics));
25− });
26− overallSuite.run({ async: true });
27− });
28− }
29−
30−
31− // ADD TESTS TO THE JS BENCHMARK SUITE
32−
33− function addTests(overallSuite, benchmark)
34− {
35− if (benchmark.ctor === 'Suite')
36− {
37− return {
38− ctor: 'StatSuite',
39− _0: benchmark._0,
40− _1: A2(List.map, curriedAddTests(overallSuite), benchmark._1)
41− };
42− }
43−
44− // WE MUST BE LOOKING AT A TEST
45− var name = benchmark._0;
46− var thunk = benchmark._1;
47−
48− var statistics = {
49− ctor: 'Result',
50− _0: name,
51− _1: null
52− };
53−
54− overallSuite.add(name, thunk, {
55− onStart: function() {
56− console.log('running: ' + name);
57− },
58− onComplete: function(event) {
59− var jsBenchmark = event.target;
60− statistics._1 = {
61− mean: jsBenchmark.stats.mean,
62− hz: jsBenchmark.hz
63− };
64− }
65− });
66−
67− return statistics;
68− }
69−
70− var curriedAddTests = F2(addTests);
71−
72−
73−
74− return localRuntime.Native.Benchmark.values = {
75− makeThunk: function(x) { return x; },
76− run: run
77− };
78−};
bench/src/Native/BenchmarkJS.jsdeleted−3919
@@ -1,3919 +0,0 @@
1−/*!
2− * Benchmark.js v1.0.0 <http://benchmarkjs.com/>
3− * Copyright 2010-2012 Mathias Bynens <http://mths.be/>
4− * Based on JSLitmus.js, copyright Robert Kieffer <http://broofa.com/>
5− * Modified by John-David Dalton <http://allyoucanleet.com/>
6− * Available under MIT license <http://mths.be/mit>
7− */
8−;(function(window, undefined) {
9− 'use strict';
10−
11− /** Used to assign each benchmark an incrimented id */
12− var counter = 0;
13−
14− /** Detect DOM document object */
15− var doc = isHostType(window, 'document') && document;
16−
17− /** Detect free variable `define` */
18− var freeDefine = typeof define == 'function' &&
19− typeof define.amd == 'object' && define.amd && define;
20−
21− /** Detect free variable `exports` */
22− var freeExports = typeof exports == 'object' && exports &&
23− (typeof global == 'object' && global && global == global.global && (window = global), exports);
24−
25− /** Detect free variable `require` */
26− var freeRequire = typeof require == 'function' && require;
27−
28− /** Used to crawl all properties regardless of enumerability */
29− var getAllKeys = Object.getOwnPropertyNames;
30−
31− /** Used to get property descriptors */
32− var getDescriptor = Object.getOwnPropertyDescriptor;
33−
34− /** Used in case an object doesn't have its own method */
35− var hasOwnProperty = {}.hasOwnProperty;
36−
37− /** Used to check if an object is extensible */
38− var isExtensible = Object.isExtensible || function() { return true; };
39−
40− /** Used to access Wade Simmons' Node microtime module */
41− var microtimeObject = req('microtime');
42−
43− /** Used to access the browser's high resolution timer */
44− var perfObject = isHostType(window, 'performance') && performance;
45−
46− /** Used to call the browser's high resolution timer */
47− var perfName = perfObject && (
48− perfObject.now && 'now' ||
49− perfObject.webkitNow && 'webkitNow'
50− );
51−
52− /** Used to access Node's high resolution timer */
53− var processObject = isHostType(window, 'process') && process;
54−
55− /** Used to check if an own property is enumerable */
56− var propertyIsEnumerable = {}.propertyIsEnumerable;
57−
58− /** Used to set property descriptors */
59− var setDescriptor = Object.defineProperty;
60−
61− /** Used to resolve a value's internal [[Class]] */
62− var toString = {}.toString;
63−
64− /** Used to prevent a `removeChild` memory leak in IE < 9 */
65− var trash = doc && doc.createElement('div');
66−
67− /** Used to integrity check compiled tests */
68− var uid = 'uid' + (+new Date);
69−
70− /** Used to avoid infinite recursion when methods call each other */
71− var calledBy = {};
72−
73− /** Used to avoid hz of Infinity */
74− var divisors = {
75− '1': 4096,
76− '2': 512,
77− '3': 64,
78− '4': 8,
79− '5': 0
80− };
81−
82− /**
83− * T-Distribution two-tailed critical values for 95% confidence
84− * http://www.itl.nist.gov/div898/handbook/eda/section3/eda3672.htm
85− */
86− var tTable = {
87− '1': 12.706,'2': 4.303, '3': 3.182, '4': 2.776, '5': 2.571, '6': 2.447,
88− '7': 2.365, '8': 2.306, '9': 2.262, '10': 2.228, '11': 2.201, '12': 2.179,
89− '13': 2.16, '14': 2.145, '15': 2.131, '16': 2.12, '17': 2.11, '18': 2.101,
90− '19': 2.093, '20': 2.086, '21': 2.08, '22': 2.074, '23': 2.069, '24': 2.064,
91− '25': 2.06, '26': 2.056, '27': 2.052, '28': 2.048, '29': 2.045, '30': 2.042,
92− 'infinity': 1.96
93− };
94−
95− /**
96− * Critical Mann-Whitney U-values for 95% confidence
97− * http://www.saburchill.com/IBbiology/stats/003.html
98− */
99− var uTable = {
100− '5': [0, 1, 2],
101− '6': [1, 2, 3, 5],
102− '7': [1, 3, 5, 6, 8],
103− '8': [2, 4, 6, 8, 10, 13],
104− '9': [2, 4, 7, 10, 12, 15, 17],
105− '10': [3, 5, 8, 11, 14, 17, 20, 23],
106− '11': [3, 6, 9, 13, 16, 19, 23, 26, 30],
107− '12': [4, 7, 11, 14, 18, 22, 26, 29, 33, 37],
108− '13': [4, 8, 12, 16, 20, 24, 28, 33, 37, 41, 45],
109− '14': [5, 9, 13, 17, 22, 26, 31, 36, 40, 45, 50, 55],
110− '15': [5, 10, 14, 19, 24, 29, 34, 39, 44, 49, 54, 59, 64],
111− '16': [6, 11, 15, 21, 26, 31, 37, 42, 47, 53, 59, 64, 70, 75],
112− '17': [6, 11, 17, 22, 28, 34, 39, 45, 51, 57, 63, 67, 75, 81, 87],
113− '18': [7, 12, 18, 24, 30, 36, 42, 48, 55, 61, 67, 74, 80, 86, 93, 99],
114− '19': [7, 13, 19, 25, 32, 38, 45, 52, 58, 65, 72, 78, 85, 92, 99, 106, 113],
115− '20': [8, 14, 20, 27, 34, 41, 48, 55, 62, 69, 76, 83, 90, 98, 105, 112, 119, 127],
116− '21': [8, 15, 22, 29, 36, 43, 50, 58, 65, 73, 80, 88, 96, 103, 111, 119, 126, 134, 142],
117− '22': [9, 16, 23, 30, 38, 45, 53, 61, 69, 77, 85, 93, 101, 109, 117, 125, 133, 141, 150, 158],
118− '23': [9, 17, 24, 32, 40, 48, 56, 64, 73, 81, 89, 98, 106, 115, 123, 132, 140, 149, 157, 166, 175],
119− '24': [10, 17, 25, 33, 42, 50, 59, 67, 76, 85, 94, 102, 111, 120, 129, 138, 147, 156, 165, 174, 183, 192],
120− '25': [10, 18, 27, 35, 44, 53, 62, 71, 80, 89, 98, 107, 117, 126, 135, 145, 154, 163, 173, 182, 192, 201, 211],
121− '26': [11, 19, 28, 37, 46, 55, 64, 74, 83, 93, 102, 112, 122, 132, 141, 151, 161, 171, 181, 191, 200, 210, 220, 230],
122− '27': [11, 20, 29, 38, 48, 57, 67, 77, 87, 97, 107, 118, 125, 138, 147, 158, 168, 178, 188, 199, 209, 219, 230, 240, 250],
123− '28': [12, 21, 30, 40, 50, 60, 70, 80, 90, 101, 111, 122, 132, 143, 154, 164, 175, 186, 196, 207, 218, 228, 239, 250, 261, 272],
124− '29': [13, 22, 32, 42, 52, 62, 73, 83, 94, 105, 116, 127, 138, 149, 160, 171, 182, 193, 204, 215, 226, 238, 249, 260, 271, 282, 294],
125− '30': [13, 23, 33, 43, 54, 65, 76, 87, 98, 109, 120, 131, 143, 154, 166, 177, 189, 200, 212, 223, 235, 247, 258, 270, 282, 293, 305, 317]
126− };
127−
128− /**
129− * An object used to flag environments/features.
130− *
131− * @static
132− * @memberOf Benchmark
133− * @type Object
134− */
135− var support = {};
136−
137− (function() {
138−
139− /**
140− * Detect Adobe AIR.
141− *
142− * @memberOf Benchmark.support
143− * @type Boolean
144− */
145− support.air = isClassOf(window.runtime, 'ScriptBridgingProxyObject');
146−
147− /**
148− * Detect if `arguments` objects have the correct internal [[Class]] value.
149− *
150− * @memberOf Benchmark.support
151− * @type Boolean
152− */
153− support.argumentsClass = isClassOf(arguments, 'Arguments');
154−
155− /**
156− * Detect if in a browser environment.
157− *
158− * @memberOf Benchmark.support
159− * @type Boolean
160− */
161− support.browser = doc && isHostType(window, 'navigator');
162−
163− /**
164− * Detect if strings support accessing characters by index.
165− *
166− * @memberOf Benchmark.support
167− * @type Boolean
168− */
169− support.charByIndex =
170− // IE 8 supports indexes on string literals but not string objects
171− ('x'[0] + Object('x')[0]) == 'xx';
172−
173− /**
174− * Detect if strings have indexes as own properties.
175− *
176− * @memberOf Benchmark.support
177− * @type Boolean
178− */
179− support.charByOwnIndex =
180− // Narwhal, Rhino, RingoJS, IE 8, and Opera < 10.52 support indexes on
181− // strings but don't detect them as own properties
182− support.charByIndex && hasKey('x', '0');
183−
184− /**
185− * Detect if Java is enabled/exposed.
186− *
187− * @memberOf Benchmark.support
188− * @type Boolean
189− */
190− support.java = isClassOf(window.java, 'JavaPackage');
191−
192− /**
193− * Detect if the Timers API exists.
194− *
195− * @memberOf Benchmark.support
196− * @type Boolean
197− */
198− support.timeout = isHostType(window, 'setTimeout') && isHostType(window, 'clearTimeout');
199−
200− /**
201− * Detect if functions support decompilation.
202− *
203− * @name decompilation
204− * @memberOf Benchmark.support
205− * @type Boolean
206− */
207− try {
208− // Safari 2.x removes commas in object literals
209− // from Function#toString results
210− // http://webk.it/11609
211− // Firefox 3.6 and Opera 9.25 strip grouping
212− // parentheses from Function#toString results
213− // http://bugzil.la/559438
214− support.decompilation = Function(
215− 'return (' + (function(x) { return { 'x': '' + (1 + x) + '', 'y': 0 }; }) + ')'
216− )()(0).x === '1';
217− } catch(e) {
218− support.decompilation = false;
219− }
220−
221− /**
222− * Detect ES5+ property descriptor API.
223− *
224− * @name descriptors
225− * @memberOf Benchmark.support
226− * @type Boolean
227− */
228− try {
229− var o = {};
230− support.descriptors = (setDescriptor(o, o, o), 'value' in getDescriptor(o, o));
231− } catch(e) {
232− support.descriptors = false;
233− }
234−
235− /**
236− * Detect ES5+ Object.getOwnPropertyNames().
237− *
238− * @name getAllKeys
239− * @memberOf Benchmark.support
240− * @type Boolean
241− */
242− try {
243− support.getAllKeys = /\bvalueOf\b/.test(getAllKeys(Object.prototype));
244− } catch(e) {
245− support.getAllKeys = false;
246− }
247−
248− /**
249− * Detect if own properties are iterated before inherited properties (all but IE < 9).
250− *
251− * @name iteratesOwnLast
252− * @memberOf Benchmark.support
253− * @type Boolean
254− */
255− support.iteratesOwnFirst = (function() {
256− var props = [];
257− function ctor() { this.x = 1; }
258− ctor.prototype = { 'y': 1 };
259− for (var prop in new ctor) { props.push(prop); }
260− return props[0] == 'x';
261− }());
262−
263− /**
264− * Detect if a node's [[Class]] is resolvable (all but IE < 9)
265− * and that the JS engine errors when attempting to coerce an object to a
266− * string without a `toString` property value of `typeof` "function".
267− *
268− * @name nodeClass
269− * @memberOf Benchmark.support
270− * @type Boolean
271− */
272− try {
273− support.nodeClass = ({ 'toString': 0 } + '', toString.call(doc || 0) != '[object Object]');
274− } catch(e) {
275− support.nodeClass = true;
276− }
277− }());
278−
279− /**
280− * Timer object used by `clock()` and `Deferred#resolve`.
281− *
282− * @private
283− * @type Object
284− */
285− var timer = {
286−
287− /**
288− * The timer namespace object or constructor.
289− *
290− * @private
291− * @memberOf timer
292− * @type Function|Object
293− */
294− 'ns': Date,
295−
296− /**
297− * Starts the deferred timer.
298− *
299− * @private
300− * @memberOf timer
301− * @param {Object} deferred The deferred instance.
302− */
303− 'start': null, // lazy defined in `clock()`
304−
305− /**
306− * Stops the deferred timer.
307− *
308− * @private
309− * @memberOf timer
310− * @param {Object} deferred The deferred instance.
311− */
312− 'stop': null // lazy defined in `clock()`
313− };
314−
315− /** Shortcut for inverse results */
316− var noArgumentsClass = !support.argumentsClass,
317− noCharByIndex = !support.charByIndex,
318− noCharByOwnIndex = !support.charByOwnIndex;
319−
320− /** Math shortcuts */
321− var abs = Math.abs,
322− floor = Math.floor,
323− max = Math.max,
324− min = Math.min,
325− pow = Math.pow,
326− sqrt = Math.sqrt;
327−
328− /*--------------------------------------------------------------------------*/
329−
330− /**
331− * The Benchmark constructor.
332− *
333− * @constructor
334− * @param {String} name A name to identify the benchmark.
335− * @param {Function|String} fn The test to benchmark.
336− * @param {Object} [options={}] Options object.
337− * @example
338− *
339− * // basic usage (the `new` operator is optional)
340− * var bench = new Benchmark(fn);
341− *
342− * // or using a name first
343− * var bench = new Benchmark('foo', fn);
344− *
345− * // or with options
346− * var bench = new Benchmark('foo', fn, {
347− *
348− * // displayed by Benchmark#toString if `name` is not available
349− * 'id': 'xyz',
350− *
351− * // called when the benchmark starts running
352− * 'onStart': onStart,
353− *
354− * // called after each run cycle
355− * 'onCycle': onCycle,
356− *
357− * // called when aborted
358− * 'onAbort': onAbort,
359− *
360− * // called when a test errors
361− * 'onError': onError,
362− *
363− * // called when reset
364− * 'onReset': onReset,
365− *
366− * // called when the benchmark completes running
367− * 'onComplete': onComplete,
368− *
369− * // compiled/called before the test loop
370− * 'setup': setup,
371− *
372− * // compiled/called after the test loop
373− * 'teardown': teardown
374− * });
375− *
376− * // or name and options
377− * var bench = new Benchmark('foo', {
378− *
379− * // a flag to indicate the benchmark is deferred
380− * 'defer': true,
381− *
382− * // benchmark test function
383− * 'fn': function(deferred) {
384− * // call resolve() when the deferred test is finished
385− * deferred.resolve();
386− * }
387− * });
388− *
389− * // or options only
390− * var bench = new Benchmark({
391− *
392− * // benchmark name
393− * 'name': 'foo',
394− *
395− * // benchmark test as a string
396− * 'fn': '[1,2,3,4].sort()'
397− * });
398− *
399− * // a test's `this` binding is set to the benchmark instance
400− * var bench = new Benchmark('foo', function() {
401− * 'My name is '.concat(this.name); // My name is foo
402− * });
403− */
404− function Benchmark(name, fn, options) {
405− var me = this;
406−
407− // allow instance creation without the `new` operator
408− if (me == null || me.constructor != Benchmark) {
409− return new Benchmark(name, fn, options);
410− }
411− // juggle arguments
412− if (isClassOf(name, 'Object')) {
413− // 1 argument (options)
414− options = name;
415− }
416− else if (isClassOf(name, 'Function')) {
417− // 2 arguments (fn, options)
418− options = fn;
419− fn = name;
420− }
421− else if (isClassOf(fn, 'Object')) {
422− // 2 arguments (name, options)
423− options = fn;
424− fn = null;
425− me.name = name;
426− }
427− else {
428− // 3 arguments (name, fn [, options])
429− me.name = name;
430− }
431− setOptions(me, options);
432− me.id || (me.id = ++counter);
433− me.fn == null && (me.fn = fn);
434− me.stats = deepClone(me.stats);
435− me.times = deepClone(me.times);
436− }
437−
438− /**
439− * The Deferred constructor.
440− *
441− * @constructor
442− * @memberOf Benchmark
443− * @param {Object} clone The cloned benchmark instance.
444− */
445− function Deferred(clone) {
446− var me = this;
447− if (me == null || me.constructor != Deferred) {
448− return new Deferred(clone);
449− }
450− me.benchmark = clone;
451− clock(me);
452− }
453−
454− /**
455− * The Event constructor.
456− *
457− * @constructor
458− * @memberOf Benchmark
459− * @param {String|Object} type The event type.
460− */
461− function Event(type) {
462− var me = this;
463− return (me == null || me.constructor != Event)
464− ? new Event(type)
465− : (type instanceof Event)
466− ? type
467− : extend(me, { 'timeStamp': +new Date }, typeof type == 'string' ? { 'type': type } : type);
468− }
469−
470− /**
471− * The Suite constructor.
472− *
473− * @constructor
474− * @memberOf Benchmark
475− * @param {String} name A name to identify the suite.
476− * @param {Object} [options={}] Options object.
477− * @example
478− *
479− * // basic usage (the `new` operator is optional)
480− * var suite = new Benchmark.Suite;
481− *
482− * // or using a name first
483− * var suite = new Benchmark.Suite('foo');
484− *
485− * // or with options
486− * var suite = new Benchmark.Suite('foo', {
487− *
488− * // called when the suite starts running
489− * 'onStart': onStart,
490− *
491− * // called between running benchmarks
492− * 'onCycle': onCycle,
493− *
494− * // called when aborted
495− * 'onAbort': onAbort,
496− *
497− * // called when a test errors
498− * 'onError': onError,
499− *
500− * // called when reset
501− * 'onReset': onReset,
502− *
503− * // called when the suite completes running
504− * 'onComplete': onComplete
505− * });
506− */
507− function Suite(name, options) {
508− var me = this;
509−
510− // allow instance creation without the `new` operator
511− if (me == null || me.constructor != Suite) {
512− return new Suite(name, options);
513− }
514− // juggle arguments
515− if (isClassOf(name, 'Object')) {
516− // 1 argument (options)
517− options = name;
518− } else {
519− // 2 arguments (name [, options])
520− me.name = name;
521− }
522− setOptions(me, options);
523− }
524−
525− /*--------------------------------------------------------------------------*/
526−
527− /**
528− * Note: Some array methods have been implemented in plain JavaScript to avoid
529− * bugs in IE, Opera, Rhino, and Mobile Safari.
530− *
531− * IE compatibility mode and IE < 9 have buggy Array `shift()` and `splice()`
532− * functions that fail to remove the last element, `object[0]`, of
533− * array-like-objects even though the `length` property is set to `0`.
534− * The `shift()` method is buggy in IE 8 compatibility mode, while `splice()`
535− * is buggy regardless of mode in IE < 9 and buggy in compatibility mode in IE 9.
536− *
537− * In Opera < 9.50 and some older/beta Mobile Safari versions using `unshift()`
538− * generically to augment the `arguments` object will pave the value at index 0
539− * without incrimenting the other values's indexes.
540− * https://github.com/documentcloud/underscore/issues/9
541− *
542− * Rhino and environments it powers, like Narwhal and RingoJS, may have
543− * buggy Array `concat()`, `reverse()`, `shift()`, `slice()`, `splice()` and
544− * `unshift()` functions that make sparse arrays non-sparse by assigning the
545− * undefined indexes a value of undefined.
546− * https://github.com/mozilla/rhino/commit/702abfed3f8ca043b2636efd31c14ba7552603dd
547− */
548−
549− /**
550− * Creates an array containing the elements of the host array followed by the
551− * elements of each argument in order.
552− *
553− * @memberOf Benchmark.Suite
554− * @returns {Array} The new array.
555− */
556− function concat() {
557− var value,
558− j = -1,
559− length = arguments.length,
560− result = slice.call(this),
561− index = result.length;
562−
563− while (++j < length) {
564− value = arguments[j];
565− if (isClassOf(value, 'Array')) {
566− for (var k = 0, l = value.length; k < l; k++, index++) {
567− if (k in value) {
568− result[index] = value[k];
569− }
570− }
571− } else {
572− result[index++] = value;
573− }
574− }
575− return result;
576− }
577−
578− /**
579− * Utility function used by `shift()`, `splice()`, and `unshift()`.
580− *
581− * @private
582− * @param {Number} start The index to start inserting elements.
583− * @param {Number} deleteCount The number of elements to delete from the insert point.
584− * @param {Array} elements The elements to insert.
585− * @returns {Array} An array of deleted elements.
586− */
587− function insert(start, deleteCount, elements) {
588− // `result` should have its length set to the `deleteCount`
589− // see https://bugs.ecmascript.org/show_bug.cgi?id=332
590− var deleteEnd = start + deleteCount,
591− elementCount = elements ? elements.length : 0,
592− index = start - 1,
593− length = start + elementCount,
594− object = this,
595− result = Array(deleteCount),
596− tail = slice.call(object, deleteEnd);
597−
598− // delete elements from the array
599− while (++index < deleteEnd) {
600− if (index in object) {
601− result[index - start] = object[index];
602− delete object[index];
603− }
604− }
605− // insert elements
606− index = start - 1;
607− while (++index < length) {
608− object[index] = elements[index - start];
609− }
610− // append tail elements
611− start = index--;
612− length = max(0, (object.length >>> 0) - deleteCount + elementCount);
613− while (++index < length) {
614− if ((index - start) in tail) {
615− object[index] = tail[index - start];
616− } else if (index in object) {
617− delete object[index];
618− }
619− }
620− // delete excess elements
621− deleteCount = deleteCount > elementCount ? deleteCount - elementCount : 0;
622− while (deleteCount--) {
623− index = length + deleteCount;
624− if (index in object) {
625− delete object[index];
626− }
627− }
628− object.length = length;
629− return result;
630− }
631−
632− /**
633− * Rearrange the host array's elements in reverse order.
634− *
635− * @memberOf Benchmark.Suite
636− * @returns {Array} The reversed array.
637− */
638− function reverse() {
639− var upperIndex,
640− value,
641− index = -1,
642− object = Object(this),
643− length = object.length >>> 0,
644− middle = floor(length / 2);
645−
646− if (length > 1) {
647− while (++index < middle) {
648− upperIndex = length - index - 1;
649− value = upperIndex in object ? object[upperIndex] : uid;
650− if (index in object) {
651− object[upperIndex] = object[index];
652− } else {
653− delete object[upperIndex];
654− }
655− if (value != uid) {
656− object[index] = value;
657− } else {
658− delete object[index];
659− }
660− }
661− }
662− return object;
663− }
664−
665− /**
666− * Removes the first element of the host array and returns it.
667− *
668− * @memberOf Benchmark.Suite
669− * @returns {Mixed} The first element of the array.
670− */
671− function shift() {
672− return insert.call(this, 0, 1)[0];
673− }
674−
675− /**
676− * Creates an array of the host array's elements from the start index up to,
677− * but not including, the end index.
678− *
679− * @memberOf Benchmark.Suite
680− * @param {Number} start The starting index.
681− * @param {Number} end The end index.
682− * @returns {Array} The new array.
683− */
684− function slice(start, end) {
685− var index = -1,
686− object = Object(this),
687− length = object.length >>> 0,
688− result = [];
689−
690− start = toInteger(start);
691− start = start < 0 ? max(length + start, 0) : min(start, length);
692− start--;
693− end = end == null ? length : toInteger(end);
694− end = end < 0 ? max(length + end, 0) : min(end, length);
695−
696− while ((++index, ++start) < end) {
697− if (start in object) {
698− result[index] = object[start];
699− }
700− }
701− return result;
702− }
703−
704− /**
705− * Allows removing a range of elements and/or inserting elements into the
706− * host array.
707− *
708− * @memberOf Benchmark.Suite
709− * @param {Number} start The start index.
710− * @param {Number} deleteCount The number of elements to delete.
711− * @param {Mixed} [val1, val2, ...] values to insert at the `start` index.
712− * @returns {Array} An array of removed elements.
713− */
714− function splice(start, deleteCount) {
715− var object = Object(this),
716− length = object.length >>> 0;
717−
718− start = toInteger(start);
719− start = start < 0 ? max(length + start, 0) : min(start, length);
720−
721− // support the de-facto SpiderMonkey extension
722− // https://developer.mozilla.org/en/JavaScript/Reference/Global_Objects/Array/splice#Parameters
723− // https://bugs.ecmascript.org/show_bug.cgi?id=429
724− deleteCount = arguments.length == 1
725− ? length - start
726− : min(max(toInteger(deleteCount), 0), length - start);
727−
728− return insert.call(object, start, deleteCount, slice.call(arguments, 2));
729− }
730−
731− /**
732− * Converts the specified `value` to an integer.
733− *
734− * @private
735− * @param {Mixed} value The value to convert.
736− * @returns {Number} The resulting integer.
737− */
738− function toInteger(value) {
739− value = +value;
740− return value === 0 || !isFinite(value) ? value || 0 : value - (value % 1);
741− }
742−
743− /**
744− * Appends arguments to the host array.
745− *
746− * @memberOf Benchmark.Suite
747− * @returns {Number} The new length.
748− */
749− function unshift() {
750− var object = Object(this);
751− insert.call(object, 0, 0, arguments);
752− return object.length;
753− }
754−
755− /*--------------------------------------------------------------------------*/
756−
757− /**
758− * A generic `Function#bind` like method.
759− *
760− * @private
761− * @param {Function} fn The function to be bound to `thisArg`.
762− * @param {Mixed} thisArg The `this` binding for the given function.
763− * @returns {Function} The bound function.
764− */
765− function bind(fn, thisArg) {
766− return function() { fn.apply(thisArg, arguments); };
767− }
768−
769− /**
770− * Creates a function from the given arguments string and body.
771− *
772− * @private
773− * @param {String} args The comma separated function arguments.
774− * @param {String} body The function body.
775− * @returns {Function} The new function.
776− */
777− function createFunction() {
778− // lazy define
779− createFunction = function(args, body) {
780− var result,
781− anchor = freeDefine ? define.amd : Benchmark,
782− prop = uid + 'createFunction';
783−
784− runScript((freeDefine ? 'define.amd.' : 'Benchmark.') + prop + '=function(' + args + '){' + body + '}');
785− result = anchor[prop];
786− delete anchor[prop];
787− return result;
788− };
789− // fix JaegerMonkey bug
790− // http://bugzil.la/639720
791− createFunction = support.browser && (createFunction('', 'return"' + uid + '"') || noop)() == uid ? createFunction : Function;
792− return createFunction.apply(null, arguments);
793− }
794−
795− /**
796− * Delay the execution of a function based on the benchmark's `delay` property.
797− *
798− * @private
799− * @param {Object} bench The benchmark instance.
800− * @param {Object} fn The function to execute.
801− */
802− function delay(bench, fn) {
803− bench._timerId = setTimeout(fn, bench.delay * 1e3);
804− }
805−
806− /**
807− * Destroys the given element.
808− *
809− * @private
810− * @param {Element} element The element to destroy.
811− */
812− function destroyElement(element) {
813− trash.appendChild(element);
814− trash.innerHTML = '';
815− }
816−
817− /**
818− * Iterates over an object's properties, executing the `callback` for each.
819− * Callbacks may terminate the loop by explicitly returning `false`.
820− *
821− * @private
822− * @param {Object} object The object to iterate over.
823− * @param {Function} callback The function executed per own property.
824− * @param {Object} options The options object.
825− * @returns {Object} Returns the object iterated over.
826− */
827− function forProps() {
828− var forShadowed,
829− skipSeen,
830− forArgs = true,
831− shadowed = ['constructor', 'hasOwnProperty', 'isPrototypeOf', 'propertyIsEnumerable', 'toLocaleString', 'toString', 'valueOf'];
832−
833− (function(enumFlag, key) {
834− // must use a non-native constructor to catch the Safari 2 issue
835− function Klass() { this.valueOf = 0; };
836− Klass.prototype.valueOf = 0;
837− // check various for-in bugs
838− for (key in new Klass) {
839− enumFlag += key == 'valueOf' ? 1 : 0;
840− }
841− // check if `arguments` objects have non-enumerable indexes
842− for (key in arguments) {
843− key == '0' && (forArgs = false);
844− }
845− // Safari 2 iterates over shadowed properties twice
846− // http://replay.waybackmachine.org/20090428222941/http://tobielangel.com/2007/1/29/for-in-loop-broken-in-safari/
847− skipSeen = enumFlag == 2;
848− // IE < 9 incorrectly makes an object's properties non-enumerable if they have
849− // the same name as other non-enumerable properties in its prototype chain.
850− forShadowed = !enumFlag;
851− }(0));
852−
853− // lazy define
854− forProps = function(object, callback, options) {
855− options || (options = {});
856−
857− var result = object;
858− object = Object(object);
859−
860− var ctor,
861− key,
862− keys,
863− skipCtor,
864− done = !result,
865− which = options.which,
866− allFlag = which == 'all',
867− index = -1,
868− iteratee = object,
869− length = object.length,
870− ownFlag = allFlag || which == 'own',
871− seen = {},
872− skipProto = isClassOf(object, 'Function'),
873− thisArg = options.bind;
874−
875− if (thisArg !== undefined) {
876− callback = bind(callback, thisArg);
877− }
878− // iterate all properties
879− if (allFlag && support.getAllKeys) {
880− for (index = 0, keys = getAllKeys(object), length = keys.length; index < length; index++) {
881− key = keys[index];
882− if (callback(object[key], key, object) === false) {
883− break;
884− }
885− }
886− }
887− // else iterate only enumerable properties
888− else {
889− for (key in object) {
890− // Firefox < 3.6, Opera > 9.50 - Opera < 11.60, and Safari < 5.1
891− // (if the prototype or a property on the prototype has been set)
892− // incorrectly set a function's `prototype` property [[Enumerable]] value
893− // to `true`. Because of this we standardize on skipping the `prototype`
894− // property of functions regardless of their [[Enumerable]] value.
895− if ((done =
896− !(skipProto && key == 'prototype') &&
897− !(skipSeen && (hasKey(seen, key) || !(seen[key] = true))) &&
898− (!ownFlag || ownFlag && hasKey(object, key)) &&
899− callback(object[key], key, object) === false)) {
900− break;
901− }
902− }
903− // in IE < 9 strings don't support accessing characters by index
904− if (!done && (forArgs && isArguments(object) ||
905− ((noCharByIndex || noCharByOwnIndex) && isClassOf(object, 'String') &&
906− (iteratee = noCharByIndex ? object.split('') : object)))) {
907− while (++index < length) {
908− if ((done =
909− callback(iteratee[index], String(index), object) === false)) {
910− break;
911− }
912− }
913− }
914− if (!done && forShadowed) {
915− // Because IE < 9 can't set the `[[Enumerable]]` attribute of an existing
916− // property and the `constructor` property of a prototype defaults to
917− // non-enumerable, we manually skip the `constructor` property when we
918− // think we are iterating over a `prototype` object.
919− ctor = object.constructor;
920− skipCtor = ctor && ctor.prototype && ctor.prototype.constructor === ctor;
921− for (index = 0; index < 7; index++) {
922− key = shadowed[index];
923− if (!(skipCtor && key == 'constructor') &&
924− hasKey(object, key) &&
925− callback(object[key], key, object) === false) {
926− break;
927− }
928− }
929− }
930− }
931− return result;
932− };
933− return forProps.apply(null, arguments);
934− }
935−
936− /**
937− * Gets the name of the first argument from a function's source.
938− *
939− * @private
940− * @param {Function} fn The function.
941− * @returns {String} The argument name.
942− */
943− function getFirstArgument(fn) {
944− return (!hasKey(fn, 'toString') &&
945− (/^[\s(]*function[^(]*\(([^\s,)]+)/.exec(fn) || 0)[1]) || '';
946− }
947−
948− /**
949− * Computes the arithmetic mean of a sample.
950− *
951− * @private
952− * @param {Array} sample The sample.
953− * @returns {Number} The mean.
954− */
955− function getMean(sample) {
956− return reduce(sample, function(sum, x) {
957− return sum + x;
958− }) / sample.length || 0;
959− }
960−
961− /**
962− * Gets the source code of a function.
963− *
964− * @private
965− * @param {Function} fn The function.
966− * @param {String} altSource A string used when a function's source code is unretrievable.
967− * @returns {String} The function's source code.
968− */
969− function getSource(fn, altSource) {
970− var result = altSource;
971− if (isStringable(fn)) {
972− result = String(fn);
973− } else if (support.decompilation) {
974− // escape the `{` for Firefox 1
975− result = (/^[^{]+\{([\s\S]*)}\s*$/.exec(fn) || 0)[1];
976− }
977− // trim string
978− result = (result || '').replace(/^\s+|\s+$/g, '');
979−
980− // detect strings containing only the "use strict" directive
981− return /^(?:\/\*+[\w|\W]*?\*\/|\/\/.*?[\n\r\u2028\u2029]|\s)*(["'])use strict\1;?$/.test(result)
982− ? ''
983− : result;
984− }
985−
986− /**
987− * Checks if a value is an `arguments` object.
988− *
989− * @private
990− * @param {Mixed} value The value to check.
991− * @returns {Boolean} Returns `true` if the value is an `arguments` object, else `false`.
992− */
993− function isArguments() {
994− // lazy define
995− isArguments = function(value) {
996− return toString.call(value) == '[object Arguments]';
997− };
998− if (noArgumentsClass) {
999− isArguments = function(value) {
1000− return hasKey(value, 'callee') &&
1001− !(propertyIsEnumerable && propertyIsEnumerable.call(value, 'callee'));
1002− };
1003− }
1004− return isArguments(arguments[0]);
1005− }
1006−
1007− /**
1008− * Checks if an object is of the specified class.
1009− *
1010− * @private
1011− * @param {Mixed} value The value to check.
1012− * @param {String} name The name of the class.
1013− * @returns {Boolean} Returns `true` if the value is of the specified class, else `false`.
1014− */
1015− function isClassOf(value, name) {
1016− return value != null && toString.call(value) == '[object ' + name + ']';
1017− }
1018−
1019− /**
1020− * Host objects can return type values that are different from their actual
1021− * data type. The objects we are concerned with usually return non-primitive
1022− * types of object, function, or unknown.
1023− *
1024− * @private
1025− * @param {Mixed} object The owner of the property.
1026− * @param {String} property The property to check.
1027− * @returns {Boolean} Returns `true` if the property value is a non-primitive, else `false`.
1028− */
1029− function isHostType(object, property) {
1030− var type = object != null ? typeof object[property] : 'number';
1031− return !/^(?:boolean|number|string|undefined)$/.test(type) &&
1032− (type == 'object' ? !!object[property] : true);
1033− }
1034−
1035− /**
1036− * Checks if a given `value` is an object created by the `Object` constructor
1037− * assuming objects created by the `Object` constructor have no inherited
1038− * enumerable properties and that there are no `Object.prototype` extensions.
1039− *
1040− * @private
1041− * @param {Mixed} value The value to check.
1042− * @returns {Boolean} Returns `true` if the `value` is a plain `Object` object, else `false`.
1043− */
1044− function isPlainObject(value) {
1045− // avoid non-objects and false positives for `arguments` objects in IE < 9
1046− var result = false;
1047− if (!(value && typeof value == 'object') || isArguments(value)) {
1048− return result;
1049− }
1050− // IE < 9 presents DOM nodes as `Object` objects except they have `toString`
1051− // methods that are `typeof` "string" and still can coerce nodes to strings.
1052− // Also check that the constructor is `Object` (i.e. `Object instanceof Object`)
1053− var ctor = value.constructor;
1054− if ((support.nodeClass || !(typeof value.toString != 'function' && typeof (value + '') == 'string')) &&
1055− (!isClassOf(ctor, 'Function') || ctor instanceof ctor)) {
1056− // In most environments an object's own properties are iterated before
1057− // its inherited properties. If the last iterated property is an object's
1058− // own property then there are no inherited enumerable properties.
1059− if (support.iteratesOwnFirst) {
1060− forProps(value, function(subValue, subKey) {
1061− result = subKey;
1062− });
1063− return result === false || hasKey(value, result);
1064− }
1065− // IE < 9 iterates inherited properties before own properties. If the first
1066− // iterated property is an object's own property then there are no inherited
1067− // enumerable properties.
1068− forProps(value, function(subValue, subKey) {
1069− result = !hasKey(value, subKey);
1070− return false;
1071− });
1072− return result === false;
1073− }
1074− return result;
1075− }
1076−
1077− /**
1078− * Checks if a value can be safely coerced to a string.
1079− *
1080− * @private
1081− * @param {Mixed} value The value to check.
1082− * @returns {Boolean} Returns `true` if the value can be coerced, else `false`.
1083− */
1084− function isStringable(value) {
1085− return hasKey(value, 'toString') || isClassOf(value, 'String');
1086− }
1087−
1088− /**
1089− * Wraps a function and passes `this` to the original function as the
1090− * first argument.
1091− *
1092− * @private
1093− * @param {Function} fn The function to be wrapped.
1094− * @returns {Function} The new function.
1095− */
1096− function methodize(fn) {
1097− return function() {
1098− var args = [this];
1099− args.push.apply(args, arguments);
1100− return fn.apply(null, args);
1101− };
1102− }
1103−
1104− /**
1105− * A no-operation function.
1106− *
1107− * @private
1108− */
1109− function noop() {
1110− // no operation performed
1111− }
1112−
1113− /**
1114− * A wrapper around require() to suppress `module missing` errors.
1115− *
1116− * @private
1117− * @param {String} id The module id.
1118− * @returns {Mixed} The exported module or `null`.
1119− */
1120− function req(id) {
1121− try {
1122− var result = freeExports && freeRequire(id);
1123− } catch(e) { }
1124− return result || null;
1125− }
1126−
1127− /**
1128− * Runs a snippet of JavaScript via script injection.
1129− *
1130− * @private
1131− * @param {String} code The code to run.
1132− */
1133− function runScript(code) {
1134− var anchor = freeDefine ? define.amd : Benchmark,
1135− script = doc.createElement('script'),
1136− sibling = doc.getElementsByTagName('script')[0],
1137− parent = sibling.parentNode,
1138− prop = uid + 'runScript',
1139− prefix = '(' + (freeDefine ? 'define.amd.' : 'Benchmark.') + prop + '||function(){})();';
1140−
1141− // Firefox 2.0.0.2 cannot use script injection as intended because it executes
1142− // asynchronously, but that's OK because script injection is only used to avoid
1143− // the previously commented JaegerMonkey bug.
1144− try {
1145− // remove the inserted script *before* running the code to avoid differences
1146− // in the expected script element count/order of the document.
1147− script.appendChild(doc.createTextNode(prefix + code));
1148− anchor[prop] = function() { destroyElement(script); };
1149− } catch(e) {
1150− parent = parent.cloneNode(false);
1151− sibling = null;
1152− script.text = code;
1153− }
1154− parent.insertBefore(script, sibling);
1155− delete anchor[prop];
1156− }
1157−
1158− /**
1159− * A helper function for setting options/event handlers.
1160− *
1161− * @private
1162− * @param {Object} bench The benchmark instance.
1163− * @param {Object} [options={}] Options object.
1164− */
1165− function setOptions(bench, options) {
1166− options = extend({}, bench.constructor.options, options);
1167− bench.options = forOwn(options, function(value, key) {
1168− if (value != null) {
1169− // add event listeners
1170− if (/^on[A-Z]/.test(key)) {
1171− forEach(key.split(' '), function(key) {
1172− bench.on(key.slice(2).toLowerCase(), value);
1173− });
1174− } else if (!hasKey(bench, key)) {
1175− bench[key] = deepClone(value);
1176− }
1177− }
1178− });
1179− }
1180−
1181− /*--------------------------------------------------------------------------*/
1182−
1183− /**
1184− * Handles cycling/completing the deferred benchmark.
1185− *
1186− * @memberOf Benchmark.Deferred
1187− */
1188− function resolve() {
1189− var me = this,
1190− clone = me.benchmark,
1191− bench = clone._original;
1192−
1193− if (bench.aborted) {
1194− // cycle() -> clone cycle/complete event -> compute()'s invoked bench.run() cycle/complete
1195− me.teardown();
1196− clone.running = false;
1197− cycle(me);
1198− }
1199− else if (++me.cycles < clone.count) {
1200− // continue the test loop
1201− if (support.timeout) {
1202− // use setTimeout to avoid a call stack overflow if called recursively
1203− setTimeout(function() { clone.compiled.call(me, timer); }, 0);
1204− } else {
1205− clone.compiled.call(me, timer);
1206− }
1207− }
1208− else {
1209− timer.stop(me);
1210− me.teardown();
1211− delay(clone, function() { cycle(me); });
1212− }
1213− }
1214−
1215− /*--------------------------------------------------------------------------*/
1216−
1217− /**
1218− * A deep clone utility.
1219− *
1220− * @static
1221− * @memberOf Benchmark
1222− * @param {Mixed} value The value to clone.
1223− * @returns {Mixed} The cloned value.
1224− */
1225− function deepClone(value) {
1226− var accessor,
1227− circular,
1228− clone,
1229− ctor,
1230− descriptor,
1231− extensible,
1232− key,
1233− length,
1234− markerKey,
1235− parent,
1236− result,
1237− source,
1238− subIndex,
1239− data = { 'value': value },
1240− index = 0,
1241− marked = [],
1242− queue = { 'length': 0 },
1243− unmarked = [];
1244−
1245− /**
1246− * An easily detectable decorator for cloned values.
1247− */
1248− function Marker(object) {
1249− this.raw = object;
1250− }
1251−
1252− /**
1253− * The callback used by `forProps()`.
1254− */
1255− function forPropsCallback(subValue, subKey) {
1256− // exit early to avoid cloning the marker
1257− if (subValue && subValue.constructor == Marker) {
1258− return;
1259− }
1260− // add objects to the queue
1261− if (subValue === Object(subValue)) {
1262− queue[queue.length++] = { 'key': subKey, 'parent': clone, 'source': value };
1263− }
1264− // assign non-objects
1265− else {
1266− try {
1267− // will throw an error in strict mode if the property is read-only
1268− clone[subKey] = subValue;
1269− } catch(e) { }
1270− }
1271− }
1272−
1273− /**
1274− * Gets an available marker key for the given object.
1275− */
1276− function getMarkerKey(object) {
1277− // avoid collisions with existing keys
1278− var result = uid;
1279− while (object[result] && object[result].constructor != Marker) {
1280− result += 1;
1281− }
1282− return result;
1283− }
1284−
1285− do {
1286− key = data.key;
1287− parent = data.parent;
1288− source = data.source;
1289− clone = value = source ? source[key] : data.value;
1290− accessor = circular = descriptor = false;
1291−
1292− // create a basic clone to filter out functions, DOM elements, and
1293− // other non `Object` objects
1294− if (value === Object(value)) {
1295− // use custom deep clone function if available
1296− if (isClassOf(value.deepClone, 'Function')) {
1297− clone = value.deepClone();
1298− } else {
1299− ctor = value.constructor;
1300− switch (toString.call(value)) {
1301− case '[object Array]':
1302− clone = new ctor(value.length);
1303− break;
1304−
1305− case '[object Boolean]':
1306− clone = new ctor(value == true);
1307− break;
1308−
1309− case '[object Date]':
1310− clone = new ctor(+value);
1311− break;
1312−
1313− case '[object Object]':
1314− isPlainObject(value) && (clone = {});
1315− break;
1316−
1317− case '[object Number]':
1318− case '[object String]':
1319− clone = new ctor(value);
1320− break;
1321−
1322− case '[object RegExp]':
1323− clone = ctor(value.source,
1324− (value.global ? 'g' : '') +
1325− (value.ignoreCase ? 'i' : '') +
1326− (value.multiline ? 'm' : ''));
1327− }
1328− }
1329− // continue clone if `value` doesn't have an accessor descriptor
1330− // http://es5.github.com/#x8.10.1
1331− if (clone && clone != value &&
1332− !(descriptor = source && support.descriptors && getDescriptor(source, key),
1333− accessor = descriptor && (descriptor.get || descriptor.set))) {
1334− // use an existing clone (circular reference)
1335− if ((extensible = isExtensible(value))) {
1336− markerKey = getMarkerKey(value);
1337− if (value[markerKey]) {
1338− circular = clone = value[markerKey].raw;
1339− }
1340− } else {
1341− // for frozen/sealed objects
1342− for (subIndex = 0, length = unmarked.length; subIndex < length; subIndex++) {
1343− data = unmarked[subIndex];
1344− if (data.object === value) {
1345− circular = clone = data.clone;
1346− break;
1347− }
1348− }
1349− }
1350− if (!circular) {
1351− // mark object to allow quickly detecting circular references and tie it to its clone
1352− if (extensible) {
1353− value[markerKey] = new Marker(clone);
1354− marked.push({ 'key': markerKey, 'object': value });
1355− } else {
1356− // for frozen/sealed objects
1357− unmarked.push({ 'clone': clone, 'object': value });
1358− }
1359− // iterate over object properties
1360− forProps(value, forPropsCallback, { 'which': 'all' });
1361− }
1362− }
1363− }
1364− if (parent) {
1365− // for custom property descriptors
1366− if (accessor || (descriptor && !(descriptor.configurable && descriptor.enumerable && descriptor.writable))) {
1367− if ('value' in descriptor) {
1368− descriptor.value = clone;
1369− }
1370− setDescriptor(parent, key, descriptor);
1371− }
1372− // for default property descriptors
1373− else {
1374− parent[key] = clone;
1375− }
1376− } else {
1377− result = clone;
1378− }
1379− } while ((data = queue[index++]));
1380−
1381− // remove markers
1382− for (index = 0, length = marked.length; index < length; index++) {
1383− data = marked[index];
1384− delete data.object[data.key];
1385− }
1386− return result;
1387− }
1388−
1389− /**
1390− * An iteration utility for arrays and objects.
1391− * Callbacks may terminate the loop by explicitly returning `false`.
1392− *
1393− * @static
1394− * @memberOf Benchmark
1395− * @param {Array|Object} object The object to iterate over.
1396− * @param {Function} callback The function called per iteration.
1397− * @param {Mixed} thisArg The `this` binding for the callback.
1398− * @returns {Array|Object} Returns the object iterated over.
1399− */
1400− function each(object, callback, thisArg) {
1401− var result = object;
1402− object = Object(object);
1403−
1404− var fn = callback,
1405− index = -1,
1406− length = object.length,
1407− isSnapshot = !!(object.snapshotItem && (length = object.snapshotLength)),
1408− isSplittable = (noCharByIndex || noCharByOwnIndex) && isClassOf(object, 'String'),
1409− isConvertable = isSnapshot || isSplittable || 'item' in object,
1410− origObject = object;
1411−
1412− // in Opera < 10.5 `hasKey(object, 'length')` returns `false` for NodeLists
1413− if (length === length >>> 0) {
1414− if (isConvertable) {
1415− // the third argument of the callback is the original non-array object
1416− callback = function(value, index) {
1417− return fn.call(this, value, index, origObject);
1418− };
1419− // in IE < 9 strings don't support accessing characters by index
1420− if (isSplittable) {
1421− object = object.split('');
1422− } else {
1423− object = [];
1424− while (++index < length) {
1425− // in Safari 2 `index in object` is always `false` for NodeLists
1426− object[index] = isSnapshot ? result.snapshotItem(index) : result[index];
1427− }
1428− }
1429− }
1430− forEach(object, callback, thisArg);
1431− } else {
1432− forOwn(object, callback, thisArg);
1433− }
1434− return result;
1435− }
1436−
1437− /**
1438− * Copies enumerable properties from the source(s) object to the destination object.
1439− *
1440− * @static
1441− * @memberOf Benchmark
1442− * @param {Object} destination The destination object.
1443− * @param {Object} [source={}] The source object.
1444− * @returns {Object} The destination object.
1445− */
1446− function extend(destination, source) {
1447− // Chrome < 14 incorrectly sets `destination` to `undefined` when we `delete arguments[0]`
1448− // http://code.google.com/p/v8/issues/detail?id=839
1449− var result = destination;
1450− delete arguments[0];
1451−
1452− forEach(arguments, function(source) {
1453− forProps(source, function(value, key) {
1454− result[key] = value;
1455− });
1456− });
1457− return result;
1458− }
1459−
1460− /**
1461− * A generic `Array#filter` like method.
1462− *
1463− * @static
1464− * @memberOf Benchmark
1465− * @param {Array} array The array to iterate over.
1466− * @param {Function|String} callback The function/alias called per iteration.
1467− * @param {Mixed} thisArg The `this` binding for the callback.
1468− * @returns {Array} A new array of values that passed callback filter.
1469− * @example
1470− *
1471− * // get odd numbers
1472− * Benchmark.filter([1, 2, 3, 4, 5], function(n) {
1473− * return n % 2;
1474− * }); // -> [1, 3, 5];
1475− *
1476− * // get fastest benchmarks
1477− * Benchmark.filter(benches, 'fastest');
1478− *
1479− * // get slowest benchmarks
1480− * Benchmark.filter(benches, 'slowest');
1481− *
1482− * // get benchmarks that completed without erroring
1483− * Benchmark.filter(benches, 'successful');
1484− */
1485− function filter(array, callback, thisArg) {
1486− var result;
1487−
1488− if (callback == 'successful') {
1489− // callback to exclude those that are errored, unrun, or have hz of Infinity
1490− callback = function(bench) { return bench.cycles && isFinite(bench.hz); };
1491− }
1492− else if (callback == 'fastest' || callback == 'slowest') {
1493− // get successful, sort by period + margin of error, and filter fastest/slowest
1494− result = filter(array, 'successful').sort(function(a, b) {
1495− a = a.stats; b = b.stats;
1496− return (a.mean + a.moe > b.mean + b.moe ? 1 : -1) * (callback == 'fastest' ? 1 : -1);
1497− });
1498− result = filter(result, function(bench) {
1499− return result[0].compare(bench) == 0;
1500− });
1501− }
1502− return result || reduce(array, function(result, value, index) {
1503− return callback.call(thisArg, value, index, array) ? (result.push(value), result) : result;
1504− }, []);
1505− }
1506−
1507− /**
1508− * A generic `Array#forEach` like method.
1509− * Callbacks may terminate the loop by explicitly returning `false`.
1510− *
1511− * @static
1512− * @memberOf Benchmark
1513− * @param {Array} array The array to iterate over.
1514− * @param {Function} callback The function called per iteration.
1515− * @param {Mixed} thisArg The `this` binding for the callback.
1516− * @returns {Array} Returns the array iterated over.
1517− */
1518− function forEach(array, callback, thisArg) {
1519− var index = -1,
1520− length = (array = Object(array)).length >>> 0;
1521−
1522− if (thisArg !== undefined) {
1523− callback = bind(callback, thisArg);
1524− }
1525− while (++index < length) {
1526− if (index in array &&
1527− callback(array[index], index, array) === false) {
1528− break;
1529− }
1530− }
1531− return array;
1532− }
1533−
1534− /**
1535− * Iterates over an object's own properties, executing the `callback` for each.
1536− * Callbacks may terminate the loop by explicitly returning `false`.
1537− *
1538− * @static
1539− * @memberOf Benchmark
1540− * @param {Object} object The object to iterate over.
1541− * @param {Function} callback The function executed per own property.
1542− * @param {Mixed} thisArg The `this` binding for the callback.
1543− * @returns {Object} Returns the object iterated over.
1544− */
1545− function forOwn(object, callback, thisArg) {
1546− return forProps(object, callback, { 'bind': thisArg, 'which': 'own' });
1547− }
1548−
1549− /**
1550− * Converts a number to a more readable comma-separated string representation.
1551− *
1552− * @static
1553− * @memberOf Benchmark
1554− * @param {Number} number The number to convert.
1555− * @returns {String} The more readable string representation.
1556− */
1557− function formatNumber(number) {
1558− number = String(number).split('.');
1559− return number[0].replace(/(?=(?:\d{3})+$)(?!\b)/g, ',') +
1560− (number[1] ? '.' + number[1] : '');
1561− }
1562−
1563− /**
1564− * Checks if an object has the specified key as a direct property.
1565− *
1566− * @static
1567− * @memberOf Benchmark
1568− * @param {Object} object The object to check.
1569− * @param {String} key The key to check for.
1570− * @returns {Boolean} Returns `true` if key is a direct property, else `false`.
1571− */
1572− function hasKey() {
1573− // lazy define for worst case fallback (not as accurate)
1574− hasKey = function(object, key) {
1575− var parent = object != null && (object.constructor || Object).prototype;
1576− return !!parent && key in Object(object) && !(key in parent && object[key] === parent[key]);
1577− };
1578− // for modern browsers
1579− if (isClassOf(hasOwnProperty, 'Function')) {
1580− hasKey = function(object, key) {
1581− return object != null && hasOwnProperty.call(object, key);
1582− };
1583− }
1584− // for Safari 2
1585− else if ({}.__proto__ == Object.prototype) {
1586− hasKey = function(object, key) {
1587− var result = false;
1588− if (object != null) {
1589− object = Object(object);
1590− object.__proto__ = [object.__proto__, object.__proto__ = null, result = key in object][0];
1591− }
1592− return result;
1593− };
1594− }
1595− return hasKey.apply(this, arguments);
1596− }
1597−
1598− /**
1599− * A generic `Array#indexOf` like method.
1600− *
1601− * @static
1602− * @memberOf Benchmark
1603− * @param {Array} array The array to iterate over.
1604− * @param {Mixed} value The value to search for.
1605− * @param {Number} [fromIndex=0] The index to start searching from.
1606− * @returns {Number} The index of the matched value or `-1`.
1607− */
1608− function indexOf(array, value, fromIndex) {
1609− var index = toInteger(fromIndex),
1610− length = (array = Object(array)).length >>> 0;
1611−
1612− index = (index < 0 ? max(0, length + index) : index) - 1;
1613− while (++index < length) {
1614− if (index in array && value === array[index]) {
1615− return index;
1616− }
1617− }
1618− return -1;
1619− }
1620−
1621− /**
1622− * Modify a string by replacing named tokens with matching object property values.
1623− *
1624− * @static
1625− * @memberOf Benchmark
1626− * @param {String} string The string to modify.
1627− * @param {Object} object The template object.
1628− * @returns {String} The modified string.
1629− */
1630− function interpolate(string, object) {
1631− forOwn(object, function(value, key) {
1632− // escape regexp special characters in `key`
1633− string = string.replace(RegExp('#\\{' + key.replace(/([.*+?^=!:${}()|[\]\/\\])/g, '\\$1') + '\\}', 'g'), value);
1634− });
1635− return string;
1636− }
1637−
1638− /**
1639− * Invokes a method on all items in an array.
1640− *
1641− * @static
1642− * @memberOf Benchmark
1643− * @param {Array} benches Array of benchmarks to iterate over.
1644− * @param {String|Object} name The name of the method to invoke OR options object.
1645− * @param {Mixed} [arg1, arg2, ...] Arguments to invoke the method with.
1646− * @returns {Array} A new array of values returned from each method invoked.
1647− * @example
1648− *
1649− * // invoke `reset` on all benchmarks
1650− * Benchmark.invoke(benches, 'reset');
1651− *
1652− * // invoke `emit` with arguments
1653− * Benchmark.invoke(benches, 'emit', 'complete', listener);
1654− *
1655− * // invoke `run(true)`, treat benchmarks as a queue, and register invoke callbacks
1656− * Benchmark.invoke(benches, {
1657− *
1658− * // invoke the `run` method
1659− * 'name': 'run',
1660− *
1661− * // pass a single argument
1662− * 'args': true,
1663− *
1664− * // treat as queue, removing benchmarks from front of `benches` until empty
1665− * 'queued': true,
1666− *
1667− * // called before any benchmarks have been invoked.
1668− * 'onStart': onStart,
1669− *
1670− * // called between invoking benchmarks
1671− * 'onCycle': onCycle,
1672− *
1673− * // called after all benchmarks have been invoked.
1674− * 'onComplete': onComplete
1675− * });
1676− */
1677− function invoke(benches, name) {
1678− var args,
1679− bench,
1680− queued,
1681− index = -1,
1682− eventProps = { 'currentTarget': benches },
1683− options = { 'onStart': noop, 'onCycle': noop, 'onComplete': noop },
1684− result = map(benches, function(bench) { return bench; });
1685−
1686− /**
1687− * Invokes the method of the current object and if synchronous, fetches the next.
1688− */
1689− function execute() {
1690− var listeners,
1691− async = isAsync(bench);
1692−
1693− if (async) {
1694− // use `getNext` as the first listener
1695− bench.on('complete', getNext);
1696− listeners = bench.events.complete;
1697− listeners.splice(0, 0, listeners.pop());
1698− }
1699− // execute method
1700− result[index] = isClassOf(bench && bench[name], 'Function') ? bench[name].apply(bench, args) : undefined;
1701− // if synchronous return true until finished
1702− return !async && getNext();
1703− }
1704−
1705− /**
1706− * Fetches the next bench or executes `onComplete` callback.
1707− */
1708− function getNext(event) {
1709− var cycleEvent,
1710− last = bench,
1711− async = isAsync(last);
1712−
1713− if (async) {
1714− last.off('complete', getNext);
1715− last.emit('complete');
1716− }
1717− // emit "cycle" event
1718− eventProps.type = 'cycle';
1719− eventProps.target = last;
1720− cycleEvent = Event(eventProps);
1721− options.onCycle.call(benches, cycleEvent);
1722−
1723− // choose next benchmark if not exiting early
1724− if (!cycleEvent.aborted && raiseIndex() !== false) {
1725− bench = queued ? benches[0] : result[index];
1726− if (isAsync(bench)) {
1727− delay(bench, execute);
1728− }
1729− else if (async) {
1730− // resume execution if previously asynchronous but now synchronous
1731− while (execute()) { }
1732− }
1733− else {
1734− // continue synchronous execution
1735− return true;
1736− }
1737− } else {
1738− // emit "complete" event
1739− eventProps.type = 'complete';
1740− options.onComplete.call(benches, Event(eventProps));
1741− }
1742− // When used as a listener `event.aborted = true` will cancel the rest of
1743− // the "complete" listeners because they were already called above and when
1744− // used as part of `getNext` the `return false` will exit the execution while-loop.
1745− if (event) {
1746− event.aborted = true;
1747− } else {
1748− return false;
1749− }
1750− }
1751−
1752− /**
1753− * Checks if invoking `Benchmark#run` with asynchronous cycles.
1754− */
1755− function isAsync(object) {
1756− // avoid using `instanceof` here because of IE memory leak issues with host objects
1757− var async = args[0] && args[0].async;
1758− return Object(object).constructor == Benchmark && name == 'run' &&
1759− ((async == null ? object.options.async : async) && support.timeout || object.defer);
1760− }
1761−
1762− /**
1763− * Raises `index` to the next defined index or returns `false`.
1764− */
1765− function raiseIndex() {
1766− var length = result.length;
1767− if (queued) {
1768− // if queued remove the previous bench and subsequent skipped non-entries
1769− do {
1770− ++index > 0 && shift.call(benches);
1771− } while ((length = benches.length) && !('0' in benches));
1772− }
1773− else {
1774− while (++index < length && !(index in result)) { }
1775− }
1776− // if we reached the last index then return `false`
1777− return (queued ? length : index < length) ? index : (index = false);
1778− }
1779−
1780− // juggle arguments
1781− if (isClassOf(name, 'String')) {
1782− // 2 arguments (array, name)
1783− args = slice.call(arguments, 2);
1784− } else {
1785− // 2 arguments (array, options)
1786− options = extend(options, name);
1787− name = options.name;
1788− args = isClassOf(args = 'args' in options ? options.args : [], 'Array') ? args : [args];
1789− queued = options.queued;
1790− }
1791−
1792− // start iterating over the array
1793− if (raiseIndex() !== false) {
1794− // emit "start" event
1795− bench = result[index];
1796− eventProps.type = 'start';
1797− eventProps.target = bench;
1798− options.onStart.call(benches, Event(eventProps));
1799−
1800− // end early if the suite was aborted in an "onStart" listener
1801− if (benches.aborted && benches.constructor == Suite && name == 'run') {
1802− // emit "cycle" event
1803− eventProps.type = 'cycle';
1804− options.onCycle.call(benches, Event(eventProps));
1805− // emit "complete" event
1806− eventProps.type = 'complete';
1807− options.onComplete.call(benches, Event(eventProps));
1808− }
1809− // else start
1810− else {
1811− if (isAsync(bench)) {
1812− delay(bench, execute);
1813− } else {
1814− while (execute()) { }
1815− }
1816− }
1817− }
1818− return result;
1819− }
1820−
1821− /**
1822− * Creates a string of joined array values or object key-value pairs.
1823− *
1824− * @static
1825− * @memberOf Benchmark
1826− * @param {Array|Object} object The object to operate on.
1827− * @param {String} [separator1=','] The separator used between key-value pairs.
1828− * @param {String} [separator2=': '] The separator used between keys and values.
1829− * @returns {String} The joined result.
1830− */
1831− function join(object, separator1, separator2) {
1832− var result = [],
1833− length = (object = Object(object)).length,
1834− arrayLike = length === length >>> 0;
1835−
1836− separator2 || (separator2 = ': ');
1837− each(object, function(value, key) {
1838− result.push(arrayLike ? value : key + separator2 + value);
1839− });
1840− return result.join(separator1 || ',');
1841− }
1842−
1843− /**
1844− * A generic `Array#map` like method.
1845− *
1846− * @static
1847− * @memberOf Benchmark
1848− * @param {Array} array The array to iterate over.
1849− * @param {Function} callback The function called per iteration.
1850− * @param {Mixed} thisArg The `this` binding for the callback.
1851− * @returns {Array} A new array of values returned by the callback.
1852− */
1853− function map(array, callback, thisArg) {
1854− return reduce(array, function(result, value, index) {
1855− result[index] = callback.call(thisArg, value, index, array);
1856− return result;
1857− }, Array(Object(array).length >>> 0));
1858− }
1859−
1860− /**
1861− * Retrieves the value of a specified property from all items in an array.
1862− *
1863− * @static
1864− * @memberOf Benchmark
1865− * @param {Array} array The array to iterate over.
1866− * @param {String} property The property to pluck.
1867− * @returns {Array} A new array of property values.
1868− */
1869− function pluck(array, property) {
1870− return map(array, function(object) {
1871− return object == null ? undefined : object[property];
1872− });
1873− }
1874−
1875− /**
1876− * A generic `Array#reduce` like method.
1877− *
1878− * @static
1879− * @memberOf Benchmark
1880− * @param {Array} array The array to iterate over.
1881− * @param {Function} callback The function called per iteration.
1882− * @param {Mixed} accumulator Initial value of the accumulator.
1883− * @returns {Mixed} The accumulator.
1884− */
1885− function reduce(array, callback, accumulator) {
1886− var noaccum = arguments.length < 3;
1887− forEach(array, function(value, index) {
1888− accumulator = noaccum ? (noaccum = false, value) : callback(accumulator, value, index, array);
1889− });
1890− return accumulator;
1891− }
1892−
1893− /*--------------------------------------------------------------------------*/
1894−
1895− /**
1896− * Aborts all benchmarks in the suite.
1897− *
1898− * @name abort
1899− * @memberOf Benchmark.Suite
1900− * @returns {Object} The suite instance.
1901− */
1902− function abortSuite() {
1903− var event,
1904− me = this,
1905− resetting = calledBy.resetSuite;
1906−
1907− if (me.running) {
1908− event = Event('abort');
1909− me.emit(event);
1910− if (!event.cancelled || resetting) {
1911− // avoid infinite recursion
1912− calledBy.abortSuite = true;
1913− me.reset();
1914− delete calledBy.abortSuite;
1915−
1916− if (!resetting) {
1917− me.aborted = true;
1918− invoke(me, 'abort');
1919− }
1920− }
1921− }
1922− return me;
1923− }
1924−
1925− /**
1926− * Adds a test to the benchmark suite.
1927− *
1928− * @memberOf Benchmark.Suite
1929− * @param {String} name A name to identify the benchmark.
1930− * @param {Function|String} fn The test to benchmark.
1931− * @param {Object} [options={}] Options object.
1932− * @returns {Object} The benchmark instance.
1933− * @example
1934− *
1935− * // basic usage
1936− * suite.add(fn);
1937− *
1938− * // or using a name first
1939− * suite.add('foo', fn);
1940− *
1941− * // or with options
1942− * suite.add('foo', fn, {
1943− * 'onCycle': onCycle,
1944− * 'onComplete': onComplete
1945− * });
1946− *
1947− * // or name and options
1948− * suite.add('foo', {
1949− * 'fn': fn,
1950− * 'onCycle': onCycle,
1951− * 'onComplete': onComplete
1952− * });
1953− *
1954− * // or options only
1955− * suite.add({
1956− * 'name': 'foo',
1957− * 'fn': fn,
1958− * 'onCycle': onCycle,
1959− * 'onComplete': onComplete
1960− * });
1961− */
1962− function add(name, fn, options) {
1963− var me = this,
1964− bench = Benchmark(name, fn, options),
1965− event = Event({ 'type': 'add', 'target': bench });
1966−
1967− if (me.emit(event), !event.cancelled) {
1968− me.push(bench);
1969− }
1970− return me;
1971− }
1972−
1973− /**
1974− * Creates a new suite with cloned benchmarks.
1975− *
1976− * @name clone
1977− * @memberOf Benchmark.Suite
1978− * @param {Object} options Options object to overwrite cloned options.
1979− * @returns {Object} The new suite instance.
1980− */
1981− function cloneSuite(options) {
1982− var me = this,
1983− result = new me.constructor(extend({}, me.options, options));
1984−
1985− // copy own properties
1986− forOwn(me, function(value, key) {
1987− if (!hasKey(result, key)) {
1988− result[key] = value && isClassOf(value.clone, 'Function')
1989− ? value.clone()
1990− : deepClone(value);
1991− }
1992− });
1993− return result;
1994− }
1995−
1996− /**
1997− * An `Array#filter` like method.
1998− *
1999− * @name filter
2000− * @memberOf Benchmark.Suite
2001− * @param {Function|String} callback The function/alias called per iteration.
2002− * @returns {Object} A new suite of benchmarks that passed callback filter.
2003− */
2004− function filterSuite(callback) {
2005− var me = this,
2006− result = new me.constructor;
2007−
2008− result.push.apply(result, filter(me, callback));
2009− return result;
2010− }
2011−
2012− /**
2013− * Resets all benchmarks in the suite.
2014− *
2015− * @name reset
2016− * @memberOf Benchmark.Suite
2017− * @returns {Object} The suite instance.
2018− */
2019− function resetSuite() {
2020− var event,
2021− me = this,
2022− aborting = calledBy.abortSuite;
2023−
2024− if (me.running && !aborting) {
2025− // no worries, `resetSuite()` is called within `abortSuite()`
2026− calledBy.resetSuite = true;
2027− me.abort();
2028− delete calledBy.resetSuite;
2029− }
2030− // reset if the state has changed
2031− else if ((me.aborted || me.running) &&
2032− (me.emit(event = Event('reset')), !event.cancelled)) {
2033− me.running = false;
2034− if (!aborting) {
2035− invoke(me, 'reset');
2036− }
2037− }
2038− return me;
2039− }
2040−
2041− /**
2042− * Runs the suite.
2043− *
2044− * @name run
2045− * @memberOf Benchmark.Suite
2046− * @param {Object} [options={}] Options object.
2047− * @returns {Object} The suite instance.
2048− * @example
2049− *
2050− * // basic usage
2051− * suite.run();
2052− *
2053− * // or with options
2054− * suite.run({ 'async': true, 'queued': true });
2055− */
2056− function runSuite(options) {
2057− var me = this;
2058−
2059− me.reset();
2060− me.running = true;
2061− options || (options = {});
2062−
2063− invoke(me, {
2064− 'name': 'run',
2065− 'args': options,
2066− 'queued': options.queued,
2067− 'onStart': function(event) {
2068− me.emit(event);
2069− },
2070− 'onCycle': function(event) {
2071− var bench = event.target;
2072− if (bench.error) {
2073− me.emit({ 'type': 'error', 'target': bench });
2074− }
2075− me.emit(event);
2076− event.aborted = me.aborted;
2077− },
2078− 'onComplete': function(event) {
2079− me.running = false;
2080− me.emit(event);
2081− }
2082− });
2083− return me;
2084− }
2085−
2086− /*--------------------------------------------------------------------------*/
2087−
2088− /**
2089− * Executes all registered listeners of the specified event type.
2090− *
2091− * @memberOf Benchmark, Benchmark.Suite
2092− * @param {String|Object} type The event type or object.
2093− * @returns {Mixed} Returns the return value of the last listener executed.
2094− */
2095− function emit(type) {
2096− var listeners,
2097− me = this,
2098− event = Event(type),
2099− events = me.events,
2100− args = (arguments[0] = event, arguments);
2101−
2102− event.currentTarget || (event.currentTarget = me);
2103− event.target || (event.target = me);
2104− delete event.result;
2105−
2106− if (events && (listeners = hasKey(events, event.type) && events[event.type])) {
2107− forEach(listeners.slice(), function(listener) {
2108− if ((event.result = listener.apply(me, args)) === false) {
2109− event.cancelled = true;
2110− }
2111− return !event.aborted;
2112− });
2113− }
2114− return event.result;
2115− }
2116−
2117− /**
2118− * Returns an array of event listeners for a given type that can be manipulated
2119− * to add or remove listeners.
2120− *
2121− * @memberOf Benchmark, Benchmark.Suite
2122− * @param {String} type The event type.
2123− * @returns {Array} The listeners array.
2124− */
2125− function listeners(type) {
2126− var me = this,
2127− events = me.events || (me.events = {});
2128−
2129− return hasKey(events, type) ? events[type] : (events[type] = []);
2130− }
2131−
2132− /**
2133− * Unregisters a listener for the specified event type(s),
2134− * or unregisters all listeners for the specified event type(s),
2135− * or unregisters all listeners for all event types.
2136− *
2137− * @memberOf Benchmark, Benchmark.Suite
2138− * @param {String} [type] The event type.
2139− * @param {Function} [listener] The function to unregister.
2140− * @returns {Object} The benchmark instance.
2141− * @example
2142− *
2143− * // unregister a listener for an event type
2144− * bench.off('cycle', listener);
2145− *
2146− * // unregister a listener for multiple event types
2147− * bench.off('start cycle', listener);
2148− *
2149− * // unregister all listeners for an event type
2150− * bench.off('cycle');
2151− *
2152− * // unregister all listeners for multiple event types
2153− * bench.off('start cycle complete');
2154− *
2155− * // unregister all listeners for all event types
2156− * bench.off();
2157− */
2158− function off(type, listener) {
2159− var me = this,
2160− events = me.events;
2161−
2162− events && each(type ? type.split(' ') : events, function(listeners, type) {
2163− var index;
2164− if (typeof listeners == 'string') {
2165− type = listeners;
2166− listeners = hasKey(events, type) && events[type];
2167− }
2168− if (listeners) {
2169− if (listener) {
2170− index = indexOf(listeners, listener);
2171− if (index > -1) {
2172− listeners.splice(index, 1);
2173− }
2174− } else {
2175− listeners.length = 0;
2176− }
2177− }
2178− });
2179− return me;
2180− }
2181−
2182− /**
2183− * Registers a listener for the specified event type(s).
2184− *
2185− * @memberOf Benchmark, Benchmark.Suite
2186− * @param {String} type The event type.
2187− * @param {Function} listener The function to register.
2188− * @returns {Object} The benchmark instance.
2189− * @example
2190− *
2191− * // register a listener for an event type
2192− * bench.on('cycle', listener);
2193− *
2194− * // register a listener for multiple event types
2195− * bench.on('start cycle', listener);
2196− */
2197− function on(type, listener) {
2198− var me = this,
2199− events = me.events || (me.events = {});
2200−
2201− forEach(type.split(' '), function(type) {
2202− (hasKey(events, type)
2203− ? events[type]
2204− : (events[type] = [])
2205− ).push(listener);
2206− });
2207− return me;
2208− }
2209−
2210− /*--------------------------------------------------------------------------*/
2211−
2212− /**
2213− * Aborts the benchmark without recording times.
2214− *
2215− * @memberOf Benchmark
2216− * @returns {Object} The benchmark instance.
2217− */
2218− function abort() {
2219− var event,
2220− me = this,
2221− resetting = calledBy.reset;
2222−
2223− if (me.running) {
2224− event = Event('abort');
2225− me.emit(event);
2226− if (!event.cancelled || resetting) {
2227− // avoid infinite recursion
2228− calledBy.abort = true;
2229− me.reset();
2230− delete calledBy.abort;
2231−
2232− if (support.timeout) {
2233− clearTimeout(me._timerId);
2234− delete me._timerId;
2235− }
2236− if (!resetting) {
2237− me.aborted = true;
2238− me.running = false;
2239− }
2240− }
2241− }
2242− return me;
2243− }
2244−
2245− /**
2246− * Creates a new benchmark using the same test and options.
2247− *
2248− * @memberOf Benchmark
2249− * @param {Object} options Options object to overwrite cloned options.
2250− * @returns {Object} The new benchmark instance.
2251− * @example
2252− *
2253− * var bizarro = bench.clone({
2254− * 'name': 'doppelganger'
2255− * });
2256− */
2257− function clone(options) {
2258− var me = this,
2259− result = new me.constructor(extend({}, me, options));
2260−
2261− // correct the `options` object
2262− result.options = extend({}, me.options, options);
2263−
2264− // copy own custom properties
2265− forOwn(me, function(value, key) {
2266− if (!hasKey(result, key)) {
2267− result[key] = deepClone(value);
2268− }
2269− });
2270− return result;
2271− }
2272−
2273− /**
2274− * Determines if a benchmark is faster than another.
2275− *
2276− * @memberOf Benchmark
2277− * @param {Object} other The benchmark to compare.
2278− * @returns {Number} Returns `-1` if slower, `1` if faster, and `0` if indeterminate.
2279− */
2280− function compare(other) {
2281− var critical,
2282− zStat,
2283− me = this,
2284− sample1 = me.stats.sample,
2285− sample2 = other.stats.sample,
2286− size1 = sample1.length,
2287− size2 = sample2.length,
2288− maxSize = max(size1, size2),
2289− minSize = min(size1, size2),
2290− u1 = getU(sample1, sample2),
2291− u2 = getU(sample2, sample1),
2292− u = min(u1, u2);
2293−
2294− function getScore(xA, sampleB) {
2295− return reduce(sampleB, function(total, xB) {
2296− return total + (xB > xA ? 0 : xB < xA ? 1 : 0.5);
2297− }, 0);
2298− }
2299−
2300− function getU(sampleA, sampleB) {
2301− return reduce(sampleA, function(total, xA) {
2302− return total + getScore(xA, sampleB);
2303− }, 0);
2304− }
2305−
2306− function getZ(u) {
2307− return (u - ((size1 * size2) / 2)) / sqrt((size1 * size2 * (size1 + size2 + 1)) / 12);
2308− }
2309−
2310− // exit early if comparing the same benchmark
2311− if (me == other) {
2312− return 0;
2313− }
2314− // reject the null hyphothesis the two samples come from the
2315− // same population (i.e. have the same median) if...
2316− if (size1 + size2 > 30) {
2317− // ...the z-stat is greater than 1.96 or less than -1.96
2318− // http://www.statisticslectures.com/topics/mannwhitneyu/
2319− zStat = getZ(u);
2320− return abs(zStat) > 1.96 ? (zStat > 0 ? -1 : 1) : 0;
2321− }
2322− // ...the U value is less than or equal the critical U value
2323− // http://www.geoib.com/mann-whitney-u-test.html
2324− critical = maxSize < 5 || minSize < 3 ? 0 : uTable[maxSize][minSize - 3];
2325− return u <= critical ? (u == u1 ? 1 : -1) : 0;
2326− }
2327−
2328− /**
2329− * Reset properties and abort if running.
2330− *
2331− * @memberOf Benchmark
2332− * @returns {Object} The benchmark instance.
2333− */
2334− function reset() {
2335− var data,
2336− event,
2337− me = this,
2338− index = 0,
2339− changes = { 'length': 0 },
2340− queue = { 'length': 0 };
2341−
2342− if (me.running && !calledBy.abort) {
2343− // no worries, `reset()` is called within `abort()`
2344− calledBy.reset = true;
2345− me.abort();
2346− delete calledBy.reset;
2347− }
2348− else {
2349− // a non-recursive solution to check if properties have changed
2350− // http://www.jslab.dk/articles/non.recursive.preorder.traversal.part4
2351− data = { 'destination': me, 'source': extend({}, me.constructor.prototype, me.options) };
2352− do {
2353− forOwn(data.source, function(value, key) {
2354− var changed,
2355− destination = data.destination,
2356− currValue = destination[key];
2357−
2358− if (value && typeof value == 'object') {
2359− if (isClassOf(value, 'Array')) {
2360− // check if an array value has changed to a non-array value
2361− if (!isClassOf(currValue, 'Array')) {
2362− changed = currValue = [];
2363− }
2364− // or has changed its length
2365− if (currValue.length != value.length) {
2366− changed = currValue = currValue.slice(0, value.length);
2367− currValue.length = value.length;
2368− }
2369− }
2370− // check if an object has changed to a non-object value
2371− else if (!currValue || typeof currValue != 'object') {
2372− changed = currValue = {};
2373− }
2374− // register a changed object
2375− if (changed) {
2376− changes[changes.length++] = { 'destination': destination, 'key': key, 'value': currValue };
2377− }
2378− queue[queue.length++] = { 'destination': currValue, 'source': value };
2379− }
2380− // register a changed primitive
2381− else if (value !== currValue && !(value == null || isClassOf(value, 'Function'))) {
2382− changes[changes.length++] = { 'destination': destination, 'key': key, 'value': value };
2383− }
2384− });
2385− }
2386− while ((data = queue[index++]));
2387−
2388− // if changed emit the `reset` event and if it isn't cancelled reset the benchmark
2389− if (changes.length && (me.emit(event = Event('reset')), !event.cancelled)) {
2390− forEach(changes, function(data) {
2391− data.destination[data.key] = data.value;
2392− });
2393− }
2394− }
2395− return me;
2396− }
2397−
2398− /**
2399− * Displays relevant benchmark information when coerced to a string.
2400− *
2401− * @name toString
2402− * @memberOf Benchmark
2403− * @returns {String} A string representation of the benchmark instance.
2404− */
2405− function toStringBench() {
2406− var me = this,
2407− error = me.error,
2408− hz = me.hz,
2409− id = me.id,
2410− stats = me.stats,
2411− size = stats.sample.length,
2412− pm = support.java ? '+/-' : '\xb1',
2413− result = me.name || (isNaN(id) ? id : '<Test #' + id + '>');
2414−
2415− if (error) {
2416− result += ': ' + join(error);
2417− } else {
2418− result += ' x ' + formatNumber(hz.toFixed(hz < 100 ? 2 : 0)) + ' ops/sec ' + pm +
2419− stats.rme.toFixed(2) + '% (' + size + ' run' + (size == 1 ? '' : 's') + ' sampled)';
2420− }
2421− return result;
2422− }
2423−
2424− /*--------------------------------------------------------------------------*/
2425−
2426− /**
2427− * Clocks the time taken to execute a test per cycle (secs).
2428− *
2429− * @private
2430− * @param {Object} bench The benchmark instance.
2431− * @returns {Number} The time taken.
2432− */
2433− function clock() {
2434− var applet,
2435− options = Benchmark.options,
2436− template = { 'begin': 's$=new n$', 'end': 'r$=(new n$-s$)/1e3', 'uid': uid },
2437− timers = [{ 'ns': timer.ns, 'res': max(0.0015, getRes('ms')), 'unit': 'ms' }];
2438−
2439− // lazy define for hi-res timers
2440− clock = function(clone) {
2441− var deferred;
2442− if (clone instanceof Deferred) {
2443− deferred = clone;
2444− clone = deferred.benchmark;
2445− }
2446−
2447− var bench = clone._original,
2448− fn = bench.fn,
2449− fnArg = deferred ? getFirstArgument(fn) || 'deferred' : '',
2450− stringable = isStringable(fn);
2451−
2452− var source = {
2453− 'setup': getSource(bench.setup, preprocess('m$.setup()')),
2454− 'fn': getSource(fn, preprocess('m$.fn(' + fnArg + ')')),
2455− 'fnArg': fnArg,
2456− 'teardown': getSource(bench.teardown, preprocess('m$.teardown()'))
2457− };
2458−
2459− var count = bench.count = clone.count,
2460− decompilable = support.decompilation || stringable,
2461− id = bench.id,
2462− isEmpty = !(source.fn || stringable),
2463− name = bench.name || (typeof id == 'number' ? '<Test #' + id + '>' : id),
2464− ns = timer.ns,
2465− result = 0;
2466−
2467− // init `minTime` if needed
2468− clone.minTime = bench.minTime || (bench.minTime = bench.options.minTime = options.minTime);
2469−
2470− // repair nanosecond timer
2471− // (some Chrome builds erase the `ns` variable after millions of executions)
2472− if (applet) {
2473− try {
2474− ns.nanoTime();
2475− } catch(e) {
2476− // use non-element to avoid issues with libs that augment them
2477− ns = timer.ns = new applet.Packages.nano;
2478− }
2479− }
2480−
2481− // Compile in setup/teardown functions and the test loop.
2482− // Create a new compiled test, instead of using the cached `bench.compiled`,
2483− // to avoid potential engine optimizations enabled over the life of the test.
2484− var compiled = bench.compiled = createFunction(preprocess('t$'), interpolate(
2485− preprocess(deferred
2486− ? 'var d$=this,#{fnArg}=d$,m$=d$.benchmark._original,f$=m$.fn,su$=m$.setup,td$=m$.teardown;' +
2487− // when `deferred.cycles` is `0` then...
2488− 'if(!d$.cycles){' +
2489− // set `deferred.fn`
2490− 'd$.fn=function(){var #{fnArg}=d$;if(typeof f$=="function"){try{#{fn}\n}catch(e$){f$(d$)}}else{#{fn}\n}};' +
2491− // set `deferred.teardown`
2492− 'd$.teardown=function(){d$.cycles=0;if(typeof td$=="function"){try{#{teardown}\n}catch(e$){td$()}}else{#{teardown}\n}};' +
2493− // execute the benchmark's `setup`
2494− 'if(typeof su$=="function"){try{#{setup}\n}catch(e$){su$()}}else{#{setup}\n};' +
2495− // start timer
2496− 't$.start(d$);' +
2497− // execute `deferred.fn` and return a dummy object
2498− '}d$.fn();return{}'
2499−
2500− : 'var r$,s$,m$=this,f$=m$.fn,i$=m$.count,n$=t$.ns;#{setup}\n#{begin};' +
2501− 'while(i$--){#{fn}\n}#{end};#{teardown}\nreturn{elapsed:r$,uid:"#{uid}"}'),
2502− source
2503− ));
2504−
2505− try {
2506− if (isEmpty) {
2507− // Firefox may remove dead code from Function#toString results
2508− // http://bugzil.la/536085
2509− throw new Error('The test "' + name + '" is empty. This may be the result of dead code removal.');
2510− }
2511− else if (!deferred) {
2512− // pretest to determine if compiled code is exits early, usually by a
2513− // rogue `return` statement, by checking for a return object with the uid
2514− bench.count = 1;
2515− compiled = (compiled.call(bench, timer) || {}).uid == uid && compiled;
2516− bench.count = count;
2517− }
2518− } catch(e) {
2519− compiled = null;
2520− clone.error = e || new Error(String(e));
2521− bench.count = count;
2522− }
2523− // fallback when a test exits early or errors during pretest
2524− if (decompilable && !compiled && !deferred && !isEmpty) {
2525− compiled = createFunction(preprocess('t$'), interpolate(
2526− preprocess(
2527− (clone.error && !stringable
2528− ? 'var r$,s$,m$=this,f$=m$.fn,i$=m$.count'
2529− : 'function f$(){#{fn}\n}var r$,s$,m$=this,i$=m$.count'
2530− ) +
2531− ',n$=t$.ns;#{setup}\n#{begin};m$.f$=f$;while(i$--){m$.f$()}#{end};' +
2532− 'delete m$.f$;#{teardown}\nreturn{elapsed:r$}'
2533− ),
2534− source
2535− ));
2536−
2537− try {
2538− // pretest one more time to check for errors
2539− bench.count = 1;
2540− compiled.call(bench, timer);
2541− bench.compiled = compiled;
2542− bench.count = count;
2543− delete clone.error;
2544− }
2545− catch(e) {
2546− bench.count = count;
2547− if (clone.error) {
2548− compiled = null;
2549− } else {
2550− bench.compiled = compiled;
2551− clone.error = e || new Error(String(e));
2552− }
2553− }
2554− }
2555− // assign `compiled` to `clone` before calling in case a deferred benchmark
2556− // immediately calls `deferred.resolve()`
2557− clone.compiled = compiled;
2558− // if no errors run the full test loop
2559− if (!clone.error) {
2560− result = compiled.call(deferred || bench, timer).elapsed;
2561− }
2562− return result;
2563− };
2564−
2565− /*------------------------------------------------------------------------*/
2566−
2567− /**
2568− * Gets the current timer's minimum resolution (secs).
2569− */
2570− function getRes(unit) {
2571− var measured,
2572− begin,
2573− count = 30,
2574− divisor = 1e3,
2575− ns = timer.ns,
2576− sample = [];
2577−
2578− // get average smallest measurable time
2579− while (count--) {
2580− if (unit == 'us') {
2581− divisor = 1e6;
2582− if (ns.stop) {
2583− ns.start();
2584− while (!(measured = ns.microseconds())) { }
2585− } else if (ns[perfName]) {
2586− divisor = 1e3;
2587− measured = Function('n', 'var r,s=n.' + perfName + '();while(!(r=n.' + perfName + '()-s)){};return r')(ns);
2588− } else {
2589− begin = ns();
2590− while (!(measured = ns() - begin)) { }
2591− }
2592− }
2593− else if (unit == 'ns') {
2594− divisor = 1e9;
2595− if (ns.nanoTime) {
2596− begin = ns.nanoTime();
2597− while (!(measured = ns.nanoTime() - begin)) { }
2598− } else {
2599− begin = (begin = ns())[0] + (begin[1] / divisor);
2600− while (!(measured = ((measured = ns())[0] + (measured[1] / divisor)) - begin)) { }
2601− divisor = 1;
2602− }
2603− }
2604− else {
2605− begin = new ns;
2606− while (!(measured = new ns - begin)) { }
2607− }
2608− // check for broken timers (nanoTime may have issues)
2609− // http://alivebutsleepy.srnet.cz/unreliable-system-nanotime/
2610− if (measured > 0) {
2611− sample.push(measured);
2612− } else {
2613− sample.push(Infinity);
2614− break;
2615− }
2616− }
2617− // convert to seconds
2618− return getMean(sample) / divisor;
2619− }
2620−
2621− /**
2622− * Replaces all occurrences of `$` with a unique number and
2623− * template tokens with content.
2624− */
2625− function preprocess(code) {
2626− return interpolate(code, template).replace(/\$/g, /\d+/.exec(uid));
2627− }
2628−
2629− /*------------------------------------------------------------------------*/
2630−
2631− // detect nanosecond support from a Java applet
2632− each(doc && doc.applets || [], function(element) {
2633− return !(timer.ns = applet = 'nanoTime' in element && element);
2634− });
2635−
2636− // check type in case Safari returns an object instead of a number
2637− try {
2638− if (typeof timer.ns.nanoTime() == 'number') {
2639− timers.push({ 'ns': timer.ns, 'res': getRes('ns'), 'unit': 'ns' });
2640− }
2641− } catch(e) { }
2642−
2643− // detect Chrome's microsecond timer:
2644− // enable benchmarking via the --enable-benchmarking command
2645− // line switch in at least Chrome 7 to use chrome.Interval
2646− try {
2647− if ((timer.ns = new (window.chrome || window.chromium).Interval)) {
2648− timers.push({ 'ns': timer.ns, 'res': getRes('us'), 'unit': 'us' });
2649− }
2650− } catch(e) { }
2651−
2652− // detect `performance.now` microsecond resolution timer
2653− if ((timer.ns = perfName && perfObject)) {
2654− timers.push({ 'ns': timer.ns, 'res': getRes('us'), 'unit': 'us' });
2655− }
2656−
2657− // detect Node's nanosecond resolution timer available in Node >= 0.8
2658− if (processObject && typeof (timer.ns = processObject.hrtime) == 'function') {
2659− timers.push({ 'ns': timer.ns, 'res': getRes('ns'), 'unit': 'ns' });
2660− }
2661−
2662− // detect Wade Simmons' Node microtime module
2663− if (microtimeObject && typeof (timer.ns = microtimeObject.now) == 'function') {
2664− timers.push({ 'ns': timer.ns, 'res': getRes('us'), 'unit': 'us' });
2665− }
2666−
2667− // pick timer with highest resolution
2668− timer = reduce(timers, function(timer, other) {
2669− return other.res < timer.res ? other : timer;
2670− });
2671−
2672− // remove unused applet
2673− if (timer.unit != 'ns' && applet) {
2674− applet = destroyElement(applet);
2675− }
2676− // error if there are no working timers
2677− if (timer.res == Infinity) {
2678− throw new Error('Benchmark.js was unable to find a working timer.');
2679− }
2680− // use API of chosen timer
2681− if (timer.unit == 'ns') {
2682− if (timer.ns.nanoTime) {
2683− extend(template, {
2684− 'begin': 's$=n$.nanoTime()',
2685− 'end': 'r$=(n$.nanoTime()-s$)/1e9'
2686− });
2687− } else {
2688− extend(template, {
2689− 'begin': 's$=n$()',
2690− 'end': 'r$=n$(s$);r$=r$[0]+(r$[1]/1e9)'
2691− });
2692− }
2693− }
2694− else if (timer.unit == 'us') {
2695− if (timer.ns.stop) {
2696− extend(template, {
2697− 'begin': 's$=n$.start()',
2698− 'end': 'r$=n$.microseconds()/1e6'
2699− });
2700− } else if (perfName) {
2701− extend(template, {
2702− 'begin': 's$=n$.' + perfName + '()',
2703− 'end': 'r$=(n$.' + perfName + '()-s$)/1e3'
2704− });
2705− } else {
2706− extend(template, {
2707− 'begin': 's$=n$()',
2708− 'end': 'r$=(n$()-s$)/1e6'
2709− });
2710− }
2711− }
2712−
2713− // define `timer` methods
2714− timer.start = createFunction(preprocess('o$'),
2715− preprocess('var n$=this.ns,#{begin};o$.elapsed=0;o$.timeStamp=s$'));
2716−
2717− timer.stop = createFunction(preprocess('o$'),
2718− preprocess('var n$=this.ns,s$=o$.timeStamp,#{end};o$.elapsed=r$'));
2719−
2720− // resolve time span required to achieve a percent uncertainty of at most 1%
2721− // http://spiff.rit.edu/classes/phys273/uncert/uncert.html
2722− options.minTime || (options.minTime = max(timer.res / 2 / 0.01, 0.05));
2723− return clock.apply(null, arguments);
2724− }
2725−
2726− /*--------------------------------------------------------------------------*/
2727−
2728− /**
2729− * Computes stats on benchmark results.
2730− *
2731− * @private
2732− * @param {Object} bench The benchmark instance.
2733− * @param {Object} options The options object.
2734− */
2735− function compute(bench, options) {
2736− options || (options = {});
2737−
2738− var async = options.async,
2739− elapsed = 0,
2740− initCount = bench.initCount,
2741− minSamples = bench.minSamples,
2742− queue = [],
2743− sample = bench.stats.sample;
2744−
2745− /**
2746− * Adds a clone to the queue.
2747− */
2748− function enqueue() {
2749− queue.push(bench.clone({
2750− '_original': bench,
2751− 'events': {
2752− 'abort': [update],
2753− 'cycle': [update],
2754− 'error': [update],
2755− 'start': [update]
2756− }
2757− }));
2758− }
2759−
2760− /**
2761− * Updates the clone/original benchmarks to keep their data in sync.
2762− */
2763− function update(event) {
2764− var clone = this,
2765− type = event.type;
2766−
2767− if (bench.running) {
2768− if (type == 'start') {
2769− // Note: `clone.minTime` prop is inited in `clock()`
2770− clone.count = bench.initCount;
2771− }
2772− else {
2773− if (type == 'error') {
2774− bench.error = clone.error;
2775− }
2776− if (type == 'abort') {
2777− bench.abort();
2778− bench.emit('cycle');
2779− } else {
2780− event.currentTarget = event.target = bench;
2781− bench.emit(event);
2782− }
2783− }
2784− } else if (bench.aborted) {
2785− // clear abort listeners to avoid triggering bench's abort/cycle again
2786− clone.events.abort.length = 0;
2787− clone.abort();
2788− }
2789− }
2790−
2791− /**
2792− * Determines if more clones should be queued or if cycling should stop.
2793− */
2794− function evaluate(event) {
2795− var critical,
2796− df,
2797− mean,
2798− moe,
2799− rme,
2800− sd,
2801− sem,
2802− variance,
2803− clone = event.target,
2804− done = bench.aborted,
2805− now = +new Date,
2806− size = sample.push(clone.times.period),
2807− maxedOut = size >= minSamples && (elapsed += now - clone.times.timeStamp) / 1e3 > bench.maxTime,
2808− times = bench.times,
2809− varOf = function(sum, x) { return sum + pow(x - mean, 2); };
2810−
2811− // exit early for aborted or unclockable tests
2812− if (done || clone.hz == Infinity) {
2813− maxedOut = !(size = sample.length = queue.length = 0);
2814− }
2815−
2816− if (!done) {
2817− // sample mean (estimate of the population mean)
2818− mean = getMean(sample);
2819− // sample variance (estimate of the population variance)
2820− variance = reduce(sample, varOf, 0) / (size - 1) || 0;
2821− // sample standard deviation (estimate of the population standard deviation)
2822− sd = sqrt(variance);
2823− // standard error of the mean (a.k.a. the standard deviation of the sampling distribution of the sample mean)
2824− sem = sd / sqrt(size);
2825− // degrees of freedom
2826− df = size - 1;
2827− // critical value
2828− critical = tTable[Math.round(df) || 1] || tTable.infinity;
2829− // margin of error
2830− moe = sem * critical;
2831− // relative margin of error
2832− rme = (moe / mean) * 100 || 0;
2833−
2834− extend(bench.stats, {
2835− 'deviation': sd,
2836− 'mean': mean,
2837− 'moe': moe,
2838− 'rme': rme,
2839− 'sem': sem,
2840− 'variance': variance
2841− });
2842−
2843− // Abort the cycle loop when the minimum sample size has been collected
2844− // and the elapsed time exceeds the maximum time allowed per benchmark.
2845− // We don't count cycle delays toward the max time because delays may be
2846− // increased by browsers that clamp timeouts for inactive tabs.
2847− // https://developer.mozilla.org/en/window.setTimeout#Inactive_tabs
2848− if (maxedOut) {
2849− // reset the `initCount` in case the benchmark is rerun
2850− bench.initCount = initCount;
2851− bench.running = false;
2852− done = true;
2853− times.elapsed = (now - times.timeStamp) / 1e3;
2854− }
2855− if (bench.hz != Infinity) {
2856− bench.hz = 1 / mean;
2857− times.cycle = mean * bench.count;
2858− times.period = mean;
2859− }
2860− }
2861− // if time permits, increase sample size to reduce the margin of error
2862− if (queue.length < 2 && !maxedOut) {
2863− enqueue();
2864− }
2865− // abort the invoke cycle when done
2866− event.aborted = done;
2867− }
2868−
2869− // init queue and begin
2870− enqueue();
2871− invoke(queue, {
2872− 'name': 'run',
2873− 'args': { 'async': async },
2874− 'queued': true,
2875− 'onCycle': evaluate,
2876− 'onComplete': function() { bench.emit('complete'); }
2877− });
2878− }
2879−
2880− /*--------------------------------------------------------------------------*/
2881−
2882− /**
2883− * Cycles a benchmark until a run `count` can be established.
2884− *
2885− * @private
2886− * @param {Object} clone The cloned benchmark instance.
2887− * @param {Object} options The options object.
2888− */
2889− function cycle(clone, options) {
2890− options || (options = {});
2891−
2892− var deferred;
2893− if (clone instanceof Deferred) {
2894− deferred = clone;
2895− clone = clone.benchmark;
2896− }
2897−
2898− var clocked,
2899− cycles,
2900− divisor,
2901− event,
2902− minTime,
2903− period,
2904− async = options.async,
2905− bench = clone._original,
2906− count = clone.count,
2907− times = clone.times;
2908−
2909− // continue, if not aborted between cycles
2910− if (clone.running) {
2911− // `minTime` is set to `Benchmark.options.minTime` in `clock()`
2912− cycles = ++clone.cycles;
2913− clocked = deferred ? deferred.elapsed : clock(clone);
2914− minTime = clone.minTime;
2915−
2916− if (cycles > bench.cycles) {
2917− bench.cycles = cycles;
2918− }
2919− if (clone.error) {
2920− event = Event('error');
2921− event.message = clone.error;
2922− clone.emit(event);
2923− if (!event.cancelled) {
2924− clone.abort();
2925− }
2926− }
2927− }
2928−
2929− // continue, if not errored
2930− if (clone.running) {
2931− // time taken to complete last test cycle
2932− bench.times.cycle = times.cycle = clocked;
2933− // seconds per operation
2934− period = bench.times.period = times.period = clocked / count;
2935− // ops per second
2936− bench.hz = clone.hz = 1 / period;
2937− // avoid working our way up to this next time
2938− bench.initCount = clone.initCount = count;
2939− // do we need to do another cycle?
2940− clone.running = clocked < minTime;
2941−
2942− if (clone.running) {
2943− // tests may clock at `0` when `initCount` is a small number,
2944− // to avoid that we set its count to something a bit higher
2945− if (!clocked && (divisor = divisors[clone.cycles]) != null) {
2946− count = floor(4e6 / divisor);
2947− }
2948− // calculate how many more iterations it will take to achive the `minTime`
2949− if (count <= clone.count) {
2950− count += Math.ceil((minTime - clocked) / period);
2951− }
2952− clone.running = count != Infinity;
2953− }
2954− }
2955− // should we exit early?
2956− event = Event('cycle');
2957− clone.emit(event);
2958− if (event.aborted) {
2959− clone.abort();
2960− }
2961− // figure out what to do next
2962− if (clone.running) {
2963− // start a new cycle
2964− clone.count = count;
2965− if (deferred) {
2966− clone.compiled.call(deferred, timer);
2967− } else if (async) {
2968− delay(clone, function() { cycle(clone, options); });
2969− } else {
2970− cycle(clone);
2971− }
2972− }
2973− else {
2974− // fix TraceMonkey bug associated with clock fallbacks
2975− // http://bugzil.la/509069
2976− if (support.browser) {
2977− runScript(uid + '=1;delete ' + uid);
2978− }
2979− // done
2980− clone.emit('complete');
2981− }
2982− }
2983−
2984− /*--------------------------------------------------------------------------*/
2985−
2986− /**
2987− * Runs the benchmark.
2988− *
2989− * @memberOf Benchmark
2990− * @param {Object} [options={}] Options object.
2991− * @returns {Object} The benchmark instance.
2992− * @example
2993− *
2994− * // basic usage
2995− * bench.run();
2996− *
2997− * // or with options
2998− * bench.run({ 'async': true });
2999− */
3000− function run(options) {
3001− var me = this,
3002− event = Event('start');
3003−
3004− // set `running` to `false` so `reset()` won't call `abort()`
3005− me.running = false;
3006− me.reset();
3007− me.running = true;
3008−
3009− me.count = me.initCount;
3010− me.times.timeStamp = +new Date;
3011− me.emit(event);
3012−
3013− if (!event.cancelled) {
3014− options = { 'async': ((options = options && options.async) == null ? me.async : options) && support.timeout };
3015−
3016− // for clones created within `compute()`
3017− if (me._original) {
3018− if (me.defer) {
3019− Deferred(me);
3020− } else {
3021− cycle(me, options);
3022− }
3023− }
3024− // for original benchmarks
3025− else {
3026− compute(me, options);
3027− }
3028− }
3029− return me;
3030− }
3031−
3032− /*--------------------------------------------------------------------------*/
3033−
3034− // Firefox 1 erroneously defines variable and argument names of functions on
3035− // the function itself as non-configurable properties with `undefined` values.
3036− // The bugginess continues as the `Benchmark` constructor has an argument
3037− // named `options` and Firefox 1 will not assign a value to `Benchmark.options`,
3038− // making it non-writable in the process, unless it is the first property
3039− // assigned by for-in loop of `extend()`.
3040− extend(Benchmark, {
3041−
3042− /**
3043− * The default options copied by benchmark instances.
3044− *
3045− * @static
3046− * @memberOf Benchmark
3047− * @type Object
3048− */
3049− 'options': {
3050−
3051− /**
3052− * A flag to indicate that benchmark cycles will execute asynchronously
3053− * by default.
3054− *
3055− * @memberOf Benchmark.options
3056− * @type Boolean
3057− */
3058− 'async': false,
3059−
3060− /**
3061− * A flag to indicate that the benchmark clock is deferred.
3062− *
3063− * @memberOf Benchmark.options
3064− * @type Boolean
3065− */
3066− 'defer': false,
3067−
3068− /**
3069− * The delay between test cycles (secs).
3070− * @memberOf Benchmark.options
3071− * @type Number
3072− */
3073− 'delay': 0.005,
3074−
3075− /**
3076− * Displayed by Benchmark#toString when a `name` is not available
3077− * (auto-generated if absent).
3078− *
3079− * @memberOf Benchmark.options
3080− * @type String
3081− */
3082− 'id': undefined,
3083−
3084− /**
3085− * The default number of times to execute a test on a benchmark's first cycle.
3086− *
3087− * @memberOf Benchmark.options
3088− * @type Number
3089− */
3090− 'initCount': 1,
3091−
3092− /**
3093− * The maximum time a benchmark is allowed to run before finishing (secs).
3094− *
3095− * Note: Cycle delays aren't counted toward the maximum time.
3096− *
3097− * @memberOf Benchmark.options
3098− * @type Number
3099− */
3100− 'maxTime': 5,
3101−
3102− /**
3103− * The minimum sample size required to perform statistical analysis.
3104− *
3105− * @memberOf Benchmark.options
3106− * @type Number
3107− */
3108− 'minSamples': 5,
3109−
3110− /**
3111− * The time needed to reduce the percent uncertainty of measurement to 1% (secs).
3112− *
3113− * @memberOf Benchmark.options
3114− * @type Number
3115− */
3116− 'minTime': 0,
3117−
3118− /**
3119− * The name of the benchmark.
3120− *
3121− * @memberOf Benchmark.options
3122− * @type String
3123− */
3124− 'name': undefined,
3125−
3126− /**
3127− * An event listener called when the benchmark is aborted.
3128− *
3129− * @memberOf Benchmark.options
3130− * @type Function
3131− */
3132− 'onAbort': undefined,
3133−
3134− /**
3135− * An event listener called when the benchmark completes running.
3136− *
3137− * @memberOf Benchmark.options
3138− * @type Function
3139− */
3140− 'onComplete': undefined,
3141−
3142− /**
3143− * An event listener called after each run cycle.
3144− *
3145− * @memberOf Benchmark.options
3146− * @type Function
3147− */
3148− 'onCycle': undefined,
3149−
3150− /**
3151− * An event listener called when a test errors.
3152− *
3153− * @memberOf Benchmark.options
3154− * @type Function
3155− */
3156− 'onError': undefined,
3157−
3158− /**
3159− * An event listener called when the benchmark is reset.
3160− *
3161− * @memberOf Benchmark.options
3162− * @type Function
3163− */
3164− 'onReset': undefined,
3165−
3166− /**
3167− * An event listener called when the benchmark starts running.
3168− *
3169− * @memberOf Benchmark.options
3170− * @type Function
3171− */
3172− 'onStart': undefined
3173− },
3174−
3175− /**
3176− * Platform object with properties describing things like browser name,
3177− * version, and operating system.
3178− *
3179− * @static
3180− * @memberOf Benchmark
3181− * @type Object
3182− */
3183− 'platform': req('platform') || window.platform || {
3184−
3185− /**
3186− * The platform description.
3187− *
3188− * @memberOf Benchmark.platform
3189− * @type String
3190− */
3191− 'description': window.navigator && navigator.userAgent || null,
3192−
3193− /**
3194− * The name of the browser layout engine.
3195− *
3196− * @memberOf Benchmark.platform
3197− * @type String|Null
3198− */
3199− 'layout': null,
3200−
3201− /**
3202− * The name of the product hosting the browser.
3203− *
3204− * @memberOf Benchmark.platform
3205− * @type String|Null
3206− */
3207− 'product': null,
3208−
3209− /**
3210− * The name of the browser/environment.
3211− *
3212− * @memberOf Benchmark.platform
3213− * @type String|Null
3214− */
3215− 'name': null,
3216−
3217− /**
3218− * The name of the product's manufacturer.
3219− *
3220− * @memberOf Benchmark.platform
3221− * @type String|Null
3222− */
3223− 'manufacturer': null,
3224−
3225− /**
3226− * The name of the operating system.
3227− *
3228− * @memberOf Benchmark.platform
3229− * @type String|Null
3230− */
3231− 'os': null,
3232−
3233− /**
3234− * The alpha/beta release indicator.
3235− *
3236− * @memberOf Benchmark.platform
3237− * @type String|Null
3238− */
3239− 'prerelease': null,
3240−
3241− /**
3242− * The browser/environment version.
3243− *
3244− * @memberOf Benchmark.platform
3245− * @type String|Null
3246− */
3247− 'version': null,
3248−
3249− /**
3250− * Return platform description when the platform object is coerced to a string.
3251− *
3252− * @memberOf Benchmark.platform
3253− * @type Function
3254− * @returns {String} The platform description.
3255− */
3256− 'toString': function() {
3257− return this.description || '';
3258− }
3259− },
3260−
3261− /**
3262− * The semantic version number.
3263− *
3264− * @static
3265− * @memberOf Benchmark
3266− * @type String
3267− */
3268− 'version': '1.0.0',
3269−
3270− // an object of environment/feature detection flags
3271− 'support': support,
3272−
3273− // clone objects
3274− 'deepClone': deepClone,
3275−
3276− // iteration utility
3277− 'each': each,
3278−
3279− // augment objects
3280− 'extend': extend,
3281−
3282− // generic Array#filter
3283− 'filter': filter,
3284−
3285− // generic Array#forEach
3286− 'forEach': forEach,
3287−
3288− // generic own property iteration utility
3289− 'forOwn': forOwn,
3290−
3291− // converts a number to a comma-separated string
3292− 'formatNumber': formatNumber,
3293−
3294− // generic Object#hasOwnProperty
3295− // (trigger hasKey's lazy define before assigning it to Benchmark)
3296− 'hasKey': (hasKey(Benchmark, ''), hasKey),
3297−
3298− // generic Array#indexOf
3299− 'indexOf': indexOf,
3300−
3301− // template utility
3302− 'interpolate': interpolate,
3303−
3304− // invokes a method on each item in an array
3305− 'invoke': invoke,
3306−
3307− // generic Array#join for arrays and objects
3308− 'join': join,
3309−
3310− // generic Array#map
3311− 'map': map,
3312−
3313− // retrieves a property value from each item in an array
3314− 'pluck': pluck,
3315−
3316− // generic Array#reduce
3317− 'reduce': reduce
3318− });
3319−
3320− /*--------------------------------------------------------------------------*/
3321−
3322− extend(Benchmark.prototype, {
3323−
3324− /**
3325− * The number of times a test was executed.
3326− *
3327− * @memberOf Benchmark
3328− * @type Number
3329− */
3330− 'count': 0,
3331−
3332− /**
3333− * The number of cycles performed while benchmarking.
3334− *
3335− * @memberOf Benchmark
3336− * @type Number
3337− */
3338− 'cycles': 0,
3339−
3340− /**
3341− * The number of executions per second.
3342− *
3343− * @memberOf Benchmark
3344− * @type Number
3345− */
3346− 'hz': 0,
3347−
3348− /**
3349− * The compiled test function.
3350− *
3351− * @memberOf Benchmark
3352− * @type Function|String
3353− */
3354− 'compiled': undefined,
3355−
3356− /**
3357− * The error object if the test failed.
3358− *
3359− * @memberOf Benchmark
3360− * @type Object
3361− */
3362− 'error': undefined,
3363−
3364− /**
3365− * The test to benchmark.
3366− *
3367− * @memberOf Benchmark
3368− * @type Function|String
3369− */
3370− 'fn': undefined,
3371−
3372− /**
3373− * A flag to indicate if the benchmark is aborted.
3374− *
3375− * @memberOf Benchmark
3376− * @type Boolean
3377− */
3378− 'aborted': false,
3379−
3380− /**
3381− * A flag to indicate if the benchmark is running.
3382− *
3383− * @memberOf Benchmark
3384− * @type Boolean
3385− */
3386− 'running': false,
3387−
3388− /**
3389− * Compiled into the test and executed immediately **before** the test loop.
3390− *
3391− * @memberOf Benchmark
3392− * @type Function|String
3393− * @example
3394− *
3395− * // basic usage
3396− * var bench = Benchmark({
3397− * 'setup': function() {
3398− * var c = this.count,
3399− * element = document.getElementById('container');
3400− * while (c--) {
3401− * element.appendChild(document.createElement('div'));
3402− * }
3403− * },
3404− * 'fn': function() {
3405− * element.removeChild(element.lastChild);
3406− * }
3407− * });
3408− *
3409− * // compiles to something like:
3410− * var c = this.count,
3411− * element = document.getElementById('container');
3412− * while (c--) {
3413− * element.appendChild(document.createElement('div'));
3414− * }
3415− * var start = new Date;
3416− * while (count--) {
3417− * element.removeChild(element.lastChild);
3418− * }
3419− * var end = new Date - start;
3420− *
3421− * // or using strings
3422− * var bench = Benchmark({
3423− * 'setup': '\
3424− * var a = 0;\n\
3425− * (function() {\n\
3426− * (function() {\n\
3427− * (function() {',
3428− * 'fn': 'a += 1;',
3429− * 'teardown': '\
3430− * }())\n\
3431− * }())\n\
3432− * }())'
3433− * });
3434− *
3435− * // compiles to something like:
3436− * var a = 0;
3437− * (function() {
3438− * (function() {
3439− * (function() {
3440− * var start = new Date;
3441− * while (count--) {
3442− * a += 1;
3443− * }
3444− * var end = new Date - start;
3445− * }())
3446− * }())
3447− * }())
3448− */
3449− 'setup': noop,
3450−
3451− /**
3452− * Compiled into the test and executed immediately **after** the test loop.
3453− *
3454− * @memberOf Benchmark
3455− * @type Function|String
3456− */
3457− 'teardown': noop,
3458−
3459− /**
3460− * An object of stats including mean, margin or error, and standard deviation.
3461− *
3462− * @memberOf Benchmark
3463− * @type Object
3464− */
3465− 'stats': {
3466−
3467− /**
3468− * The margin of error.
3469− *
3470− * @memberOf Benchmark#stats
3471− * @type Number
3472− */
3473− 'moe': 0,
3474−
3475− /**
3476− * The relative margin of error (expressed as a percentage of the mean).
3477− *
3478− * @memberOf Benchmark#stats
3479− * @type Number
3480− */
3481− 'rme': 0,
3482−
3483− /**
3484− * The standard error of the mean.
3485− *
3486− * @memberOf Benchmark#stats
3487− * @type Number
3488− */
3489− 'sem': 0,
3490−
3491− /**
3492− * The sample standard deviation.
3493− *
3494− * @memberOf Benchmark#stats
3495− * @type Number
3496− */
3497− 'deviation': 0,
3498−
3499− /**
3500− * The sample arithmetic mean.
3501− *
3502− * @memberOf Benchmark#stats
3503− * @type Number
3504− */
3505− 'mean': 0,
3506−
3507− /**
3508− * The array of sampled periods.
3509− *
3510− * @memberOf Benchmark#stats
3511− * @type Array
3512− */
3513− 'sample': [],
3514−
3515− /**
3516− * The sample variance.
3517− *
3518− * @memberOf Benchmark#stats
3519− * @type Number
3520− */
3521− 'variance': 0
3522− },
3523−
3524− /**
3525− * An object of timing data including cycle, elapsed, period, start, and stop.
3526− *
3527− * @memberOf Benchmark
3528− * @type Object
3529− */
3530− 'times': {
3531−
3532− /**
3533− * The time taken to complete the last cycle (secs).
3534− *
3535− * @memberOf Benchmark#times
3536− * @type Number
3537− */
3538− 'cycle': 0,
3539−
3540− /**
3541− * The time taken to complete the benchmark (secs).
3542− *
3543− * @memberOf Benchmark#times
3544− * @type Number
3545− */
3546− 'elapsed': 0,
3547−
3548− /**
3549− * The time taken to execute the test once (secs).
3550− *
3551− * @memberOf Benchmark#times
3552− * @type Number
3553− */
3554− 'period': 0,
3555−
3556− /**
3557− * A timestamp of when the benchmark started (ms).
3558− *
3559− * @memberOf Benchmark#times
3560− * @type Number
3561− */
3562− 'timeStamp': 0
3563− },
3564−
3565− // aborts benchmark (does not record times)
3566− 'abort': abort,
3567−
3568− // creates a new benchmark using the same test and options
3569− 'clone': clone,
3570−
3571− // compares benchmark's hertz with another
3572− 'compare': compare,
3573−
3574− // executes listeners
3575− 'emit': emit,
3576−
3577− // get listeners
3578− 'listeners': listeners,
3579−
3580− // unregister listeners
3581− 'off': off,
3582−
3583− // register listeners
3584− 'on': on,
3585−
3586− // reset benchmark properties
3587− 'reset': reset,
3588−
3589− // runs the benchmark
3590− 'run': run,
3591−
3592− // pretty print benchmark info
3593− 'toString': toStringBench
3594− });
3595−
3596− /*--------------------------------------------------------------------------*/
3597−
3598− extend(Deferred.prototype, {
3599−
3600− /**
3601− * The deferred benchmark instance.
3602− *
3603− * @memberOf Benchmark.Deferred
3604− * @type Object
3605− */
3606− 'benchmark': null,
3607−
3608− /**
3609− * The number of deferred cycles performed while benchmarking.
3610− *
3611− * @memberOf Benchmark.Deferred
3612− * @type Number
3613− */
3614− 'cycles': 0,
3615−
3616− /**
3617− * The time taken to complete the deferred benchmark (secs).
3618− *
3619− * @memberOf Benchmark.Deferred
3620− * @type Number
3621− */
3622− 'elapsed': 0,
3623−
3624− /**
3625− * A timestamp of when the deferred benchmark started (ms).
3626− *
3627− * @memberOf Benchmark.Deferred
3628− * @type Number
3629− */
3630− 'timeStamp': 0,
3631−
3632− // cycles/completes the deferred benchmark
3633− 'resolve': resolve
3634− });
3635−
3636− /*--------------------------------------------------------------------------*/
3637−
3638− extend(Event.prototype, {
3639−
3640− /**
3641− * A flag to indicate if the emitters listener iteration is aborted.
3642− *
3643− * @memberOf Benchmark.Event
3644− * @type Boolean
3645− */
3646− 'aborted': false,
3647−
3648− /**
3649− * A flag to indicate if the default action is cancelled.
3650− *
3651− * @memberOf Benchmark.Event
3652− * @type Boolean
3653− */
3654− 'cancelled': false,
3655−
3656− /**
3657− * The object whose listeners are currently being processed.
3658− *
3659− * @memberOf Benchmark.Event
3660− * @type Object
3661− */
3662− 'currentTarget': undefined,
3663−
3664− /**
3665− * The return value of the last executed listener.
3666− *
3667− * @memberOf Benchmark.Event
3668− * @type Mixed
3669− */
3670− 'result': undefined,
3671−
3672− /**
3673− * The object to which the event was originally emitted.
3674− *
3675− * @memberOf Benchmark.Event
3676− * @type Object
3677− */
3678− 'target': undefined,
3679−
3680− /**
3681− * A timestamp of when the event was created (ms).
3682− *
3683− * @memberOf Benchmark.Event
3684− * @type Number
3685− */
3686− 'timeStamp': 0,
3687−
3688− /**
3689− * The event type.
3690− *
3691− * @memberOf Benchmark.Event
3692− * @type String
3693− */
3694− 'type': ''
3695− });
3696−
3697− /*--------------------------------------------------------------------------*/
3698−
3699− /**
3700− * The default options copied by suite instances.
3701− *
3702− * @static
3703− * @memberOf Benchmark.Suite
3704− * @type Object
3705− */
3706− Suite.options = {
3707−
3708− /**
3709− * The name of the suite.
3710− *
3711− * @memberOf Benchmark.Suite.options
3712− * @type String
3713− */
3714− 'name': undefined
3715− };
3716−
3717− /*--------------------------------------------------------------------------*/
3718−
3719− extend(Suite.prototype, {
3720−
3721− /**
3722− * The number of benchmarks in the suite.
3723− *
3724− * @memberOf Benchmark.Suite
3725− * @type Number
3726− */
3727− 'length': 0,
3728−
3729− /**
3730− * A flag to indicate if the suite is aborted.
3731− *
3732− * @memberOf Benchmark.Suite
3733− * @type Boolean
3734− */
3735− 'aborted': false,
3736−
3737− /**
3738− * A flag to indicate if the suite is running.
3739− *
3740− * @memberOf Benchmark.Suite
3741− * @type Boolean
3742− */
3743− 'running': false,
3744−
3745− /**
3746− * An `Array#forEach` like method.
3747− * Callbacks may terminate the loop by explicitly returning `false`.
3748− *
3749− * @memberOf Benchmark.Suite
3750− * @param {Function} callback The function called per iteration.
3751− * @returns {Object} The suite iterated over.
3752− */
3753− 'forEach': methodize(forEach),
3754−
3755− /**
3756− * An `Array#indexOf` like method.
3757− *
3758− * @memberOf Benchmark.Suite
3759− * @param {Mixed} value The value to search for.
3760− * @returns {Number} The index of the matched value or `-1`.
3761− */
3762− 'indexOf': methodize(indexOf),
3763−
3764− /**
3765− * Invokes a method on all benchmarks in the suite.
3766− *
3767− * @memberOf Benchmark.Suite
3768− * @param {String|Object} name The name of the method to invoke OR options object.
3769− * @param {Mixed} [arg1, arg2, ...] Arguments to invoke the method with.
3770− * @returns {Array} A new array of values returned from each method invoked.
3771− */
3772− 'invoke': methodize(invoke),
3773−
3774− /**
3775− * Converts the suite of benchmarks to a string.
3776− *
3777− * @memberOf Benchmark.Suite
3778− * @param {String} [separator=','] A string to separate each element of the array.
3779− * @returns {String} The string.
3780− */
3781− 'join': [].join,
3782−
3783− /**
3784− * An `Array#map` like method.
3785− *
3786− * @memberOf Benchmark.Suite
3787− * @param {Function} callback The function called per iteration.
3788− * @returns {Array} A new array of values returned by the callback.
3789− */
3790− 'map': methodize(map),
3791−
3792− /**
3793− * Retrieves the value of a specified property from all benchmarks in the suite.
3794− *
3795− * @memberOf Benchmark.Suite
3796− * @param {String} property The property to pluck.
3797− * @returns {Array} A new array of property values.
3798− */
3799− 'pluck': methodize(pluck),
3800−
3801− /**
3802− * Removes the last benchmark from the suite and returns it.
3803− *
3804− * @memberOf Benchmark.Suite
3805− * @returns {Mixed} The removed benchmark.
3806− */
3807− 'pop': [].pop,
3808−
3809− /**
3810− * Appends benchmarks to the suite.
3811− *
3812− * @memberOf Benchmark.Suite
3813− * @returns {Number} The suite's new length.
3814− */
3815− 'push': [].push,
3816−
3817− /**
3818− * Sorts the benchmarks of the suite.
3819− *
3820− * @memberOf Benchmark.Suite
3821− * @param {Function} [compareFn=null] A function that defines the sort order.
3822− * @returns {Object} The sorted suite.
3823− */
3824− 'sort': [].sort,
3825−
3826− /**
3827− * An `Array#reduce` like method.
3828− *
3829− * @memberOf Benchmark.Suite
3830− * @param {Function} callback The function called per iteration.
3831− * @param {Mixed} accumulator Initial value of the accumulator.
3832− * @returns {Mixed} The accumulator.
3833− */
3834− 'reduce': methodize(reduce),
3835−
3836− // aborts all benchmarks in the suite
3837− 'abort': abortSuite,
3838−
3839− // adds a benchmark to the suite
3840− 'add': add,
3841−
3842− // creates a new suite with cloned benchmarks
3843− 'clone': cloneSuite,
3844−
3845− // executes listeners of a specified type
3846− 'emit': emit,
3847−
3848− // creates a new suite of filtered benchmarks
3849− 'filter': filterSuite,
3850−
3851− // get listeners
3852− 'listeners': listeners,
3853−
3854− // unregister listeners
3855− 'off': off,
3856−
3857− // register listeners
3858− 'on': on,
3859−
3860− // resets all benchmarks in the suite
3861− 'reset': resetSuite,
3862−
3863− // runs all benchmarks in the suite
3864− 'run': runSuite,
3865−
3866− // array methods
3867− 'concat': concat,
3868−
3869− 'reverse': reverse,
3870−
3871− 'shift': shift,
3872−
3873− 'slice': slice,
3874−
3875− 'splice': splice,
3876−
3877− 'unshift': unshift
3878− });
3879−
3880− /*--------------------------------------------------------------------------*/
3881−
3882− // expose Deferred, Event and Suite
3883− extend(Benchmark, {
3884− 'Deferred': Deferred,
3885− 'Event': Event,
3886− 'Suite': Suite
3887− });
3888−
3889− // expose Benchmark
3890− // some AMD build optimizers, like r.js, check for specific condition patterns like the following:
3891− if (typeof define == 'function' && typeof define.amd == 'object' && define.amd) {
3892− // define as an anonymous module so, through path mapping, it can be aliased
3893− define(function() {
3894− return Benchmark;
3895− });
3896− }
3897− // check for `exports` after `define` in case a build optimizer adds an `exports` object
3898− else if (freeExports) {
3899− // in Node.js or RingoJS v0.8.0+
3900− if (typeof module == 'object' && module && module.exports == freeExports) {
3901− (module.exports = Benchmark).Benchmark = Benchmark;
3902− }
3903− // in Narwhal or RingoJS v0.7.0-
3904− else {
3905− freeExports.Benchmark = Benchmark;
3906− }
3907− }
3908− // in a browser or Rhino
3909− else {
3910− // use square bracket notation so Closure Compiler won't munge `Benchmark`
3911− // http://code.google.com/closure/compiler/docs/api-tutorial3.html#export
3912− window['Benchmark'] = Benchmark;
3913− }
3914−
3915− // trigger clock's lazy define early to avoid a security error
3916− if (support.air) {
3917− clock({ '_original': { 'fn': noop, 'count': 1, 'options': {} } });
3918− }
3919−}(this));
bench/src/Realistic/Check.elmdeleted−65
@@ -1,65 +0,0 @@
1−module Realistic.Check (benchmark) where
2−{-| Source: http://elm-lang.org/examples/checkboxes
3−-}
4−
5−import Benchmark
6−import String
7−
8−
9−benchmark : Benchmark.Benchmark
10−benchmark =
11− Benchmark.suite "check box business logic"
12− [ run "toggle boxes" toggleActions
13− ]
14−
15−
16−run : String -> List Action -> Benchmark.Benchmark
17−run description actions =
18− Benchmark.test
19− (description ++ " - " ++ toString (List.length actions) ++ " actions")
20− (\_ -> List.foldl update initialModel actions)
21−
22−
23−toggleActions =
24− [ Red True
25− , Underline True
26− , Bold True
27− , Bold False
28− , Red False
29− , Bold True
30− , Bold False
31− ]
32−
33−
34−-- MODEL
35−
36−type alias Model =
37− { red : Bool
38− , underline : Bool
39− , bold : Bool
40− }
41−
42−
43−initialModel =
44− Model False False True
45−
46−
47−-- UPDATE
48−
49−type Action
50− = Red Bool
51− | Underline Bool
52− | Bold Bool
53−
54−
55−update action model =
56− case action of
57− Red bool ->
58− { model | red = bool }
59−
60− Underline bool ->
61− { model | underline = bool }
62−
63− Bold bool ->
64− { model | bold = bool }
65−
bench/src/Realistic/Check15.elmdeleted−65
@@ -1,65 +0,0 @@
1−module Realistic.Check15 (benchmark) where
2−{-| Source: http://elm-lang.org/examples/checkboxes
3−-}
4−
5−import Benchmark
6−import String
7−
8−
9−benchmark : Benchmark.Benchmark
10−benchmark =
11− Benchmark.suite "check box business logic"
12− [ run "toggle boxes" toggleActions
13− ]
14−
15−
16−run : String -> List Action -> Benchmark.Benchmark
17−run description actions =
18− Benchmark.test
19− (description ++ " - " ++ toString (List.length actions) ++ " actions")
20− (\_ -> List.foldl update initialModel actions)
21−
22−
23−toggleActions =
24− [ Red True
25− , Underline True
26− , Bold True
27− , Bold False
28− , Red False
29− , Bold True
30− , Bold False
31− ]
32−
33−
34−-- MODEL
35−
36−type alias Model =
37− { red : Bool
38− , underline : Bool
39− , bold : Bool
40− }
41−
42−
43−initialModel =
44− Model False False True
45−
46−
47−-- UPDATE
48−
49−type Action
50− = Red Bool
51− | Underline Bool
52− | Bold Bool
53−
54−
55−update action model =
56− case action of
57− Red bool ->
58− { model | red <- bool }
59−
60− Underline bool ->
61− { model | underline <- bool }
62−
63− Bold bool ->
64− { model | bold <- bool }
65−
bench/src/Realistic/Todo.elmdeleted−169
@@ -1,169 +0,0 @@
1−module Realistic.Todo (benchmark) where
2−{-| Source: https://github.com/evancz/elm-todomvc
3−-}
4−
5−import Benchmark
6−import String
7−
8−
9−benchmark : Benchmark.Benchmark
10−benchmark =
11− Benchmark.suite "todomvc business logic"
12− [ run "type in 5 todos, each 15 characters long" typingActions
13− , run "do everything" batchActions
14− ]
15−
16−
17−run : String -> List Action -> Benchmark.Benchmark
18−run description actions =
19− Benchmark.test
20− (description ++ " - " ++ toString (List.length actions) ++ " actions")
21− (\_ -> List.foldl update emptyModel actions)
22−
23−
24−typingActions =
25− let
26− enter i =
27− List.map (\n -> UpdateField (String.repeat n "X")) [1..15]
28− ++ [ Add ]
29− in
30− List.concatMap enter [1..5]
31−
32−
33−batchActions =
34− let
35− addTask i =
36− [ UpdateField ("My task " ++ toString i)
37− , Add
38− ]
39−
40− editTask i =
41− [ EditingTask i True
42− , UpdateTask i "New Task text"
43− , EditingTask i False
44− ]
45−
46− check i =
47− Check i True
48−
49− uncheck i =
50− Check i False
51−
52− isEven i =
53− i % 2 == 0
54− in
55− List.concat
56− [ List.concatMap addTask [1..50]
57− , [CheckAll True, CheckAll False]
58− , List.concatMap editTask (List.filter isEven [1 .. 50])
59− , List.map check [5, 7, 9, 13, 17, 23, 37]
60− , List.map uncheck [7, 13, 23, 37]
61− , [DeleteComplete, Delete 7, Delete 23]
62− , List.concatMap addTask [51..80]
63− , List.map check (List.filter isEven [51..80])
64− , [DeleteComplete, CheckAll True, DeleteComplete]
65− ]
66−
67−
68−
69−-- MODEL
70−
71−
72−type alias Model =
73− { tasks : List Task
74− , field : String
75− , uid : Int
76− , visibility : String
77− }
78−
79−
80−type alias Task =
81− { description : String
82− , completed : Bool
83− , editing : Bool
84− , id : Int
85− }
86−
87−
88−newTask : String -> Int -> Task
89−newTask desc id =
90− { description = desc
91− , completed = False
92− , editing = False
93− , id = id
94− }
95−
96−
97−emptyModel : Model
98−emptyModel =
99− { tasks = []
100− , visibility = "All"
101− , field = ""
102− , uid = 0
103− }
104−
105−
106−
107−-- UPDATE
108−
109−
110−type Action
111− = NoOp
112− | UpdateField String
113− | EditingTask Int Bool
114− | UpdateTask Int String
115− | Add
116− | Delete Int
117− | DeleteComplete
118− | Check Int Bool
119− | CheckAll Bool
120− | ChangeVisibility String
121−
122−
123−update : Action -> Model -> Model
124−update action model =
125− case action of
126− NoOp -> model
127−
128− Add ->
129− { model |
130− uid = model.uid + 1,
131− field = "",
132− tasks =
133− if String.isEmpty model.field
134− then model.tasks
135− else model.tasks ++ [newTask model.field model.uid]
136− }
137−
138− UpdateField str ->
139− { model | field = str }
140−
141− EditingTask id isEditing ->
142− let updateTask t = if t.id == id then { t | editing = isEditing } else t
143− in
144− { model | tasks = List.map updateTask model.tasks }
145−
146− UpdateTask id task ->
147− let updateTask t = if t.id == id then { t | description = task } else t
148− in
149− { model | tasks = List.map updateTask model.tasks }
150−
151− Delete id ->
152− { model | tasks = List.filter (\t -> t.id /= id) model.tasks }
153−
154− DeleteComplete ->
155− { model | tasks = List.filter (not << .completed) model.tasks }
156−
157− Check id isCompleted ->
158− let updateTask t = if t.id == id then { t | completed = isCompleted } else t
159− in
160− { model | tasks = List.map updateTask model.tasks }
161−
162− CheckAll isCompleted ->
163− let updateTask t = { t | completed = isCompleted }
164− in
165− { model | tasks = List.map updateTask model.tasks }
166−
167− ChangeVisibility visibility ->
168− { model | visibility = visibility }
169−
bench/src/Realistic/Todo15.elmdeleted−167
@@ -1,167 +0,0 @@
1−module Realistic.Todo15 (benchmark) where
2−
3−import Benchmark
4−import String
5−
6−
7−benchmark : Benchmark.Benchmark
8−benchmark =
9− Benchmark.suite "todomvc business logic"
10− [ run "type in 5 todos, each 15 characters long" typingActions
11− , run "do everything" batchActions
12− ]
13−
14−
15−run : String -> List Action -> Benchmark.Benchmark
16−run description actions =
17− Benchmark.test
18− (description ++ " - " ++ toString (List.length actions) ++ " actions")
19− (\_ -> List.foldl update emptyModel actions)
20−
21−
22−typingActions =
23− let
24− enter i =
25− List.map (\n -> UpdateField (String.repeat n "X")) [1..15]
26− ++ [ Add ]
27− in
28− List.concatMap enter [1..5]
29−
30−
31−batchActions =
32− let
33− addTask i =
34− [ UpdateField ("My task " ++ toString i)
35− , Add
36− ]
37−
38− editTask i =
39− [ EditingTask i True
40− , UpdateTask i "New Task text"
41− , EditingTask i False
42− ]
43−
44− check i =
45− Check i True
46−
47− uncheck i =
48− Check i False
49−
50− isEven i =
51− i % 2 == 0
52− in
53− List.concat
54− [ List.concatMap addTask [1..50]
55− , [CheckAll True, CheckAll False]
56− , List.concatMap editTask (List.filter isEven [1 .. 50])
57− , List.map check [5, 7, 9, 13, 17, 23, 37]
58− , List.map uncheck [7, 13, 23, 37]
59− , [DeleteComplete, Delete 7, Delete 23]
60− , List.concatMap addTask [51..80]
61− , List.map check (List.filter isEven [51..80])
62− , [DeleteComplete, CheckAll True, DeleteComplete]
63− ]
64−
65−
66−
67−-- MODEL
68−
69−
70−type alias Model =
71− { tasks : List Task
72− , field : String
73− , uid : Int
74− , visibility : String
75− }
76−
77−
78−type alias Task =
79− { description : String
80− , completed : Bool
81− , editing : Bool
82− , id : Int
83− }
84−
85−
86−newTask : String -> Int -> Task
87−newTask desc id =
88− { description = desc
89− , completed = False
90− , editing = False
91− , id = id
92− }
93−
94−
95−emptyModel : Model
96−emptyModel =
97− { tasks = []
98− , visibility = "All"
99− , field = ""
100− , uid = 0
101− }
102−
103−
104−
105−-- UPDATE
106−
107−
108−type Action
109− = NoOp
110− | UpdateField String
111− | EditingTask Int Bool
112− | UpdateTask Int String
113− | Add
114− | Delete Int
115− | DeleteComplete
116− | Check Int Bool
117− | CheckAll Bool
118− | ChangeVisibility String
119−
120−
121−update : Action -> Model -> Model
122−update action model =
123− case action of
124− NoOp -> model
125−
126− Add ->
127− { model |
128− uid <- model.uid + 1,
129− field <- "",
130− tasks <-
131− if String.isEmpty model.field
132− then model.tasks
133− else model.tasks ++ [newTask model.field model.uid]
134− }
135−
136− UpdateField str ->
137− { model | field <- str }
138−
139− EditingTask id isEditing ->
140− let updateTask t = if t.id == id then { t | editing <- isEditing } else t
141− in
142− { model | tasks <- List.map updateTask model.tasks }
143−
144− UpdateTask id task ->
145− let updateTask t = if t.id == id then { t | description <- task } else t
146− in
147− { model | tasks <- List.map updateTask model.tasks }
148−
149− Delete id ->
150− { model | tasks <- List.filter (\t -> t.id /= id) model.tasks }
151−
152− DeleteComplete ->
153− { model | tasks <- List.filter (not << .completed) model.tasks }
154−
155− Check id isCompleted ->
156− let updateTask t = if t.id == id then { t | completed <- isCompleted } else t
157− in
158− { model | tasks <- List.map updateTask model.tasks }
159−
160− CheckAll isCompleted ->
161− let updateTask t = { t | completed <- isCompleted }
162− in
163− { model | tasks <- List.map updateTask model.tasks }
164−
165− ChangeVisibility visibility ->
166− { model | visibility <- visibility }
167−
bench/src/Syntax/Case.elmdeleted−80
@@ -1,80 +0,0 @@
1−module Syntax.Case (benchmark) where
2−
3−import Benchmark exposing (Benchmark, test, suite)
4−import String
5−
6−
7−benchmark : Benchmark.Benchmark
8−benchmark =
9− suite "case expressions"
10− [ suite "simple explicit patterns"
11− [ test "Maybe.withDefault 0 (Just 42)" (withDefault 0 (Just 42))
12− , test "Maybe.withDefault 0 Nothing" (withDefault 0 Nothing)
13− , test "isBlack Diamond" (isBlack Diamond)
14− , test "evaluate basicBoolean" (\_ -> evaluate basicBoolean)
15− , test "evaluate fancyBoolean" (\_ -> evaluate fancyBoolean)
16− ]
17− ]
18−
19−
20−-- 1 Level Deep Patterns
21−
22−withDefault default maybe _ =
23− case maybe of
24− Just x ->
25− x
26−
27− Nothing ->
28− default
29−
30−
31−type Suit = Diamond | Heart | Spade | Club
32−
33−
34−isBlack suit _ =
35− case suit of
36− Diamond ->
37− False
38−
39− Heart ->
40− False
41−
42− Spade ->
43− True
44−
45− Club ->
46− True
47−
48−
49−type Boolean
50− = Tru
51− | Fls
52− | And Boolean Boolean
53− | Or Boolean Boolean
54− | Not Boolean
55−
56−
57−basicBoolean =
58− And (Not Fls) Tru
59−
60−
61−fancyBoolean =
62− Or (Not Tru) (Or Fls (And Tru Tru))
63−
64−
65−evaluate boolean =
66− case boolean of
67− Tru ->
68− True
69−
70− Fls ->
71− False
72−
73− And a b ->
74− evaluate a && evaluate b
75−
76− Or a b ->
77− evaluate a || evaluate b
78−
79− Not bool ->
80− not (evaluate bool)
bench/src/Syntax/Let.elmdeleted−37
@@ -1,37 +0,0 @@
1−module Syntax.Let (benchmark) where
2−
3−import Benchmark exposing (Benchmark, test, suite)
4−import String
5−
6−
7−benchmark : Benchmark.Benchmark
8−benchmark =
9− suite "let expressions"
10− [ test "bind numbers, add them" simpleBindings
11− , test "tuple destructuring" tupleDestructuring
12− , test "record destructuring" recordDestructuring
13− ]
14−
15−
16−simpleBindings _ =
17− let
18− x = 3
19− y = 4
20− in
21− x + y
22−
23−
24−tupleDestructuring _ =
25− let
26− (x,y) = (3,4)
27− (a,b) = (1,1)
28− in
29− x + y + a + b
30−
31−
32−recordDestructuring _ =
33− let
34− {x,y} = { x = 3, y = 4 }
35− {a,b} = { a = 1, b = 1 }
36− in
37− x + y + a + b
bench/src/Syntax/Records.elmdeleted−109
@@ -1,109 +0,0 @@
1−module Syntax.Records (benchmark) where
2−
3−import Benchmark exposing (Benchmark, test, suite)
4−import String
5−
6−
7−benchmark : Benchmark.Benchmark
8−benchmark =
9− suite "records"
10− [ suite "update"
11− [ test "1 of 2 fields" (update1of2 record2)
12− , test "2 of 2 fields" (update2of2 record2)
13− , test "2 of 2 new" (new2of2 record2)
14− , test "3 of 5 fields" (update3of5 record5)
15− , test "5 of 5 fields" (update5of5 record5)
16− , test "5 of 5 new" (new5of5 record5)
17− ]
18− , suite "access"
19− [ test "2 of 2" (access2of2 record2)
20− , test "4 of 10" (access4of10 record10)
21− ]
22− ]
23−
24−
25−-- RECORDS WITH 2 FIELDS
26−
27−record2 =
28− { x = 3
29− , y = 4
30− }
31−
32−
33−update1of2 r _ =
34− { r | x = r.x + 42 }
35−
36−
37−update2of2 r _ =
38− { r
39− | x = r.x + 1
40− , y = r.y + 1
41− }
42−
43−
44−new2of2 r _ =
45− { x = r.x + 1
46− , y = r.y + 1
47− }
48−
49−
50−access2of2 r _ =
51− r.x + r.y
52−
53−
54−-- RECORDS WITH 5 FIELDS
55−
56−record5 =
57− { product = "iPhone 6s"
58− , storage = 16
59− , weight = 143
60− , ppi = 326
61− , chip = "A9"
62− }
63−
64−
65−update3of5 r _ =
66− { r
67− | product = "iPhone 6s Plus"
68− , weight = 192
69− , ppi = 401
70− }
71−
72−
73−update5of5 r _ =
74− { r
75− | product = "iPhone 6"
76− , storage = r.storage
77− , weight = 129
78− , ppi = r.ppi
79− , chip = "A8"
80− }
81−
82−
83−new5of5 r _ =
84− { product = "iPhone 6"
85− , storage = r.storage
86− , weight = 129
87− , ppi = r.ppi
88− , chip = "A8"
89− }
90−
91−
92−-- RECORDS WITH 10 FIELDS
93−
94−record10 =
95− { a = 1
96− , b = 2
97− , c = 3
98− , d = 4
99− , e = True
100− , f = 'a'
101− , g = "abc"
102− , h = record2
103− , i = record5
104− , j = [1,2,3]
105− }
106−
107−
108−access4of10 r _ =
109− r.a + r.b + r.c + r.d
bench/src/Syntax/Records15.elmdeleted−109
@@ -1,109 +0,0 @@
1−module Syntax.Records15 (benchmark) where
2−
3−import Benchmark exposing (Benchmark, test, suite)
4−import String
5−
6−
7−benchmark : Benchmark.Benchmark
8−benchmark =
9− suite "records"
10− [ suite "update"
11− [ test "1 of 2 fields" (update1of2 record2)
12− , test "2 of 2 fields" (update2of2 record2)
13− , test "2 of 2 new" (new2of2 record2)
14− , test "3 of 5 fields" (update3of5 record5)
15− , test "5 of 5 fields" (update5of5 record5)
16− , test "5 of 5 new" (new5of5 record5)
17− ]
18− , suite "access"
19− [ test "2 of 2" (access2of2 record2)
20− , test "4 of 10" (access4of10 record10)
21− ]
22− ]
23−
24−
25−-- RECORDS WITH 2 FIELDS
26−
27−record2 =
28− { x = 3
29− , y = 4
30− }
31−
32−
33−update1of2 r _ =
34− { r | x <- r.x + 42 }
35−
36−
37−update2of2 r _ =
38− { r
39− | x <- r.x + 1
40− , y <- r.y + 1
41− }
42−
43−
44−new2of2 r _ =
45− { x = r.x + 1
46− , y = r.y + 1
47− }
48−
49−
50−access2of2 r _ =
51− r.x + r.y
52−
53−
54−-- RECORDS WITH 5 FIELDS
55−
56−record5 =
57− { product = "iPhone 6s"
58− , storage = 16
59− , weight = 143
60− , ppi = 326
61− , chip = "A9"
62− }
63−
64−
65−update3of5 r _ =
66− { r
67− | product <- "iPhone 6s Plus"
68− , weight <- 192
69− , ppi <- 401
70− }
71−
72−
73−update5of5 r _ =
74− { r
75− | product <- "iPhone 6"
76− , storage <- r.storage
77− , weight <- 129
78− , ppi <- r.ppi
79− , chip <- "A8"
80− }
81−
82−
83−new5of5 r _ =
84− { product = "iPhone 6"
85− , storage = r.storage
86− , weight = 129
87− , ppi = r.ppi
88− , chip = "A8"
89− }
90−
91−
92−-- RECORDS WITH 10 FIELDS
93−
94−record10 =
95− { a = 1
96− , b = 2
97− , c = 3
98− , d = 4
99− , e = True
100− , f = 'a'
101− , g = "abc"
102− , h = record2
103− , i = record5
104− , j = [1,2,3]
105− }
106−
107−
108−access4of10 r _ =
109− r.a + r.b + r.c + r.d
builder/src/BackgroundWriter.hsnew file+42
@@ -0,0 +1,42 @@
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.hsnew file+1251
@@ -0,0 +1,1251 @@
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.hsnew file+37
@@ -0,0 +1,37 @@
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.hsnew file+383
@@ -0,0 +1,383 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Deps.Diff
3+ ( diff
4+ , PackageChanges(..)
5+ , ModuleChanges(..)
6+ , Changes(..)
7+ , moduleChangeMagnitude
8+ , toMagnitude
9+ , bump
10+ , getDocs
11+ )
12+ where
13+
14+
15+import Control.Monad (zipWithM)
16+import Data.Function (on)
17+import qualified Data.List as List
18+import qualified Data.Map as Map
19+import qualified Data.Name as Name
20+import qualified Data.Set as Set
21+import qualified System.Directory as Dir
22+import System.FilePath ((</>))
23+
24+import qualified Deps.Website as Website
25+import qualified Elm.Compiler.Type as Type
26+import qualified Elm.Docs as Docs
27+import qualified Elm.Magnitude as M
28+import qualified Elm.ModuleName as ModuleName
29+import 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
36+
37+
38+
39+-- CHANGES
40+
41+
42+data PackageChanges =
43+ PackageChanges
44+ { _modules_added :: [ModuleName.Raw]
45+ , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
46+ , _modules_removed :: [ModuleName.Raw]
47+ }
48+
49+
50+data ModuleChanges =
51+ 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
56+ }
57+
58+
59+data Changes k v =
60+ Changes
61+ { _added :: Map.Map k v
62+ , _changed :: Map.Map k (v,v)
63+ , _removed :: Map.Map k v
64+ }
65+
66+
67+getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
68+getChanges isEquivalent old new =
69+ let
70+ overlap = Map.intersectionWith (,) old new
71+ changed = Map.filter (not . uncurry isEquivalent) overlap
72+ in
73+ Changes (Map.difference new old) changed (Map.difference old new)
74+
75+
76+
77+-- DIFF
78+
79+
80+diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
81+diff oldDocs newDocs =
82+ let
83+ filterOutPatches chngs =
84+ Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
85+
86+ (Changes added changed removed) =
87+ getChanges (\_ _ -> False) oldDocs newDocs
88+ in
89+ PackageChanges
90+ (Map.keys added)
91+ (filterOutPatches (Map.map diffModule changed))
92+ (Map.keys removed)
93+
94+
95+
96+diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
97+diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
98+ ModuleChanges
99+ (getChanges isEquivalentUnion u1 u2)
100+ (getChanges isEquivalentAlias a1 a2)
101+ (getChanges isEquivalentValue v1 v2)
102+ (getChanges isEquivalentBinop b1 b2)
103+
104+
105+
106+-- EQUIVALENCE
107+
108+
109+isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
110+isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
111+ length oldCtors == length newCtors
112+ && and (zipWith (==) (map fst oldCtors) (map fst newCtors))
113+ && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
114+ where
115+ equiv :: [Type.Type] -> [Type.Type] -> Bool
116+ equiv oldTypes newTypes =
117+ let
118+ allEquivalent =
119+ zipWith
120+ isEquivalentAlias
121+ (map (Docs.Alias oldComment oldVars) oldTypes)
122+ (map (Docs.Alias newComment newVars) newTypes)
123+ in
124+ length oldTypes == length newTypes
125+ && and allEquivalent
126+
127+
128+isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
129+isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
130+ case diffType oldType newType of
131+ Nothing ->
132+ False
133+
134+ Just renamings ->
135+ length oldVars == length newVars
136+ && isEquivalentRenaming (zip oldVars newVars ++ renamings)
137+
138+
139+isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
140+isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
141+ isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
142+
143+
144+isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
145+isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
146+ isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
147+ && a1 == a2
148+ && p1 == p2
149+
150+
151+
152+-- DIFF TYPES
153+
154+
155+diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
156+diffType oldType newType =
157+ case (oldType, newType) of
158+ (Type.Var oldName, Type.Var newName) ->
159+ Just [(oldName, newName)]
160+
161+ (Type.Lambda a b, Type.Lambda a' b') ->
162+ (++)
163+ <$> diffType a a'
164+ <*> diffType b b'
165+
166+ (Type.Type oldName oldArgs, Type.Type newName newArgs) ->
167+ if not (isSameName oldName newName) || length oldArgs /= length newArgs then
168+ Nothing
169+ else
170+ concat <$> zipWithM diffType oldArgs newArgs
171+
172+ (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
173+ case (maybeExt, maybeExt') of
174+ (Nothing, Just _) ->
175+ Nothing
176+
177+ (Just _, Nothing) ->
178+ Nothing
179+
180+ (Nothing, Nothing) ->
181+ diffFields fields fields'
182+
183+ (Just oldExt, Just newExt) ->
184+ (:) (oldExt, newExt) <$> diffFields fields fields'
185+
186+ (Type.Unit, Type.Unit) ->
187+ Just []
188+
189+ (Type.Tuple a b cs, Type.Tuple x y zs) ->
190+ if length cs /= length zs then
191+ Nothing
192+ else
193+ do aVars <- diffType a x
194+ bVars <- diffType b y
195+ cVars <- concat <$> zipWithM diffType cs zs
196+ return (aVars ++ bVars ++ cVars)
197+
198+ (_, _) ->
199+ Nothing
200+
201+
202+-- handle very old docs that do not use qualified names
203+isSameName :: Name.Name -> Name.Name -> Bool
204+isSameName oldFullName newFullName =
205+ let
206+ dedot name =
207+ reverse (Name.splitDots name)
208+ in
209+ case ( dedot oldFullName, dedot newFullName ) of
210+ (oldName:[], newName:_) ->
211+ oldName == newName
212+
213+ (oldName:_, newName:[]) ->
214+ oldName == newName
215+
216+ _ ->
217+ oldFullName == newFullName
218+
219+
220+diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
221+diffFields oldRawFields newRawFields =
222+ let
223+ sort = List.sortBy (compare `on` fst)
224+ oldFields = sort oldRawFields
225+ newFields = sort newRawFields
226+ in
227+ if length oldRawFields /= length newRawFields then
228+ Nothing
229+
230+ else if or (zipWith ((/=) `on` fst) oldFields newFields) then
231+ Nothing
232+
233+ else
234+ concat <$> zipWithM (diffType `on` snd) oldFields newFields
235+
236+
237+
238+-- TYPE VARIABLES
239+
240+
241+isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
242+isEquivalentRenaming varPairs =
243+ let
244+ renamings =
245+ Map.toList (foldr insert Map.empty varPairs)
246+
247+ insert (old,new) dict =
248+ Map.insertWith (++) old [new] dict
249+
250+ verify (old, news) =
251+ case news of
252+ [] ->
253+ Nothing
254+
255+ new : rest ->
256+ if all (new ==) rest then
257+ Just (old, new)
258+ else
259+ Nothing
260+
261+ allUnique list =
262+ length list == Set.size (Set.fromList list)
263+ in
264+ case mapM verify renamings of
265+ Nothing ->
266+ False
267+
268+ Just verifiedRenamings ->
269+ all compatibleVars verifiedRenamings
270+ &&
271+ allUnique (map snd verifiedRenamings)
272+
273+
274+compatibleVars :: (Name.Name, Name.Name) -> Bool
275+compatibleVars (old, new) =
276+ case (categorizeVar old, categorizeVar new) of
277+ (CompAppend, CompAppend) -> True
278+ (Comparable, Comparable) -> True
279+ (Appendable, Appendable) -> True
280+ (Number , Number ) -> True
281+ (Number , Comparable) -> True
282+
283+ (_, Var) -> True
284+
285+ (_, _) -> False
286+
287+
288+data TypeVarCategory
289+ = CompAppend
290+ | Comparable
291+ | Appendable
292+ | Number
293+ | Var
294+
295+
296+categorizeVar :: Name.Name -> TypeVarCategory
297+categorizeVar name
298+ | Name.isCompappendType name = CompAppend
299+ | Name.isComparableType name = Comparable
300+ | Name.isAppendableType name = Appendable
301+ | Name.isNumberType name = Number
302+ | otherwise = Var
303+
304+
305+
306+-- MAGNITUDE
307+
308+
309+bump :: PackageChanges -> V.Version -> V.Version
310+bump changes version =
311+ case toMagnitude changes of
312+ M.PATCH ->
313+ V.bumpPatch version
314+
315+ M.MINOR ->
316+ V.bumpMinor version
317+
318+ M.MAJOR ->
319+ V.bumpMajor version
320+
321+
322+toMagnitude :: PackageChanges -> M.Magnitude
323+toMagnitude (PackageChanges added changed removed) =
324+ let
325+ addMag = if null added then M.PATCH else M.MINOR
326+ removeMag = if null removed then M.PATCH else M.MAJOR
327+ changeMags = map moduleChangeMagnitude (Map.elems changed)
328+ in
329+ maximum (addMag : removeMag : changeMags)
330+
331+
332+moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
333+moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
334+ maximum
335+ [ changeMagnitude unions
336+ , changeMagnitude aliases
337+ , changeMagnitude values
338+ , changeMagnitude binops
339+ ]
340+
341+
342+changeMagnitude :: Changes k v -> M.Magnitude
343+changeMagnitude (Changes added changed removed) =
344+ if Map.size removed > 0 || Map.size changed > 0 then
345+ M.MAJOR
346+
347+ else if Map.size added > 0 then
348+ M.MINOR
349+
350+ 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
builder/src/Deps/Registry.hsnew file+213
@@ -0,0 +1,213 @@
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.hsnew file+444
@@ -0,0 +1,444 @@
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2+module Deps.Solver
3+ ( Solver
4+ , Result(..)
5+ , Connection(..)
6+ --
7+ , Details(..)
8+ , verify
9+ --
10+ , AppSolution(..)
11+ , addToApp
12+ --
13+ , Env(..)
14+ , initEnv
15+ )
16+ where
17+
18+
19+import Control.Monad (foldM)
20+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
21+import qualified Data.Map as Map
22+import Data.Map ((!))
23+import qualified System.Directory as Dir
24+import System.FilePath ((</>))
25+
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
37+
38+
39+
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+ }
69+
70+
71+data Connection
72+ = Online Http.Manager
73+ | Offline
74+
75+
76+
77+-- RESULT
78+
79+
80+data Result a
81+ = Ok a
82+ | NoSolution
83+ | NoOfflineSolution
84+ | Err Exit.Solver
85+
86+
87+
88+-- VERIFY -- used by Elm.Details
89+
90+
91+data Details =
92+ Details V.Version (Map.Map Pkg.Name C.Constraint)
93+
94+
95+verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96+verify cache connection registry constraints =
97+ Stuff.withRegistryLock cache $
98+ case try constraints of
99+ Solver solver ->
100+ solver (State cache connection registry Map.empty)
101+ (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
102+ (\_ -> return $ noSolution connection)
103+ (\e -> return $ Err e)
104+
105+
106+addDeps :: State -> Pkg.Name -> V.Version -> Details
107+addDeps (State _ _ _ constraints) name vsn =
108+ case Map.lookup (name, vsn) constraints of
109+ Just (Constraints _ deps) -> Details vsn deps
110+ Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
111+
112+
113+noSolution :: Connection -> Result a
114+noSolution connection =
115+ case connection of
116+ Online _ -> NoSolution
117+ Offline -> NoOfflineSolution
118+
119+
120+
121+-- ADD TO APP - used in Install
122+
123+
124+data AppSolution =
125+ AppSolution
126+ { _old :: Map.Map Pkg.Name V.Version
127+ , _new :: Map.Map Pkg.Name V.Version
128+ , _app :: Outline.AppOutline
129+ }
130+
131+
132+addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
133+addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134+ Stuff.withRegistryLock cache $
135+ let
136+ allIndirects = Map.union indirect testIndirect
137+ allDirects = Map.union direct testDirect
138+ allDeps = Map.union allDirects allIndirects
139+
140+ attempt toConstraint deps =
141+ try (Map.insert pkg C.anything (Map.map toConstraint deps))
142+ in
143+ case
144+ oneOf
145+ ( attempt C.exactly allDeps )
146+ [ attempt C.exactly allDirects
147+ , attempt C.untilNextMinor allDirects
148+ , attempt C.untilNextMajor allDirects
149+ , attempt (\_ -> C.anything) allDirects
150+ ]
151+ of
152+ Solver solver ->
153+ solver (State cache connection registry Map.empty)
154+ (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
155+ (\_ -> return $ noSolution connection)
156+ (\e -> return $ Err e)
157+
158+
159+toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
160+toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =
161+ let
162+ d = Map.intersection new (Map.insert pkg V.one direct)
163+ i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
164+ td = Map.intersection new (Map.delete pkg testDirect)
165+ ti = Map.difference new (Map.unions [d,i,td])
166+ in
167+ AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)
168+
169+
170+getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
171+getTransitive constraints solution unvisited visited =
172+ case unvisited of
173+ [] ->
174+ visited
175+
176+ info@(pkg,vsn) : infos ->
177+ if Map.member pkg visited
178+ then getTransitive constraints solution infos visited
179+ else
180+ let
181+ newDeps = _deps (constraints ! info)
182+ newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
183+ newVisited = Map.insert pkg vsn visited
184+ in
185+ getTransitive constraints solution infos $
186+ getTransitive constraints solution newUnvisited newVisited
187+
188+
189+
190+-- TRY
191+
192+
193+try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
194+try constraints =
195+ exploreGoals (Goals constraints Map.empty)
196+
197+
198+
199+-- EXPLORE GOALS
200+
201+
202+data Goals =
203+ Goals
204+ { _pending :: Map.Map Pkg.Name C.Constraint
205+ , _solved :: Map.Map Pkg.Name V.Version
206+ }
207+
208+
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
214+
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
221+
222+
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
232+
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
237+ Just version ->
238+ if C.satisfies newConstraint version
239+ then return unsolved
240+ else backtrack
241+
242+ Nothing ->
243+ case Map.lookup name unsolved of
244+ Nothing ->
245+ return $ Map.insert name newConstraint unsolved
246+
247+ Just oldConstraint ->
248+ case C.intersect oldConstraint newConstraint of
249+ Nothing ->
250+ backtrack
251+
252+ 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+
441+
442+backtrack :: Solver a
443+backtrack =
444+ Solver $ \state _ back _ -> back state
builder/src/Deps/Website.hsnew file+26
@@ -0,0 +1,26 @@
1+module Deps.Website
2+ ( domain
3+ , route
4+ , metadata
5+ )
6+ where
7+
8+
9+import qualified Elm.Package as Pkg
10+import qualified Elm.Version as V
11+import qualified Http
12+
13+
14+domain :: String
15+domain =
16+ "https://package.elm-lang.org"
17+
18+
19+route :: String -> [(String,String)] -> String
20+route path params =
21+ Http.toUrl (domain ++ path) params
22+
23+
24+metadata :: Pkg.Name -> V.Version -> String -> String
25+metadata name version file =
26+ domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file
builder/src/Elm/Details.hsnew file+833
@@ -0,0 +1,833 @@
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/Outline.hsnew file+407
@@ -0,0 +1,407 @@
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/File.hsnew file+231
@@ -0,0 +1,231 @@
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/Generate.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# LANGUAGE BangPatterns #-}
2+module Generate
3+ ( debug
4+ , dev
5+ , prod
6+ , repl
7+ )
8+ where
9+
10+
11+import Prelude hiding (cycle, print)
12+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13+import Control.Monad (liftM2)
14+import qualified Data.ByteString.Builder as B
15+import Data.Map ((!))
16+import qualified Data.Map as Map
17+import qualified Data.Maybe as Maybe
18+import qualified Data.Name as N
19+import qualified Data.NonEmptyList as NE
20+
21+import qualified AST.Optimized as Opt
22+import qualified Build
23+import qualified Elm.Compiler.Type.Extract as Extract
24+import qualified Elm.Details as Details
25+import qualified Elm.Interface as I
26+import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Package as Pkg
28+import qualified File
29+import qualified Generate.JavaScript as JS
30+import qualified Generate.Mode as Mode
31+import qualified Nitpick.Debug as Nitpick
32+import qualified Reporting.Exit as Exit
33+import qualified Reporting.Task as Task
34+import qualified Stuff
35+
36+
37+-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38+-- desireable to have Repl and Reactor to keep foreign objects in memory
39+-- to make things a bit faster?
40+
41+
42+
43+-- GENERATORS
44+
45+
46+type Task a =
47+ Task.Task Exit.Generate a
48+
49+
50+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51+debug root details (Build.Artifacts pkg ifaces roots modules) =
52+ do loading <- loadObjects root details modules
53+ types <- loadTypes root ifaces modules
54+ objects <- finalizeObjects loading
55+ let mode = Mode.Dev (Just types)
56+ let graph = objectsToGlobalGraph objects
57+ let mains = gatherMains pkg objects roots
58+ return $ JS.generate mode graph mains
59+
60+
61+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62+dev root details (Build.Artifacts pkg _ roots modules) =
63+ do objects <- finalizeObjects =<< loadObjects root details modules
64+ let mode = Mode.Dev Nothing
65+ let graph = objectsToGlobalGraph objects
66+ let mains = gatherMains pkg objects roots
67+ return $ JS.generate mode graph mains
68+
69+
70+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71+prod root details (Build.Artifacts pkg _ roots modules) =
72+ do objects <- finalizeObjects =<< loadObjects root details modules
73+ checkForDebugUses objects
74+ let graph = objectsToGlobalGraph objects
75+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
76+ let mains = gatherMains pkg objects roots
77+ return $ JS.generate mode graph mains
78+
79+
80+repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81+repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82+ do objects <- finalizeObjects =<< loadObjects root details modules
83+ let graph = objectsToGlobalGraph objects
84+ return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85+
86+
87+
88+-- CHECK FOR DEBUG
89+
90+
91+checkForDebugUses :: Objects -> Task ()
92+checkForDebugUses (Objects _ locals) =
93+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94+ [] -> return ()
95+ m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96+
97+
98+
99+-- GATHER MAINS
100+
101+
102+gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103+gatherMains pkg (Objects _ locals) roots =
104+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105+
106+
107+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108+lookupMain pkg locals root =
109+ let
110+ toPair name (Opt.LocalGraph maybeMain _ _) =
111+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
112+ in
113+ case root of
114+ Build.Inside name -> toPair name =<< Map.lookup name locals
115+ Build.Outside name _ g -> toPair name g
116+
117+
118+
119+-- LOADING OBJECTS
120+
121+
122+data LoadingObjects =
123+ LoadingObjects
124+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126+ }
127+
128+
129+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130+loadObjects root details modules =
131+ Task.io $
132+ do mvar <- Details.loadObjects root details
133+ mvars <- traverse (loadObject root) modules
134+ return $ LoadingObjects mvar (Map.fromList mvars)
135+
136+
137+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138+loadObject root modul =
139+ case modul of
140+ Build.Fresh name _ graph ->
141+ do mvar <- newMVar (Just graph)
142+ return (name, mvar)
143+
144+ Build.Cached name _ _ ->
145+ do mvar <- newEmptyMVar
146+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147+ return (name, mvar)
148+
149+
150+
151+-- FINALIZE OBJECTS
152+
153+
154+data Objects =
155+ Objects
156+ { _foreign :: Opt.GlobalGraph
157+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158+ }
159+
160+
161+finalizeObjects :: LoadingObjects -> Task Objects
162+finalizeObjects (LoadingObjects mvar mvars) =
163+ Task.eio id $
164+ do result <- readMVar mvar
165+ results <- traverse readMVar mvars
166+ case liftM2 Objects result (sequence results) of
167+ Just loaded -> return (Right loaded)
168+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169+
170+
171+objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172+objectsToGlobalGraph (Objects globals locals) =
173+ foldr Opt.addLocalGraph globals locals
174+
175+
176+
177+-- LOAD TYPES
178+
179+
180+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181+loadTypes root ifaces modules =
182+ Task.eio id $
183+ do mvars <- traverse (loadTypesHelp root) modules
184+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185+ results <- traverse readMVar mvars
186+ case sequence results of
187+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189+
190+
191+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192+loadTypesHelp root modul =
193+ case modul of
194+ Build.Fresh name iface _ ->
195+ newMVar (Just (Extract.fromInterface name iface))
196+
197+ Build.Cached name _ ciMVar ->
198+ do cachedInterface <- readMVar ciMVar
199+ case cachedInterface of
200+ Build.Unneeded ->
201+ do mvar <- newEmptyMVar
202+ _ <- forkIO $
203+ do maybeIface <- File.readBinary (Stuff.elmi root name)
204+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
205+ return mvar
206+
207+ Build.Loaded iface ->
208+ newMVar (Just (Extract.fromInterface name iface))
209+
210+ Build.Corrupted ->
211+ newMVar Nothing
builder/src/Http.hsnew file+244
@@ -0,0 +1,244 @@
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.hsnew file+474
@@ -0,0 +1,474 @@
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.hsnew file+2069
@@ -0,0 +1,2069 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module 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+ --
25+ , toString
26+ , toStderr
27+ , toJson
28+ )
29+ where
30+
31+
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
52+import 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 ((<>))
57+import qualified Reporting.Doc as D
58+import qualified Reporting.Error.Import as Import
59+import qualified Reporting.Error.Json as Json
60+import qualified Reporting.Exit.Help as Help
61+import qualified Reporting.Error as Error
62+import qualified Reporting.Render.Code as Code
63+
64+
65+
66+-- RENDERERS
67+
68+
69+toString :: Help.Report -> String
70+toString report =
71+ Help.toString (Help.reportToDoc report)
72+
73+
74+toStderr :: Help.Report -> IO ()
75+toStderr report =
76+ Help.toStderr (Help.reportToDoc report)
77+
78+
79+toJson :: Help.Report -> Encode.Value
80+toJson report =
81+ Help.reportToJson report
82+
83+
84+
85+-- INIT
86+
87+
88+data Init
89+ = InitNoSolution [Pkg.Name]
90+ | InitNoOfflineSolution [Pkg.Name]
91+ | InitSolverProblem Solver
92+ | InitAlreadyExists
93+ | InitRegistryProblem RegistryProblem
94+
95+
96+initToReport :: Init -> Help.Report
97+initToReport exit =
98+ case exit of
99+ InitNoSolution pkgs ->
100+ Help.report "NO SOLUTION" Nothing
101+ "I tried to create an elm.json with the following direct dependencies:"
102+ [ D.indent 4 $ D.vcat $
103+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
104+ , D.reflow $
105+ "I could not find compatible versions though! This should not happen, so please\
106+ \ ask around one of the community forums at https://elm-lang.org/community to learn\
107+ \ what is going on!"
108+ ]
109+
110+ InitNoOfflineSolution pkgs ->
111+ Help.report "NO OFFLINE SOLUTION" Nothing
112+ "I tried to create an elm.json with the following direct dependencies:"
113+ [ D.indent 4 $ D.vcat $
114+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
115+ , D.reflow $
116+ "I could not find compatible versions though, but that may be because I could not\
117+ \ connect to https://package.elm-lang.org to get the latest list of packages. Are\
118+ \ you able to connect to the internet? Please ask around one of the community\
119+ \ forums at https://elm-lang.org/community for help!"
120+ ]
121+
122+ InitSolverProblem solver ->
123+ toSolverReport solver
124+
125+ InitAlreadyExists ->
126+ Help.report "EXISTING PROJECT" Nothing
127+ "You already have an elm.json file, so there is nothing for me to initialize!"
128+ [ D.fillSep
129+ ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"
130+ ,"you","figure","out","what","to","do","next?"
131+ ]
132+ ]
133+
134+ InitRegistryProblem problem ->
135+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
136+ "I need the list of published packages before I can start initializing projects"
137+
138+
139+
140+-- DIFF
141+
142+
143+data Diff
144+ = DiffNoOutline
145+ | DiffBadOutline Outline
146+ | DiffApplication
147+ | DiffNoExposed
148+ | DiffUnpublished
149+ | DiffUnknownPackage Pkg.Name [Pkg.Name]
150+ | DiffUnknownVersion Pkg.Name V.Version [V.Version]
151+ | DiffDocsProblem V.Version DocsProblem
152+ | DiffMustHaveLatestRegistry RegistryProblem
153+ | DiffBadDetails Details
154+ | DiffBadBuild BuildProblem
155+
156+
157+diffToReport :: Diff -> Help.Report
158+diffToReport diff =
159+ case diff of
160+ DiffNoOutline ->
161+ Help.report "DIFF WHAT?" Nothing
162+ "I cannot find an elm.json so I am not sure what you want me to diff.\
163+ \ Normally you run `elm diff` from within a project!"
164+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"
165+ , D.indent 4 $ D.green $ "elm diff elm/http 1.0.0 2.0.0"
166+ ]
167+
168+ DiffBadOutline outline ->
169+ toOutlineReport outline
170+
171+ DiffApplication ->
172+ Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
173+ "Your elm.json says this project is an application, but `elm diff` only works\
174+ \ with packages. That way there are previously published versions of the API to\
175+ \ diff against!"
176+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"
177+ , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"
178+ ]
179+
180+ DiffNoExposed ->
181+ Help.report "NO EXPOSED MODULES" (Just "elm.json")
182+ "Your elm.json has no \"exposed-modules\" which means there is no public API at\
183+ \ all right now! What am I supposed to diff?"
184+ [ D.reflow $
185+ "Try adding some modules back to the \"exposed-modules\" field."
186+ ]
187+
188+ DiffUnpublished ->
189+ Help.report "UNPUBLISHED" Nothing
190+ "This package is not published yet. There is nothing to diff against!"
191+ []
192+
193+ DiffUnknownPackage pkg suggestions ->
194+ Help.report "UNKNOWN PACKAGE" Nothing
195+ ( "I cannot find a package called:"
196+ )
197+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
198+ , "Maybe you want one of these instead?"
199+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
200+ , "But check <https://package.elm-lang.org> to see all possibilities!"
201+ ]
202+
203+ DiffUnknownVersion _pkg vsn realVersions ->
204+ Help.docReport "UNKNOWN VERSION" Nothing
205+ ( D.fillSep $
206+ [ "Version", D.red (D.fromVersion vsn)
207+ , "has", "never", "been", "published,", "so", "I"
208+ , "cannot", "diff", "against", "it."
209+ ]
210+ )
211+ [ "Here are all the versions that HAVE been published:"
212+ , D.indent 4 $ D.dullyellow $ D.vcat $
213+ let
214+ sameMajor v1 v2 = V._major v1 == V._major v2
215+ mkRow vsns = D.hsep $ map D.fromVersion vsns
216+ in
217+ map mkRow $ List.groupBy sameMajor (List.sort realVersions)
218+ , "Want one of those instead?"
219+ ]
220+
221+ DiffDocsProblem version problem ->
222+ toDocsProblemReport problem $
223+ "I need the docs for " ++ V.toChars version ++ " to compute this diff"
224+
225+ DiffMustHaveLatestRegistry problem ->
226+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
227+ "I need the latest list of published packages before I do this diff"
228+
229+ DiffBadDetails details ->
230+ toDetailsReport details
231+
232+ DiffBadBuild buildProblem ->
233+ toBuildProblemReport buildProblem
234+
235+
236+
237+-- BUMP
238+
239+
240+data Bump
241+ = BumpNoOutline
242+ | BumpBadOutline Outline
243+ | BumpApplication
244+ | BumpUnexpectedVersion V.Version [V.Version]
245+ | BumpMustHaveLatestRegistry RegistryProblem
246+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
247+ | BumpBadDetails Details
248+ | BumpNoExposed
249+ | BumpBadBuild BuildProblem
250+
251+
252+bumpToReport :: Bump -> Help.Report
253+bumpToReport bump =
254+ case bump of
255+ BumpNoOutline ->
256+ Help.report "BUMP WHAT?" Nothing
257+ "I cannot find an elm.json so I am not sure what you want me to bump."
258+ [ D.reflow $
259+ "Elm packages always have an elm.json that says current the version number. If\
260+ \ you run this command from a directory with an elm.json file, I will try to bump\
261+ \ the version in there based on the API changes."
262+ ]
263+
264+ BumpBadOutline outline ->
265+ toOutlineReport outline
266+
267+ BumpApplication ->
268+ Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
269+ "Your elm.json says this is an application. That means it cannot be published\
270+ \ on <https://package.elm-lang.org> and therefore has no version to bump!"
271+ []
272+
273+ BumpUnexpectedVersion vsn versions ->
274+ Help.docReport "CANNOT BUMP" (Just "elm.json")
275+ ( D.fillSep
276+ ["Your","elm.json","says","I","should","bump","relative","to","version"
277+ ,D.red (D.fromVersion vsn) <> ","
278+ ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
279+ ,"That","means","there","is","no","API","for","me","to","diff","against","and"
280+ ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
281+ ]
282+ )
283+ [ D.fillSep $
284+ ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
285+ ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
286+ , D.vcat $ map (D.green . D.fromVersion) versions
287+ ]
288+
289+ BumpMustHaveLatestRegistry problem ->
290+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
291+ "I need the latest list of published packages before I can bump any versions"
292+
293+ BumpCannotFindDocs _ version problem ->
294+ toDocsProblemReport problem $
295+ "I need the docs for " ++ V.toChars version ++ " to compute the next version number"
296+
297+ BumpBadDetails details ->
298+ toDetailsReport details
299+
300+ BumpNoExposed ->
301+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
302+ ( D.fillSep $
303+ [ "To", "bump", "a", "package,", "the"
304+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
305+ , "elm.json", "must", "list", "at", "least", "one", "module."
306+ ]
307+ )
308+ [ D.reflow $
309+ "Try adding some modules back to the \"exposed-modules\" field."
310+ ]
311+
312+ BumpBadBuild problem ->
313+ toBuildProblemReport problem
314+
315+
316+
317+-- OVERVIEW OF VERSIONING
318+
319+
320+newPackageOverview :: String
321+newPackageOverview =
322+ unlines
323+ [ "This package has never been published before. Here's how things work:"
324+ , ""
325+ , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
326+ , ""
327+ , " - All packages start with initial version " ++ V.toChars V.one
328+ , ""
329+ , " - Versions are incremented based on how the API changes:"
330+ , ""
331+ , " PATCH = the API is the same, no risk of breaking code"
332+ , " MINOR = values have been added, existing values are unchanged"
333+ , " MAJOR = existing values have been changed or removed"
334+ , ""
335+ , " - I will bump versions for you, automatically enforcing these rules"
336+ , ""
337+ ]
338+
339+
340+
341+-- PUBLISH
342+
343+
344+data Publish
345+ = PublishNoOutline
346+ | PublishBadOutline Outline
347+ | PublishBadDetails Details
348+ | PublishMustHaveLatestRegistry RegistryProblem
349+ | PublishApplication
350+ | PublishNotInitialVersion V.Version
351+ | PublishAlreadyPublished V.Version
352+ | PublishInvalidBump V.Version V.Version
353+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
354+ | PublishNoSummary
355+ | PublishNoExposed
356+ | PublishNoReadme
357+ | PublishShortReadme
358+ | PublishNoLicense
359+ | PublishBuildProblem BuildProblem
360+ | PublishMissingTag V.Version
361+ | PublishCannotGetTag V.Version Http.Error
362+ | PublishCannotGetTagData V.Version String BS.ByteString
363+ | PublishCannotGetZip Http.Error
364+ | PublishCannotDecodeZip String
365+ | PublishCannotGetDocs V.Version V.Version DocsProblem
366+ | PublishCannotRegister Http.Error
367+ | PublishNoGit
368+ | PublishLocalChanges V.Version
369+ --
370+ | PublishZipBadDetails Details
371+ | PublishZipApplication
372+ | PublishZipNoExposed
373+ | PublishZipBuildProblem BuildProblem
374+
375+
376+publishToReport :: Publish -> Help.Report
377+publishToReport publish =
378+ case publish of
379+ PublishNoOutline ->
380+ Help.report "PUBLISH WHAT?" Nothing
381+ "I cannot find an elm.json so I am not sure what you want me to publish."
382+ [ D.reflow $
383+ "Elm packages always have an elm.json that states the version number,\
384+ \ dependencies, exposed modules, etc."
385+ ]
386+
387+ PublishBadOutline outline ->
388+ toOutlineReport outline
389+
390+ PublishBadDetails problem ->
391+ toDetailsReport problem
392+
393+ PublishMustHaveLatestRegistry problem ->
394+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
395+ "I need the latest list of published packages to make sure this is safe to publish"
396+
397+ PublishApplication ->
398+ Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
399+
400+ PublishNotInitialVersion vsn ->
401+ Help.docReport "INVALID VERSION" Nothing
402+ ( D.fillSep
403+ ["I","cannot","publish"
404+ ,D.red (D.fromVersion vsn)
405+ ,"as","the","initial","version."
406+ ]
407+ )
408+ [ D.fillSep
409+ ["Change","it","to",D.green "1.0.0","which","is"
410+ ,"the","initial","version","for","all","Elm","packages."
411+ ]
412+ ]
413+
414+ PublishAlreadyPublished vsn ->
415+ Help.docReport "ALREADY PUBLISHED" Nothing
416+ ( D.vcat
417+ [ D.fillSep
418+ [ "Version", D.green (D.fromVersion vsn)
419+ , "has", "already", "been", "published.", "You", "cannot"
420+ , "publish", "it", "again!"
421+ ]
422+ , "Try using the `bump` command:"
423+ ]
424+ )
425+ [ D.dullyellow $ D.indent 4 "elm bump"
426+ , D.reflow $
427+ "It computes the version number based on API changes, ensuring\
428+ \ that no breaking changes end up in PATCH releases!"
429+ ]
430+
431+ PublishInvalidBump statedVersion latestVersion ->
432+ Help.docReport "INVALID VERSION" (Just "elm.json")
433+ ( D.fillSep $
434+ ["Your","elm.json","says","the","next","version","should","be"
435+ ,D.red (D.fromVersion statedVersion) <> ","
436+ ,"but","that","is","not","valid","based","on","the","previously"
437+ ,"published","versions."
438+ ]
439+ )
440+ [ D.fillSep $
441+ ["Change","the","version","back","to"
442+ ,D.green (D.fromVersion latestVersion)
443+ ,"which","is","the","most","recently","published","version."
444+ ,"From","there,","have","Elm","bump","the","version","by","running:"
445+ ]
446+ , D.indent 4 $ D.green "elm bump"
447+ , D.reflow $
448+ "If you want more insight on the API changes Elm detects, you\
449+ \ can run `elm diff` at this point as well."
450+ ]
451+
452+ PublishBadBump old new magnitude realNew realMagnitude ->
453+ Help.docReport "INVALID VERSION" (Just "elm.json")
454+ (
455+ D.fillSep $
456+ ["Your","elm.json","says","the","next","version","should","be"
457+ ,D.red (D.fromVersion new) <> ","
458+ ,"indicating","a",D.fromChars (M.toChars magnitude)
459+ ,"change","to","the","public","API."
460+ ,"This","does","not","match","the","API","diff","given","by:"
461+ ]
462+ )
463+ [ D.indent 4 $ D.fromChars $
464+ "elm diff " ++ V.toChars old
465+
466+ , D.fillSep $
467+ ["This","command","says","this","is","a"
468+ ,D.fromChars (M.toChars realMagnitude)
469+ ,"change,","so","the","next","version","should","be"
470+ ,D.green (D.fromVersion realNew) <> "."
471+ ,"Double","check","everything","to","make","sure","you"
472+ ,"are","publishing","what","you","want!"
473+ ]
474+ , D.reflow $
475+ "Also, next time use `elm bump` and I'll figure all this out for you!"
476+ ]
477+
478+ PublishNoSummary ->
479+ Help.docReport "NO SUMMARY" (Just "elm.json")
480+ ( D.fillSep $
481+ [ "To", "publish", "a", "package,", "your", "elm.json", "must"
482+ , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"
483+ , "a", "consice", "overview", "of", "your", "project."
484+ ]
485+ )
486+ [ D.reflow $
487+ "The summary must be less than 80 characters. It should describe\
488+ \ the concrete use of your package as clearly and as plainly as possible."
489+ ]
490+
491+ PublishNoExposed ->
492+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
493+ ( D.fillSep $
494+ [ "To", "publish", "a", "package,", "the"
495+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
496+ , "elm.json", "must", "list", "at", "least", "one", "module."
497+ ]
498+ )
499+ [ D.reflow $
500+ "Which modules do you want users of the package to have access to? Add their\
501+ \ names to the \"exposed-modules\" list."
502+ ]
503+
504+ PublishNoReadme ->
505+ toBadReadmeReport "NO README" $
506+ "Every published package must have a helpful README.md\
507+ \ file, but I do not see one in your project."
508+
509+ PublishShortReadme ->
510+ toBadReadmeReport "SHORT README" $
511+ "This README.md is too short. Having more details will help\
512+ \ people assess your package quickly and fairly."
513+
514+ PublishNoLicense ->
515+ Help.report "NO LICENSE FILE" (Just "LICENSE")
516+ "By publishing a package you are inviting the Elm community to build\
517+ \ upon your work. But without knowing your license, we have no idea if\
518+ \ that is legal!"
519+ [ D.reflow $
520+ "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\
521+ \ you must share that choice in two places. First, the license\
522+ \ identifier must appear in your elm.json file. Second, the full\
523+ \ license text must appear in the root of your project in a file\
524+ \ named LICENSE. Add that file and you will be all set!"
525+ ]
526+
527+ PublishBuildProblem buildProblem ->
528+ toBuildProblemReport buildProblem
529+
530+ PublishMissingTag version ->
531+ let vsn = V.toChars version in
532+ Help.docReport "NO TAG" Nothing
533+ ( D.fillSep $
534+ [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"
535+ , "cannot", "find", "a", D.green (D.fromChars vsn), "tag."
536+ ]
537+ )
538+ [ D.vcat
539+ [ "These tags make it possible to find this specific version on GitHub."
540+ , "To tag the most recent commit and push it to GitHub, run this:"
541+ ]
542+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $
543+ [ "git tag -a " ++ vsn ++ " -m \"new release\""
544+ , "git push origin " ++ vsn
545+ ]
546+ , "The -m flag is for a helpful message. Try to make it more informative!"
547+ ]
548+
549+ PublishCannotGetTag version httpError ->
550+ case httpError of
551+ Http.BadHttp _ (HTTP.StatusCodeException response _)
552+ | HTTP.statusCode (HTTP.responseStatus response) == 404 ->
553+ let vsn = V.toChars version in
554+ Help.report "NO TAG ON GITHUB" Nothing
555+ ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")
556+ [ D.reflow
557+ "Run the following command to make this tag available on GitHub:"
558+ , D.indent 4 $ D.dullyellow $ D.fromChars $
559+ "git push origin " ++ vsn
560+ , D.reflow
561+ "This will make it possible to find your code online based on the version number."
562+ ]
563+
564+ _ ->
565+ toHttpErrorReport "PROBLEM VERIFYING TAG" httpError
566+ "I need to check that the version tag is registered on GitHub"
567+
568+ PublishCannotGetTagData version url body ->
569+ Help.report "PROBLEM VERIFYING TAG" Nothing
570+ ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")
571+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
572+ , D.reflow $
573+ "I got the data back, but it was not what I was expecting. The response\
574+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
575+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
576+ , D.indent 4 $ D.dullyellow $ D.fromChars $
577+ if BS.length body <= 76
578+ then BS_UTF8.toString body
579+ else take 73 (BS_UTF8.toString body) ++ "..."
580+ , D.reflow $
581+ "Does this error keep showing up? Maybe there is something weird with your\
582+ \ internet connection. We have gotten reports that schools, businesses,\
583+ \ airports, etc. sometimes intercept requests and add things to the body\
584+ \ or change its contents entirely. Could that be the problem?"
585+ ]
586+
587+ PublishCannotGetZip httpError ->
588+ toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $
589+ "I need to check that folks can download and build the source code when they\
590+ \ install this package"
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
698+
699+
700+toDocsProblemReport :: DocsProblem -> String -> Help.Report
701+toDocsProblemReport problem context =
702+ case problem of
703+ DP_Http httpError ->
704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705+
706+ DP_Data url body ->
707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
709+ , D.reflow $
710+ "I got the data back, but it was not what I was expecting. The response\
711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713+ , D.indent 4 $ D.dullyellow $ D.fromChars $
714+ if BS.length body <= 76
715+ then BS_UTF8.toString body
716+ else take 73 (BS_UTF8.toString body) ++ "..."
717+ , D.reflow $
718+ "Does this error keep showing up? Maybe there is something weird with your\
719+ \ internet connection. We have gotten reports that schools, businesses,\
720+ \ airports, etc. sometimes intercept requests and add things to the body\
721+ \ or change its contents entirely. Could that be the problem?"
722+ ]
723+
724+ DP_Cache ->
725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726+ [ D.reflow $
727+ "I deleted the cached version, so the next run should download a fresh copy of\
728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730+ \ for some reason."
731+ ]
732+
733+
734+
735+-- INSTALL
736+
737+
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
751+
752+
753+installToReport :: Install -> Help.Report
754+installToReport exit =
755+ case exit of
756+ InstallNoOutline ->
757+ Help.report "NEW PROJECT?" Nothing
758+ "Are you trying to start a new project? Try this command instead:"
759+ [ D.indent 4 $ D.green "elm init"
760+ , D.reflow "It will help you get started!"
761+ ]
762+
763+ InstallBadOutline outline ->
764+ toOutlineReport outline
765+
766+ InstallBadRegistry problem ->
767+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
768+ "I need the list of published packages to figure out how to install things"
769+
770+ InstallNoArgs elmHome ->
771+ Help.report "INSTALL WHAT?" Nothing
772+ "I am expecting commands like:"
773+ [ D.green $ D.indent 4 $ D.vcat $
774+ [ "elm install elm/http"
775+ , "elm install elm/json"
776+ , "elm install elm/random"
777+ ]
778+ , D.toFancyHint
779+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."
780+ ,"\"Gotta","download","everything!\"","But","why","download","packages"
781+ ,"again","and","again?","Instead,","Elm","caches","packages","in"
782+ ,D.dullyellow (D.fromChars elmHome)
783+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
784+ ,"Elm","projects","check","that","cache","before","trying","the","internet."
785+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
786+ ,"easier","to","work","offline.","As","a","result"
787+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
788+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
789+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
790+ ]
791+ ]
792+
793+ InstallNoOnlineAppSolution pkg ->
794+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
795+ (
796+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
797+ \ with your existing dependencies."
798+ )
799+ [ D.reflow $
800+ "I checked all the published versions. When that failed, I tried to find any\
801+ \ compatible combination of these packages, even if it meant changing all your\
802+ \ existing dependencies! That did not work either!"
803+ , D.reflow $
804+ "This is most likely to happen when a package is not upgraded yet. Maybe a new\
805+ \ version of Elm came out recently? Maybe a common package was changed recently?\
806+ \ Maybe a better package came along, so there was no need to upgrade this one?\
807+ \ Try asking around https://elm-lang.org/community to learn what might be going on\
808+ \ with this package."
809+ , D.toSimpleNote $
810+ "Whatever the case, please be kind to the relevant package authors! Having\
811+ \ friendly interactions with users is great motivation, and conversely, getting\
812+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
813+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
814+ \ goals, etc. They face obstacles outside of their technical work you will never\
815+ \ know about, so please assume the best and try to be patient and supportive!"
816+ ]
817+
818+ InstallNoOfflineAppSolution pkg ->
819+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
820+ (
821+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
822+ \ with your existing dependencies."
823+ )
824+ [ D.reflow $
825+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
826+ \ able to look through packages that you have downloaded in the past."
827+ , D.reflow $
828+ "Try again later when you have internet!"
829+ ]
830+
831+ InstallNoOnlinePkgSolution pkg ->
832+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
833+ (
834+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
835+ \ with your existing constraints."
836+ )
837+ [ D.reflow $
838+ "With applications, I try to broaden the constraints to see if anything works,\
839+ \ but messing with package constraints is much more delicate business. E.g. making\
840+ \ your constraints stricter may make it harder for applications to find compatible\
841+ \ dependencies. So fixing something here may break it for a lot of other people!"
842+ , D.reflow $
843+ "So I recommend making an application with the same dependencies as your package.\
844+ \ See if there is a solution at all. From there it may be easier to figure out\
845+ \ how to proceed in a way that will disrupt your users as little as possible. And\
846+ \ the solution may be to help other package authors to get their packages updated,\
847+ \ or to drop a dependency entirely."
848+ ]
849+
850+ InstallNoOfflinePkgSolution pkg ->
851+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
852+ (
853+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
854+ \ with your existing constraints."
855+ )
856+ [ D.reflow $
857+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
858+ \ able to look through packages that you have downloaded in the past."
859+ , D.reflow $
860+ "Try again later when you have internet!"
861+ ]
862+
863+ InstallHadSolverTrouble solver ->
864+ toSolverReport solver
865+
866+ InstallUnknownPackageOnline pkg suggestions ->
867+ Help.docReport "UNKNOWN PACKAGE" Nothing
868+ (
869+ D.fillSep
870+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
871+ )
872+ [ D.reflow $
873+ "I looked through https://package.elm-lang.org for packages with similar names\
874+ \ and found these:"
875+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
876+ , D.reflow $ "Maybe you want one of these instead?"
877+ ]
878+
879+ InstallUnknownPackageOffline pkg suggestions ->
880+ Help.docReport "UNKNOWN PACKAGE" Nothing
881+ (
882+ D.fillSep
883+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
884+ )
885+ [ D.reflow $
886+ "I could not connect to https://package.elm-lang.org though, so new packages may\
887+ \ have been published since I last updated my local cache of package names."
888+ , D.reflow $
889+ "Looking through the locally cached names, the closest ones are:"
890+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
891+ , D.reflow $ "Maybe you want one of these instead?"
892+ ]
893+
894+ InstallBadDetails details ->
895+ toDetailsReport details
896+
897+
898+
899+-- SOLVER
900+
901+
902+data Solver
903+ = SolverBadCacheData Pkg.Name V.Version
904+ | SolverBadHttpData Pkg.Name V.Version String
905+ | SolverBadHttp Pkg.Name V.Version Http.Error
906+
907+
908+toSolverReport :: Solver -> Help.Report
909+toSolverReport problem =
910+ case problem of
911+ SolverBadCacheData pkg vsn ->
912+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
913+ (
914+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
915+ \ help me search for a set of compatible packages. I had it cached locally, but\
916+ \ it looks like the file was corrupted!"
917+ )
918+ [ D.reflow $
919+ "I deleted the cached version, so the next run should download a fresh copy.\
920+ \ Hopefully that will get you unstuck, but it will not resolve the root\
921+ \ problem if a 3rd party tool is modifing cached files for some reason."
922+ ]
923+
924+ SolverBadHttpData pkg vsn url ->
925+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
926+ (
927+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
928+ \ help me search for a set of compatible packages, but I ran into corrupted\
929+ \ information from:"
930+ )
931+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
932+ , D.reflow $
933+ "Is something weird with your internet connection. We have gotten reports that\
934+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\
935+ \ to the body or change its contents entirely. Could that be the problem?"
936+ ]
937+
938+ SolverBadHttp pkg vsn httpError ->
939+ toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
940+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
941+ ++ " to help me search for a set of compatible packages"
942+
943+
944+
945+-- OUTLINE
946+
947+
948+data Outline
949+ = OutlineHasBadStructure (Decode.Error OutlineProblem)
950+ | OutlineHasMissingSrcDirs FilePath [FilePath]
951+ | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952+ | OutlineNoPkgCore
953+ | OutlineNoAppCore
954+ | OutlineNoAppJson
955+
956+
957+data OutlineProblem
958+ = OP_BadType
959+ | OP_BadPkgName Row Col
960+ | OP_BadVersion Row Col
961+ | OP_BadConstraint C.Error
962+ | OP_BadModuleName Row Col
963+ | OP_BadModuleHeaderTooLong
964+ | OP_BadDependencyName Row Col
965+ | OP_BadLicense Json.String [Json.String]
966+ | OP_BadSummaryTooLong
967+ | OP_NoSrcDirs
968+
969+
970+toOutlineReport :: Outline -> Help.Report
971+toOutlineReport problem =
972+ case problem of
973+ OutlineHasBadStructure decodeError ->
974+ Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
975+ Json.ExplicitReason "I ran into a problem with your elm.json file."
976+
977+ OutlineHasMissingSrcDirs dir dirs ->
978+ case dirs of
979+ [] ->
980+ Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
981+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
982+ [ D.indent 4 $ D.red $ D.fromChars dir
983+ , D.reflow $
984+ "I cannot find it though. Is it missing? Is there a typo?"
985+ ]
986+
987+ _:_ ->
988+ Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
989+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
990+ [ D.indent 4 $ D.vcat $
991+ map (D.red . D.fromChars) (dir:dirs)
992+ , D.reflow $
993+ "I cannot find them though. Are they missing? Are there typos?"
994+ ]
995+
996+ OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
997+ if dir1 == dir2 then
998+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
999+ "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
1000+ [ D.indent 4 $ D.vcat $
1001+ map (D.red . D.fromChars) [dir1,dir2]
1002+ , D.reflow $
1003+ "Remove one of the entries!"
1004+ ]
1005+ else
1006+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
1007+ "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
1008+ [ D.indent 4 $ D.vcat $
1009+ map (D.red . D.fromChars) [dir1,dir2]
1010+ , D.reflow $
1011+ "These are two different ways of refering to the same directory:"
1012+ , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
1013+ , D.reflow $
1014+ "Remove one of the redundant entries from your \"source-directories\" field."
1015+ ]
1016+
1017+ OutlineNoPkgCore ->
1018+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1019+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1020+ \ of `List` and `Maybe` do not work without it."
1021+ [ D.reflow $
1022+ "If you modified your elm.json by hand, try to change it back! And if you are\
1023+ \ having trouble getting back to a working elm.json, it may be easier to find a\
1024+ \ working package and start fresh with their elm.json file."
1025+ ]
1026+
1027+ OutlineNoAppCore ->
1028+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1029+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1030+ \ of `List` and `Maybe` do not work without it."
1031+ [ D.reflow $
1032+ "If you modified your elm.json by hand, try to change it back! And if you are\
1033+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1034+ \ and use `elm init` to start fresh."
1035+ ]
1036+
1037+ OutlineNoAppJson ->
1038+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1039+ "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
1040+ \ flags and ports."
1041+ [ D.reflow $
1042+ "If you modified your elm.json by hand, try to change it back! And if you are\
1043+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1044+ \ and use `elm init` to start fresh."
1045+ ]
1046+
1047+
1048+toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
1049+toOutlineProblemReport path source _ region problem =
1050+ let
1051+ toHighlight row col =
1052+ Just $ A.Region (A.Position row col) (A.Position row col)
1053+
1054+ toSnippet title highlight pair =
1055+ Help.jsonReport title (Just path) $
1056+ Code.toSnippet source region highlight pair
1057+ in
1058+ case problem of
1059+ OP_BadType ->
1060+ toSnippet "UNEXPECTED TYPE" Nothing
1061+ ( D.reflow $
1062+ "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
1063+ , D.fillSep
1064+ ["Try","changing","the","\"type\"","to"
1065+ ,D.green "\"application\"","or",D.green "\"package\"","instead."
1066+ ]
1067+ )
1068+
1069+ OP_BadPkgName row col ->
1070+ toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
1071+ ( D.reflow $
1072+ "I got stuck while reading your elm.json file. I ran into trouble with the package name:"
1073+ , D.stack
1074+ [ D.fillSep
1075+ ["Package","names","are","always","written","as"
1076+ ,D.green "\"author/project\""
1077+ ,"so","I","am","expecting","to","see","something","like:"
1078+ ]
1079+ , D.dullyellow $ D.indent 4 $ D.vcat $
1080+ [ "\"mdgriffith/elm-ui\""
1081+ , "\"w0rm/elm-physics\""
1082+ , "\"Microsoft/elm-json-tree-view\""
1083+ , "\"FordLabs/elm-star-rating\""
1084+ , "\"1602/json-schema\""
1085+ ]
1086+ , D.reflow
1087+ "The author name should match your GitHub name exactly, and the project name\
1088+ \ needs to follow these rules:"
1089+ , D.indent 4 $ D.vcat $
1090+ [ "+--------------------------------------+-----------+-----------+"
1091+ , "| RULE | BAD | GOOD |"
1092+ , "+--------------------------------------+-----------+-----------+"
1093+ , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
1094+ , "| no leading digits | 3D | elm-3d |"
1095+ , "| no non-ASCII characters | elm-bjørn | elm-bear |"
1096+ , "| no underscores | elm_ui | elm-ui |"
1097+ , "| no double hyphens | elm--hash | elm-hash |"
1098+ , "| no starting or ending hyphen | -elm-tar- | elm-tar |"
1099+ , "+--------------------------------------+-----------+-----------+"
1100+ ]
1101+ , D.toSimpleNote $
1102+ "These rules only apply to the project name, so you should never need\
1103+ \ to change your GitHub name!"
1104+ ]
1105+ )
1106+
1107+ OP_BadVersion row col ->
1108+ toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
1109+ ( D.reflow $
1110+ "I got stuck while reading your elm.json file. I was expecting a version number here:"
1111+ , D.fillSep
1112+ ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
1113+ ,"that","explicitly","states","all","three","numbers!"
1114+ ]
1115+ )
1116+
1117+ OP_BadConstraint constraintError ->
1118+ case constraintError of
1119+ C.BadFormat row col ->
1120+ toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
1121+ ( D.reflow $
1122+ "I got stuck while reading your elm.json file. I do not understand this version constraint:"
1123+ , D.stack
1124+ [ D.fillSep
1125+ ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
1126+ ,"that","explicitly","lists","the","lower","and","upper","bounds."
1127+ ]
1128+ , D.toSimpleNote $
1129+ "The spaces in there are required! Taking them out will confuse me. Adding\
1130+ \ extra spaces confuses me too. I recommend starting with a valid example\
1131+ \ and just changing the version numbers."
1132+ ]
1133+ )
1134+
1135+ C.InvalidRange before after ->
1136+ if before == after then
1137+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1138+ ( D.reflow $
1139+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1140+ , D.fillSep
1141+ ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
1142+ ,"so","it","is","best","to","use","wide","constraints.","I","recommend"
1143+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
1144+ ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
1145+ ,"happen","in","any","of","the","versions","in","that","range."
1146+ ]
1147+ )
1148+
1149+ else
1150+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1151+ ( D.reflow $
1152+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1153+ , D.fillSep
1154+ ["Maybe","you","want","something","like"
1155+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
1156+ ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
1157+ ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
1158+ ,"cannot","happen","in","any","of","the","versions","in","that","range."
1159+ ]
1160+ )
1161+
1162+ OP_BadModuleName row col ->
1163+ toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
1164+ ( D.reflow $
1165+ "I got stuck while reading your elm.json file. I was expecting a module name here:"
1166+ , D.fillSep
1167+ ["I","need","something","like",D.green "\"Html.Events\""
1168+ ,"or",D.green "\"Browser.Navigation\""
1169+ ,"where","each","segment","starts","with","a","capital"
1170+ ,"letter","and","the","segments","are","separated","by","dots."
1171+ ]
1172+ )
1173+
1174+ OP_BadModuleHeaderTooLong ->
1175+ toSnippet "HEADER TOO LONG" Nothing
1176+ ( D.reflow $
1177+ "I got stuck while reading your elm.json file. This section header is too long:"
1178+ , D.stack
1179+ [ D.fillSep
1180+ ["I","need","it","to","be"
1181+ ,D.green "under",D.green "20",D.green "bytes"
1182+ ,"so","it","renders","nicely","on","the","package","website!"
1183+ ]
1184+ , D.toSimpleNote
1185+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1186+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1187+ \ overly restrictive for your needs."
1188+ ]
1189+ )
1190+
1191+ OP_BadDependencyName row col ->
1192+ toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
1193+ ( D.reflow $
1194+ "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
1195+ , D.stack
1196+ [ D.fillSep
1197+ ["Package","names","always","include","the","name","of","the","author,"
1198+ ,"so","I","am","expecting","to","see","dependencies","like"
1199+ ,D.dullyellow "\"mdgriffith/elm-ui\"","and"
1200+ ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
1201+ ]
1202+ , D.fillSep $
1203+ ["I","generally","recommend","finding","the","package","you","want","on"
1204+ ,"the","package","website,","and","installing","it","with","the"
1205+ ,D.green "elm install","command!"
1206+ ]
1207+ ]
1208+ )
1209+
1210+ OP_BadLicense _ suggestions ->
1211+ toSnippet "UNKNOWN LICENSE" Nothing
1212+ ( D.reflow $
1213+ "I got stuck while reading your elm.json file. I do not know about this type of license:"
1214+ ,
1215+ D.stack
1216+ [ D.fillSep
1217+ ["Elm","packages","generally","use"
1218+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
1219+ ,"but","I","accept","any","OSI","approved","SPDX","license."
1220+ ,"Here","some","that","seem","close","to","what","you","wrote:"
1221+ ]
1222+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
1223+ , D.reflow $
1224+ "Check out https://spdx.org/licenses/ for the full list of options."
1225+ ]
1226+ )
1227+
1228+ OP_BadSummaryTooLong ->
1229+ toSnippet "SUMMARY TOO LONG" Nothing
1230+ ( D.reflow $
1231+ "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
1232+ , D.stack
1233+ [ D.fillSep
1234+ ["I","need","it","to","be"
1235+ ,D.green "under",D.green "80",D.green "bytes"
1236+ ,"so","it","renders","nicely","on","the","package","website!"
1237+ ]
1238+ , D.toSimpleNote
1239+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1240+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1241+ \ overly restrictive for your needs."
1242+ ]
1243+ )
1244+
1245+ OP_NoSrcDirs ->
1246+ toSnippet "NO SOURCE DIRECTORIES" Nothing
1247+ ( D.reflow $
1248+ "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
1249+ , D.fillSep
1250+ ["I","need","something","like",D.green "[\"src\"]"
1251+ ,"so","I","know","where","to","look","for","your","modules!"
1252+ ]
1253+ )
1254+
1255+
1256+
1257+-- DETAILS
1258+
1259+
1260+data Details
1261+ = DetailsNoSolution
1262+ | DetailsNoOfflineSolution
1263+ | DetailsSolverProblem Solver
1264+ | DetailsBadElmInPkg C.Constraint
1265+ | DetailsBadElmInAppOutline V.Version
1266+ | DetailsHandEditedDependencies
1267+ | DetailsBadOutline Outline
1268+ | DetailsCannotGetRegistry RegistryProblem
1269+ | DetailsBadDeps FilePath [DetailsBadDep]
1270+
1271+
1272+data DetailsBadDep
1273+ = BD_BadDownload Pkg.Name V.Version PackageProblem
1274+ | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)
1275+
1276+
1277+toDetailsReport :: Details -> Help.Report
1278+toDetailsReport details =
1279+ case details of
1280+ DetailsNoSolution ->
1281+ Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json")
1282+ "The dependencies in your elm.json are not compatible."
1283+ [ D.fillSep
1284+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
1285+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1286+ ]
1287+ , D.reflow $
1288+ "Please ask for help on the community forums if you try those paths and are still\
1289+ \ having problems!"
1290+ ]
1291+
1292+ DetailsNoOfflineSolution ->
1293+ Help.report "TROUBLE VERIFYING DEPENDENCIES" (Just "elm.json")
1294+ "I could not connect to https://package.elm-lang.org to get the latest list of\
1295+ \ packages, and I was unable to verify your dependencies with the information I\
1296+ \ have cached locally."
1297+ [ D.reflow $
1298+ "Are you able to connect to the internet? These dependencies may work once you\
1299+ \ get access to the registry!"
1300+ , D.toFancyNote
1301+ ["If","you","changed","your","dependencies","by","hand,","try","to","change","them","back!"
1302+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1303+ ]
1304+ ]
1305+
1306+ DetailsSolverProblem solver ->
1307+ toSolverReport solver
1308+
1309+ DetailsBadElmInPkg constraint ->
1310+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1311+ "Your elm.json says this package needs a version of Elm in this range:"
1312+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
1313+ , D.fillSep
1314+ [ "But", "you", "are", "using", "Elm"
1315+ , D.red (D.fromVersion V.compiler)
1316+ , "right", "now."
1317+ ]
1318+ ]
1319+
1320+ DetailsBadElmInAppOutline version ->
1321+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1322+ "Your elm.json says this application needs a different version of Elm."
1323+ [ D.fillSep
1324+ [ "It", "requires"
1325+ , D.green (D.fromVersion version) <> ","
1326+ , "but", "you", "are", "using"
1327+ , D.red (D.fromVersion V.compiler)
1328+ , "right", "now."
1329+ ]
1330+ ]
1331+
1332+ DetailsHandEditedDependencies ->
1333+ Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
1334+ "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
1335+ \ party tool) leaving them in an invalid state."
1336+ [ D.fillSep
1337+ ["Try","to","change","them","back","to","what","they","were","before!"
1338+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1339+ ]
1340+ , D.reflow $
1341+ "Please ask for help on the community forums if you try those paths and are still\
1342+ \ having problems!"
1343+ ]
1344+
1345+ DetailsBadOutline outline ->
1346+ toOutlineReport outline
1347+
1348+ DetailsCannotGetRegistry problem ->
1349+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
1350+ "I need the list of published packages to verify your dependencies"
1351+
1352+ DetailsBadDeps cacheDir deps ->
1353+ case List.sortOn toBadDepRank deps of
1354+ [] ->
1355+ Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1356+ "I am not sure what is going wrong though."
1357+ [ D.reflow $
1358+ "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
1359+ \ trying to build again. That will work if some cached files got corrupted\
1360+ \ somehow."
1361+ , D.reflow $
1362+ "If that does not work, go to https://elm-lang.org/community and ask for\
1363+ \ help. This is a weird case!"
1364+ ]
1365+
1366+ d:_ ->
1367+ case d of
1368+ BD_BadDownload pkg vsn packageProblem ->
1369+ toPackageProblemReport pkg vsn packageProblem
1370+
1371+ BD_BadBuild pkg vsn fingerprint ->
1372+ Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1373+ "I ran into a compilation error when trying to build the following package:"
1374+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
1375+ , D.reflow $
1376+ "This probably means it has package constraints that are too wide. It may be\
1377+ \ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\
1378+ \ over to https://elm-lang.org/community to get help figuring out how to take\
1379+ \ this path!"
1380+ , D.toSimpleNote $
1381+ "To help with the root problem, please report this to the package author along\
1382+ \ with the following information:"
1383+ , D.indent 4 $ D.vcat $
1384+ map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $
1385+ Map.toList fingerprint
1386+ , D.reflow $
1387+ "If you want to help out even more, try building the package locally. That should\
1388+ \ give you much more specific information about why this package is failing to\
1389+ \ build, which will in turn make it easier for the package author to fix it!"
1390+ ]
1391+
1392+
1393+toBadDepRank :: DetailsBadDep -> Int -- lower is better
1394+toBadDepRank badDep =
1395+ case badDep of
1396+ BD_BadDownload _ _ _ -> 0
1397+ BD_BadBuild _ _ _ -> 1
1398+
1399+
1400+
1401+-- PACKAGE PROBLEM
1402+
1403+
1404+data PackageProblem
1405+ = PP_BadEndpointRequest Http.Error
1406+ | PP_BadEndpointContent String
1407+ | PP_BadArchiveRequest Http.Error
1408+ | PP_BadArchiveContent String
1409+ | PP_BadArchiveHash String String String
1410+
1411+
1412+toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report
1413+toPackageProblemReport pkg vsn problem =
1414+ let
1415+ thePackage =
1416+ Pkg.toChars pkg ++ " " ++ V.toChars vsn
1417+ in
1418+ case problem of
1419+ PP_BadEndpointRequest httpError ->
1420+ toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1421+ "I need to find the latest download link for " ++ thePackage
1422+
1423+ PP_BadEndpointContent url ->
1424+ Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1425+ (
1426+ "I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:"
1427+ )
1428+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1429+ , D.reflow $
1430+ "Is something weird with your internet connection. We have gotten reports that\
1431+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\
1432+ \ to the body or change its contents entirely. Could that be the problem?"
1433+ ]
1434+
1435+ PP_BadArchiveRequest httpError ->
1436+ toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1437+ "I was trying to download the source code for " ++ thePackage
1438+
1439+ PP_BadArchiveContent url ->
1440+ Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1441+ (
1442+ "I downloaded the source code for " ++ thePackage ++ " from:"
1443+ )
1444+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1445+ , D.reflow $
1446+ "But I was unable to unzip the data. Maybe there is something weird with\
1447+ \ your internet connection. We have gotten reports that schools, businesses,\
1448+ \ airports, etc. sometimes intercept requests and add things to the body or\
1449+ \ change its contents entirely. Could that be the problem?"
1450+ ]
1451+
1452+ PP_BadArchiveHash url expectedHash actualHash ->
1453+ Help.report "CORRUPT PACKAGE DATA" Nothing
1454+ (
1455+ "I downloaded the source code for " ++ thePackage ++ " from:"
1456+ )
1457+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1458+ , D.reflow "But it looks like the hash of the archive has changed since publication:"
1459+ , D.vcat $ map D.fromChars $
1460+ [ " Expected: " ++ expectedHash
1461+ , " Actual: " ++ actualHash
1462+ ]
1463+ , D.reflow $
1464+ "This usually means that the package author moved the version\
1465+ \ tag, so report it to them and see if that is the issue. Folks\
1466+ \ on Elm slack can probably help as well."
1467+ ]
1468+
1469+
1470+
1471+-- REGISTRY PROBLEM
1472+
1473+
1474+data RegistryProblem
1475+ = RP_Http Http.Error
1476+ | RP_Data String BS.ByteString
1477+
1478+
1479+toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report
1480+toRegistryProblemReport title problem context =
1481+ case problem of
1482+ RP_Http err ->
1483+ toHttpErrorReport title err context
1484+
1485+ RP_Data url body ->
1486+ Help.report title Nothing (context ++ ", so I fetched:")
1487+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1488+ , D.reflow $
1489+ "I got the data back, but it was not what I was expecting. The response\
1490+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
1491+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
1492+ , D.indent 4 $ D.dullyellow $ D.fromChars $
1493+ if BS.length body <= 76
1494+ then BS_UTF8.toString body
1495+ else take 73 (BS_UTF8.toString body) ++ "..."
1496+ , D.reflow $
1497+ "Does this error keep showing up? Maybe there is something weird with your\
1498+ \ internet connection. We have gotten reports that schools, businesses,\
1499+ \ airports, etc. sometimes intercept requests and add things to the body\
1500+ \ or change its contents entirely. Could that be the problem?"
1501+ ]
1502+
1503+
1504+toHttpErrorReport :: String -> Http.Error -> String -> Help.Report
1505+toHttpErrorReport title err context =
1506+ let
1507+ toHttpReport intro url details =
1508+ Help.report title Nothing intro $
1509+ D.indent 4 (D.dullyellow (D.fromChars url)) : details
1510+ in
1511+ case err of
1512+ Http.BadUrl url reason ->
1513+ toHttpReport (context ++ ", so I wanted to fetch:") url
1514+ [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"
1515+ , D.indent 4 $ D.fromChars reason
1516+ , D.reflow $
1517+ "This may indicate that there is some problem in the compiler, so please open an\
1518+ \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\
1519+ \ version, the command you ran, the terminal output, and any additional information\
1520+ \ that might help others reproduce the error."
1521+ ]
1522+
1523+ Http.BadHttp url httpExceptionContent ->
1524+ case httpExceptionContent of
1525+ HTTP.StatusCodeException response body ->
1526+ let
1527+ (HTTP.Status code message) = HTTP.responseStatus response
1528+ in
1529+ toHttpReport (context ++ ", so I tried to fetch:") url
1530+ [ D.fillSep $
1531+ ["But","it","came","back","as",D.red (D.fromInt code)]
1532+ ++ map D.fromChars (words (BS_UTF8.toString message))
1533+ , D.indent 4 $ D.reflow $ BS_UTF8.toString body
1534+ , D.reflow $
1535+ "This may mean some online endpoint changed in an unexpected way, so if does not\
1536+ \ seem like something on your side is causing this (e.g. firewall) please report\
1537+ \ this to https://github.com/elm/compiler/issues with your operating system, Elm\
1538+ \ version, the command you ran, the terminal output, and any additional information\
1539+ \ that can help others reproduce the error!"
1540+ ]
1541+
1542+ HTTP.TooManyRedirects responses ->
1543+ toHttpReport (context ++ ", so I tried to fetch:") url
1544+ [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"
1545+ , D.indent 4 $ D.vcat $ map toRedirectDoc responses
1546+ , D.reflow $
1547+ "Is it possible that your internet connection intercepts certain requests? That\
1548+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1549+ \ and certain countries. Try asking for help locally or in a community forum!"
1550+ ]
1551+
1552+ otherException ->
1553+ toHttpReport (context ++ ", so I tried to fetch:") url
1554+ [ D.reflow $ "But my HTTP library is giving me the following error message:"
1555+ , D.indent 4 $ D.fromChars (show otherException)
1556+ , D.reflow $
1557+ "Are you somewhere with a slow internet connection? Or no internet?\
1558+ \ Does the link I am trying to fetch work in your browser? Maybe the\
1559+ \ site is down? Does your internet connection have a firewall that\
1560+ \ blocks certain domains? It is usually something like that!"
1561+ ]
1562+
1563+ Http.BadMystery url someException ->
1564+ toHttpReport (context ++ ", so I tried to fetch:") url
1565+ [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"
1566+ , D.indent 4 $ D.fromChars (show someException)
1567+ , D.reflow $
1568+ "Is it possible that your internet connection intercepts certain requests? That\
1569+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1570+ \ and certain countries. Try asking for help locally or in a community forum!"
1571+ ]
1572+
1573+
1574+toRedirectDoc :: HTTP.Response body -> D.Doc
1575+toRedirectDoc response =
1576+ let
1577+ (HTTP.Status code message) = HTTP.responseStatus response
1578+ in
1579+ case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of
1580+ Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)
1581+ Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)
1582+
1583+
1584+
1585+-- MAKE
1586+
1587+
1588+data Make
1589+ = MakeNoOutline
1590+ | MakeCannotOptimizeAndDebug
1591+ | MakeBadDetails Details
1592+ | MakeAppNeedsFileNames
1593+ | MakePkgNeedsExposing
1594+ | MakeMultipleFilesIntoHtml
1595+ | MakeNoMain
1596+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1597+ | MakeCannotBuild BuildProblem
1598+ | MakeBadGenerate Generate
1599+
1600+
1601+makeToReport :: Make -> Help.Report
1602+makeToReport make =
1603+ case make of
1604+ MakeNoOutline ->
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 ->
1869+ Help.report "IMPORT CYCLE" Nothing
1870+ "Your module imports form a cycle:"
1871+ [ D.cycle 4 name names
1872+ , D.reflow $
1873+ "Learn more about why this is disallowed and how to break cycles here:"
1874+ ++ D.makeLink "import-cycles"
1875+ ]
1876+
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) []
2055+
2056+ ReplBadLocalDeps root e es ->
2057+ Help.compilerReport root e es
2058+
2059+ ReplProjectProblem projectProblem ->
2060+ toProjectProblemReport projectProblem
2061+
2062+ ReplBadGenerate generate ->
2063+ toGenerateReport generate
2064+
2065+ ReplBadCache ->
2066+ corruptCacheReport
2067+
2068+ ReplBlocked ->
2069+ corruptCacheReport
builder/src/Reporting/Exit/Help.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Help
3+ ( Report
4+ , report
5+ , docReport
6+ , jsonReport
7+ , compilerReport
8+ , reportToDoc
9+ , reportToJson
10+ , toString
11+ , toStdout
12+ , toStderr
13+ )
14+ where
15+
16+
17+import GHC.IO.Handle (hIsTerminalDevice)
18+import System.IO (Handle, hPutStr, stderr, stdout)
19+
20+import qualified Json.Encode as E
21+import Json.Encode ((==>))
22+import Reporting.Doc ((<+>))
23+import qualified Reporting.Doc as D
24+import qualified Reporting.Error as Error
25+
26+
27+
28+-- REPORT
29+
30+
31+data Report
32+ = CompilerReport FilePath Error.Module [Error.Module]
33+ | Report
34+ { _title :: String
35+ , _path :: Maybe FilePath
36+ , _message :: D.Doc
37+ }
38+
39+
40+report :: String -> Maybe FilePath -> String -> [D.Doc] -> Report
41+report title path startString others =
42+ Report title path $ D.stack (D.reflow startString:others)
43+
44+
45+docReport :: String -> Maybe FilePath -> D.Doc -> [D.Doc] -> Report
46+docReport title path startDoc others =
47+ Report title path $ D.stack (startDoc:others)
48+
49+
50+jsonReport :: String -> Maybe FilePath -> D.Doc -> Report
51+jsonReport =
52+ Report
53+
54+
55+compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
56+compilerReport =
57+ CompilerReport
58+
59+
60+
61+-- TO DOC
62+
63+
64+reportToDoc :: Report -> D.Doc
65+reportToDoc report_ =
66+ case report_ of
67+ CompilerReport root e es ->
68+ Error.toDoc root e es
69+
70+ Report title maybePath message ->
71+ let
72+ makeDashes n =
73+ replicate (max 1 (80 - n)) '-'
74+
75+ errorBarEnd =
76+ case maybePath of
77+ Nothing ->
78+ makeDashes (4 + length title)
79+
80+ Just path ->
81+ makeDashes (5 + length title + length path) ++ " " ++ path
82+
83+ errorBar =
84+ D.dullcyan $
85+ "--" <+> D.fromChars title <+> D.fromChars errorBarEnd
86+ in
87+ D.stack [errorBar, message, ""]
88+
89+
90+
91+-- TO JSON
92+
93+
94+reportToJson :: Report -> E.Value
95+reportToJson report_ =
96+ case report_ of
97+ CompilerReport _ e es ->
98+ E.object
99+ [ "type" ==> E.chars "compile-errors"
100+ , "errors" ==> E.list Error.toJson (e:es)
101+ ]
102+
103+ 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
109+ ]
110+
111+
112+
113+-- OUTPUT
114+
115+
116+toString :: D.Doc -> String
117+toString =
118+ D.toString
119+
120+
121+toStdout :: D.Doc -> IO ()
122+toStdout doc =
123+ toHandle stdout doc
124+
125+
126+toStderr :: D.Doc -> IO ()
127+toStderr doc =
128+ toHandle stderr doc
129+
130+
131+toHandle :: Handle -> D.Doc -> IO ()
132+toHandle handle doc =
133+ do isTerminal <- hIsTerminalDevice handle
134+ if isTerminal
135+ then D.toAnsi handle doc
136+ else hPutStr handle (toString doc)
builder/src/Reporting/Task.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE Rank2Types #-}
2+module Reporting.Task
3+ ( Task
4+ , run
5+ , throw
6+ , mapError
7+ --
8+ , io
9+ , mio
10+ , eio
11+ )
12+ where
13+
14+
15+
16+-- TASKS
17+
18+
19+newtype Task x a =
20+ Task
21+ (
22+ forall result. (a -> IO result) -> (x -> IO result) -> IO result
23+ )
24+
25+
26+run :: Task x a -> IO (Either x a)
27+run (Task task) =
28+ task (return . Right) (return . Left)
29+
30+
31+throw :: x -> Task x a
32+throw x =
33+ Task $ \_ err -> err x
34+
35+
36+mapError :: (x -> y) -> Task x a -> Task y a
37+mapError func (Task task) =
38+ Task $ \ok err ->
39+ task ok (err . func)
40+
41+
42+
43+-- IO
44+
45+
46+{-# INLINE io #-}
47+io :: IO a -> Task x a
48+io work =
49+ Task $ \ok _ -> work >>= ok
50+
51+
52+mio :: x -> IO (Maybe a) -> Task x a
53+mio x work =
54+ Task $ \ok err ->
55+ do result <- work
56+ case result of
57+ Just a -> ok a
58+ Nothing -> err x
59+
60+
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)
68+
69+
70+
71+-- INSTANCES
72+
73+
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
82+
83+
84+instance Applicative (Task x) where
85+ {-# INLINE pure #-}
86+ pure a =
87+ Task $ \ok _ -> ok a
88+
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
100+
101+
102+instance Monad (Task x) where
103+ {-# INLINE return #-}
104+ return = pure
105+
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
builder/src/Stuff.hsnew file+179
@@ -0,0 +1,179 @@
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"
cabal.confignew file+2
@@ -0,0 +1,2 @@
1+profiling: False
2+library-profiling: True
compiler/src/AST/Canonical.hsnew file+401
@@ -0,0 +1,401 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module AST.Canonical
4+ ( Expr, Expr_(..)
5+ , CaseBranch(..)
6+ , FieldUpdate(..)
7+ , CtorOpts(..)
8+ -- definitions
9+ , Def(..)
10+ , Decls(..)
11+ -- patterns
12+ , Pattern, Pattern_(..)
13+ , PatternCtorArg(..)
14+ -- types
15+ , Annotation(..)
16+ , Type(..)
17+ , AliasType(..)
18+ , FieldType(..)
19+ , fieldsToList
20+ -- modules
21+ , Module(..)
22+ , Alias(..)
23+ , Binop(..)
24+ , Union(..)
25+ , Ctor(..)
26+ , Exports(..)
27+ , Export(..)
28+ , Effects(..)
29+ , Port(..)
30+ , Manager(..)
31+ )
32+ where
33+
34+{- 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+package in the List module.
37+
38+In later phases (e.g. type inference, exhaustiveness checking, optimization)
39+you need to look up additional info from these modules. What is the type?
40+What are the alternative type constructors? These lookups can be quite costly,
41+especially in type inference. To reduce costs the canonicalization phase
42+caches info needed in later phases. This means we no longer build large
43+dictionaries of metadata with O(log(n)) lookups in those phases. Instead
44+there is an O(1) read of an existing field! I have tried to mark all
45+cached data with comments like:
46+
47+-- CACHE for exhaustiveness
48+-- CACHE for inference
49+
50+So it is clear why the data is kept around.
51+-}
52+
53+
54+import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
55+import Data.Binary
56+import qualified Data.List as List
57+import qualified Data.Map as Map
58+import Data.Name (Name)
59+
60+import qualified AST.Source as Src
61+import qualified AST.Utils.Binop as Binop
62+import qualified AST.Utils.Shader as Shader
63+import 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
67+import qualified Reporting.Annotation as A
68+
69+
70+
71+-- EXPRESSIONS
72+
73+
74+type Expr =
75+ A.Located Expr_
76+
77+
78+-- CACHE Annotations for type inference
79+data 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
89+ | Int Int
90+ | Float EF.Float
91+ | List [Expr]
92+ | Negate Expr
93+ | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
94+ | Lambda [Pattern] Expr
95+ | Call Expr [Expr]
96+ | If [(Expr, Expr)] Expr
97+ | Let Def Expr
98+ | LetRec [Def] Expr
99+ | LetDestruct Pattern Expr Expr
100+ | 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)
105+ | Unit
106+ | Tuple Expr Expr (Maybe Expr)
107+ | Shader Shader.Source Shader.Types
108+
109+
110+data CaseBranch =
111+ CaseBranch Pattern Expr
112+
113+
114+data FieldUpdate =
115+ FieldUpdate A.Region Expr
116+
117+
118+
119+-- DEFS
120+
121+
122+data Def
123+ = Def (A.Located Name) [Pattern] Expr
124+ | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type
125+
126+
127+
128+-- DECLARATIONS
129+
130+
131+data Decls
132+ = Declare Def Decls
133+ | DeclareRec Def [Def] Decls
134+ | SaveTheEnvironment
135+
136+
137+
138+-- PATTERNS
139+
140+
141+type Pattern =
142+ A.Located Pattern_
143+
144+
145+data Pattern_
146+ = PAnything
147+ | PVar Name
148+ | PRecord [Name]
149+ | PAlias Pattern Name
150+ | PUnit
151+ | PTuple Pattern Pattern (Maybe Pattern)
152+ | PList [Pattern]
153+ | PCons Pattern Pattern
154+ | PBool Union Bool
155+ | PChr ES.String
156+ | PStr ES.String
157+ | PInt Int
158+ | PCtor
159+ { _p_home :: ModuleName.Canonical
160+ , _p_type :: Name
161+ , _p_union :: Union
162+ , _p_name :: Name
163+ , _p_index :: Index.ZeroBased
164+ , _p_args :: [PatternCtorArg]
165+ }
166+ -- CACHE _p_home, _p_type, and _p_vars for type inference
167+ -- CACHE _p_index to replace _p_name in PROD code gen
168+ -- CACHE _p_opts to allocate less in PROD code gen
169+ -- CACHE _p_alts and _p_numAlts for exhaustiveness checker
170+
171+
172+data PatternCtorArg =
173+ PatternCtorArg
174+ { _index :: Index.ZeroBased -- CACHE for destructors/errors
175+ , _type :: Type -- CACHE for type inference
176+ , _arg :: Pattern
177+ }
178+
179+
180+
181+-- TYPES
182+
183+
184+data Annotation = Forall FreeVars Type
185+ deriving (Eq)
186+
187+
188+type FreeVars = Map.Map Name ()
189+
190+
191+data Type
192+ = TLambda Type Type
193+ | TVar Name
194+ | TType ModuleName.Canonical Name [Type]
195+ | TRecord (Map.Map Name FieldType) (Maybe Name)
196+ | TUnit
197+ | TTuple Type Type (Maybe Type)
198+ | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType
199+ deriving (Eq)
200+
201+
202+data AliasType
203+ = Holey Type
204+ | Filled Type
205+ deriving (Eq)
206+
207+
208+data FieldType = FieldType {-# UNPACK #-} !Word16 Type
209+ deriving (Eq)
210+
211+
212+-- NOTE: The Word16 marks the source order, but it may not be available
213+-- for every canonical type. For example, if the canonical type is inferred
214+-- the orders will all be zeros.
215+--
216+fieldsToList :: Map.Map Name FieldType -> [(Name, Type)]
217+fieldsToList fields =
218+ let
219+ getIndex (_, FieldType index _) =
220+ index
221+
222+ dropIndex (name, FieldType _ tipe) =
223+ (name, tipe)
224+ in
225+ map dropIndex (List.sortOn getIndex (Map.toList fields))
226+
227+
228+
229+-- MODULES
230+
231+
232+data Module =
233+ Module
234+ { _name :: ModuleName.Canonical
235+ , _exports :: Exports
236+ , _docs :: Src.Docs
237+ , _decls :: Decls
238+ , _unions :: Map.Map Name Union
239+ , _aliases :: Map.Map Name Alias
240+ , _binops :: Map.Map Name Binop
241+ , _effects :: Effects
242+ }
243+
244+
245+data Alias = Alias [Name] Type
246+ deriving (Eq)
247+
248+
249+data Binop = Binop_ Binop.Associativity Binop.Precedence Name
250+ deriving (Eq)
251+
252+
253+data Union =
254+ Union
255+ { _u_vars :: [Name]
256+ , _u_alts :: [Ctor]
257+ , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking
258+ , _u_opts :: CtorOpts -- CACHE which optimizations are available
259+ }
260+ deriving (Eq)
261+
262+
263+data CtorOpts
264+ = Normal
265+ | Enum
266+ | Unbox
267+ deriving (Eq, Ord)
268+
269+
270+data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args
271+ deriving (Eq)
272+
273+
274+
275+-- EXPORTS
276+
277+
278+data Exports
279+ = ExportEverything A.Region
280+ | Export (Map.Map Name (A.Located Export))
281+
282+
283+data Export
284+ = ExportValue
285+ | ExportBinop
286+ | ExportAlias
287+ | ExportUnionOpen
288+ | ExportUnionClosed
289+ | ExportPort
290+
291+
292+
293+-- EFFECTS
294+
295+
296+data Effects
297+ = NoEffects
298+ | Ports (Map.Map Name Port)
299+ | Manager A.Region A.Region A.Region Manager
300+
301+
302+data Port
303+ = Incoming { _freeVars :: FreeVars, _payload :: Type, _func :: Type }
304+ | Outgoing { _freeVars :: FreeVars, _payload :: Type, _func :: Type }
305+
306+
307+data Manager
308+ = Cmd Name
309+ | Sub Name
310+ | Fx Name Name
311+
312+
313+
314+-- BINARY
315+
316+
317+instance Binary Alias where
318+ get = liftM2 Alias get get
319+ put (Alias a b) = put a >> put b
320+
321+
322+instance Binary Union where
323+ put (Union a b c d) = put a >> put b >> put c >> put d
324+ get = liftM4 Union get get get get
325+
326+
327+instance Binary Ctor where
328+ get = liftM4 Ctor get get get get
329+ put (Ctor a b c d) = put a >> put b >> put c >> put d
330+
331+
332+instance Binary CtorOpts where
333+ put opts =
334+ case opts of
335+ Normal -> putWord8 0
336+ Enum -> putWord8 1
337+ Unbox -> putWord8 2
338+
339+ get =
340+ do n <- getWord8
341+ case n of
342+ 0 -> return Normal
343+ 1 -> return Enum
344+ 2 -> return Unbox
345+ _ -> fail "binary encoding of CtorOpts was corrupted"
346+
347+
348+instance Binary Annotation where
349+ get = liftM2 Forall get get
350+ put (Forall a b) = put a >> put b
351+
352+
353+instance Binary Type where
354+ put tipe =
355+ case tipe of
356+ TLambda a b -> putWord8 0 >> put a >> put b
357+ TVar a -> putWord8 1 >> put a
358+ TRecord a b -> putWord8 2 >> put a >> put b
359+ TUnit -> putWord8 3
360+ TTuple a b c -> putWord8 4 >> put a >> put b >> put c
361+ TAlias a b c d -> putWord8 5 >> put a >> put b >> put c >> put d
362+ TType home name ts ->
363+ let potentialWord = length ts + 7 in
364+ if potentialWord <= fromIntegral (maxBound :: Word8) then
365+ do putWord8 (fromIntegral potentialWord)
366+ put home
367+ put name
368+ mapM_ put ts
369+ else
370+ putWord8 6 >> put home >> put name >> put ts
371+
372+ get =
373+ do word <- getWord8
374+ case word of
375+ 0 -> liftM2 TLambda get get
376+ 1 -> liftM TVar get
377+ 2 -> liftM2 TRecord get get
378+ 3 -> return TUnit
379+ 4 -> liftM3 TTuple get get get
380+ 5 -> liftM4 TAlias get get get get
381+ 6 -> liftM3 TType get get get
382+ n -> liftM3 TType get get (replicateM (fromIntegral (n - 7)) get)
383+
384+
385+instance Binary AliasType where
386+ put aliasType =
387+ case aliasType of
388+ Holey tipe -> putWord8 0 >> put tipe
389+ Filled tipe -> putWord8 1 >> put tipe
390+
391+ get =
392+ do n <- getWord8
393+ case n of
394+ 0 -> liftM Holey get
395+ 1 -> liftM Filled get
396+ _ -> fail "binary encoding of AliasType was corrupted"
397+
398+
399+instance Binary FieldType where
400+ get = liftM2 FieldType get get
401+ put (FieldType a b) = put a >> put b
compiler/src/AST/Optimized.hsnew file+451
@@ -0,0 +1,451 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Optimized
3+ ( Def(..)
4+ , Expr(..)
5+ , Global(..)
6+ , Path(..)
7+ , Destructor(..)
8+ , Decider(..)
9+ , Choice(..)
10+ , GlobalGraph(..)
11+ , LocalGraph(..)
12+ , Main(..)
13+ , Node(..)
14+ , EffectsType(..)
15+ , empty
16+ , addGlobalGraph
17+ , addLocalGraph
18+ , addKernel
19+ , toKernelGlobal
20+ )
21+ where
22+
23+
24+import Control.Monad (liftM, liftM2, liftM3, liftM4)
25+import Data.Binary (Binary, get, put, getWord8, putWord8)
26+import qualified Data.Map as Map
27+import qualified Data.Name as Name
28+import Data.Name (Name)
29+import qualified Data.Set as Set
30+
31+import qualified AST.Canonical as Can
32+import qualified AST.Utils.Shader as Shader
33+import 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
37+import qualified Elm.Package as Pkg
38+import qualified Elm.String as ES
39+import qualified Optimize.DecisionTree as DT
40+import qualified Reporting.Annotation as A
41+
42+
43+
44+-- EXPRESSIONS
45+
46+
47+data Expr
48+ = Bool Bool
49+ | Chr ES.String
50+ | Str ES.String
51+ | Int Int
52+ | Float EF.Float
53+ | VarLocal Name
54+ | VarGlobal Global
55+ | VarEnum Global Index.ZeroBased
56+ | VarBox Global
57+ | VarCycle ModuleName.Canonical Name
58+ | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)
59+ | VarKernel Name Name
60+ | List [Expr]
61+ | Function [Name] Expr
62+ | Call Expr [Expr]
63+ | TailCall Name [(Name, Expr)]
64+ | If [(Expr, Expr)] Expr
65+ | Let Def Expr
66+ | 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)
72+ | Unit
73+ | Tuple Expr Expr (Maybe Expr)
74+ | Shader Shader.Source (Set.Set Name) (Set.Set Name)
75+
76+
77+data Global = Global ModuleName.Canonical Name
78+
79+
80+
81+-- DEFINITIONS
82+
83+
84+data Def
85+ = Def Name Expr
86+ | TailDef Name [Name] Expr
87+
88+
89+data Destructor =
90+ Destructor Name Path
91+
92+
93+data Path
94+ = Index Index.ZeroBased Path
95+ | Field Name Path
96+ | Unbox Path
97+ | Root Name
98+
99+
100+
101+-- BRANCHING
102+
103+
104+data Decider a
105+ = Leaf a
106+ | Chain
107+ { _testChain :: [(DT.Path, DT.Test)]
108+ , _success :: Decider a
109+ , _failure :: Decider a
110+ }
111+ | FanOut
112+ { _path :: DT.Path
113+ , _tests :: [(DT.Test, Decider a)]
114+ , _fallback :: Decider a
115+ }
116+ deriving (Eq)
117+
118+
119+data Choice
120+ = Inline Expr
121+ | Jump Int
122+
123+
124+
125+-- OBJECT GRAPH
126+
127+
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
140+ }
141+
142+
143+data Main
144+ = Static
145+ | Dynamic
146+ { _message :: Can.Type
147+ , _decoder :: Expr
148+ }
149+
150+
151+data Node
152+ = Define Expr (Set.Set Global)
153+ | DefineTailFunc [Name] Expr (Set.Set Global)
154+ | Ctor Index.ZeroBased Int
155+ | Enum Index.ZeroBased
156+ | Box
157+ | Link Global
158+ | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)
159+ | Manager EffectsType
160+ | Kernel [K.Chunk] (Set.Set Global)
161+ | PortIncoming Expr (Set.Set Global)
162+ | PortOutgoing Expr (Set.Set Global)
163+
164+
165+data EffectsType = Cmd | Sub | Fx
166+
167+
168+
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
226+
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
239+
240+
241+
242+-- BINARY
243+
244+
245+instance Binary Global where
246+ get = liftM2 Global get get
247+ put (Global a b) = put a >> put b
248+
249+
250+instance Binary Expr where
251+ put expr =
252+ case expr of
253+ Bool a -> putWord8 0 >> put a
254+ Chr a -> putWord8 1 >> put a
255+ Str a -> putWord8 2 >> put a
256+ Int a -> putWord8 3 >> put a
257+ Float a -> putWord8 4 >> put a
258+ VarLocal a -> putWord8 5 >> put a
259+ VarGlobal a -> putWord8 6 >> put a
260+ VarEnum a b -> putWord8 7 >> put a >> put b
261+ VarBox a -> putWord8 8 >> put a
262+ VarCycle a b -> putWord8 9 >> put a >> put b
263+ VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d
264+ VarKernel a b -> putWord8 11 >> put a >> put b
265+ List a -> putWord8 12 >> put a
266+ Function a b -> putWord8 13 >> put a >> put b
267+ Call a b -> putWord8 14 >> put a >> put b
268+ TailCall a b -> putWord8 15 >> put a >> put b
269+ If a b -> putWord8 16 >> put a >> put b
270+ Let a b -> putWord8 17 >> put a >> put b
271+ Destruct a b -> putWord8 18 >> put a >> put b
272+ Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d
273+ Accessor a -> putWord8 20 >> put a
274+ Access a b -> putWord8 21 >> put a >> put b
275+ Update a b -> putWord8 22 >> put a >> put b
276+ Record a -> putWord8 23 >> put a
277+ Unit -> putWord8 24
278+ 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
280+
281+ get =
282+ do word <- getWord8
283+ case word of
284+ 0 -> liftM Bool get
285+ 1 -> liftM Chr get
286+ 2 -> liftM Str get
287+ 3 -> liftM Int get
288+ 4 -> liftM Float get
289+ 5 -> liftM VarLocal get
290+ 6 -> liftM VarGlobal get
291+ 7 -> liftM2 VarEnum get get
292+ 8 -> liftM VarBox get
293+ 9 -> liftM2 VarCycle get get
294+ 10 -> liftM4 VarDebug get get get get
295+ 11 -> liftM2 VarKernel get get
296+ 12 -> liftM List get
297+ 13 -> liftM2 Function get get
298+ 14 -> liftM2 Call get get
299+ 15 -> liftM2 TailCall get get
300+ 16 -> liftM2 If get get
301+ 17 -> liftM2 Let get get
302+ 18 -> liftM2 Destruct get get
303+ 19 -> liftM4 Case get get get get
304+ 20 -> liftM Accessor get
305+ 21 -> liftM2 Access get get
306+ 22 -> liftM2 Update get get
307+ 23 -> liftM Record get
308+ 24 -> pure Unit
309+ 25 -> liftM3 Tuple get get get
310+ 26 -> liftM3 Shader get get get
311+ _ -> fail "problem getting Opt.Expr binary"
312+
313+
314+instance Binary Def where
315+ put def =
316+ case def of
317+ Def a b -> putWord8 0 >> put a >> put b
318+ TailDef a b c -> putWord8 1 >> put a >> put b >> put c
319+
320+ get =
321+ do word <- getWord8
322+ case word of
323+ 0 -> liftM2 Def get get
324+ 1 -> liftM3 TailDef get get get
325+ _ -> fail "problem getting Opt.Def binary"
326+
327+
328+instance Binary Destructor where
329+ get = liftM2 Destructor get get
330+ put (Destructor a b) = put a >> put b
331+
332+
333+instance Binary Path where
334+ put destructor =
335+ case destructor of
336+ Index a b -> putWord8 0 >> put a >> put b
337+ Field a b -> putWord8 1 >> put a >> put b
338+ Unbox a -> putWord8 2 >> put a
339+ Root a -> putWord8 3 >> put a
340+
341+ get =
342+ do word <- getWord8
343+ case word of
344+ 0 -> liftM2 Index get get
345+ 1 -> liftM2 Field get get
346+ 2 -> liftM Unbox get
347+ 3 -> liftM Root get
348+ _ -> fail "problem getting Opt.Path binary"
349+
350+
351+instance (Binary a) => Binary (Decider a) where
352+ put decider =
353+ case decider of
354+ Leaf a -> putWord8 0 >> put a
355+ Chain a b c -> putWord8 1 >> put a >> put b >> put c
356+ FanOut a b c -> putWord8 2 >> put a >> put b >> put c
357+
358+ get =
359+ do word <- getWord8
360+ case word of
361+ 0 -> liftM Leaf get
362+ 1 -> liftM3 Chain get get get
363+ 2 -> liftM3 FanOut get get get
364+ _ -> fail "problem getting Opt.Decider binary"
365+
366+
367+instance Binary Choice where
368+ put choice =
369+ case choice of
370+ Inline expr -> putWord8 0 >> put expr
371+ Jump index -> putWord8 1 >> put index
372+
373+ get =
374+ do word <- getWord8
375+ case word of
376+ 0 -> liftM Inline get
377+ 1 -> liftM Jump get
378+ _ -> fail "problem getting Opt.Choice binary"
379+
380+
381+
382+instance Binary GlobalGraph where
383+ get = liftM2 GlobalGraph get get
384+ put (GlobalGraph a b) = put a >> put b
385+
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
390+
391+
392+instance Binary Main where
393+ put main =
394+ case main of
395+ Static -> putWord8 0
396+ Dynamic a b -> putWord8 1 >> put a >> put b
397+
398+ get =
399+ do word <- getWord8
400+ case word of
401+ 0 -> return Static
402+ 1 -> liftM2 Dynamic get get
403+ _ -> fail "problem getting Opt.Main binary"
404+
405+
406+instance Binary Node where
407+ put node =
408+ case node of
409+ Define a b -> putWord8 0 >> put a >> put b
410+ DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
411+ Ctor a b -> putWord8 2 >> put a >> put b
412+ Enum a -> putWord8 3 >> put a
413+ Box -> putWord8 4
414+ Link a -> putWord8 5 >> put a
415+ Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d
416+ Manager a -> putWord8 7 >> put a
417+ Kernel a b -> putWord8 8 >> put a >> put b
418+ PortIncoming a b -> putWord8 9 >> put a >> put b
419+ PortOutgoing a b -> putWord8 10 >> put a >> put b
420+
421+ get =
422+ do word <- getWord8
423+ case word of
424+ 0 -> liftM2 Define get get
425+ 1 -> liftM3 DefineTailFunc get get get
426+ 2 -> liftM2 Ctor get get
427+ 3 -> liftM Enum get
428+ 4 -> return Box
429+ 5 -> liftM Link get
430+ 6 -> liftM4 Cycle get get get get
431+ 7 -> liftM Manager get
432+ 8 -> liftM2 Kernel get get
433+ 9 -> liftM2 PortIncoming get get
434+ 10 -> liftM2 PortOutgoing get get
435+ _ -> fail "problem getting Opt.Node binary"
436+
437+
438+instance Binary EffectsType where
439+ put effectsType =
440+ case effectsType of
441+ Cmd -> putWord8 0
442+ Sub -> putWord8 1
443+ Fx -> putWord8 2
444+
445+ get =
446+ do word <- getWord8
447+ case word of
448+ 0 -> return Cmd
449+ 1 -> return Sub
450+ 2 -> return Fx
451+ _ -> fail "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hsnew file+209
@@ -0,0 +1,209 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Source
3+ ( Expr, Expr_(..), VarType(..)
4+ , Def(..)
5+ , Pattern, Pattern_(..)
6+ , Type, Type_(..)
7+ , Module(..)
8+ , getName
9+ , getImportName
10+ , Import(..)
11+ , Value(..)
12+ , Union(..)
13+ , Alias(..)
14+ , Infix(..)
15+ , Port(..)
16+ , Effects(..)
17+ , Manager(..)
18+ , Docs(..)
19+ , Comment(..)
20+ , Exposing(..)
21+ , Exposed(..)
22+ , Privacy(..)
23+ )
24+ where
25+
26+
27+import Data.Name (Name)
28+import qualified Data.Name as Name
29+
30+import qualified AST.Utils.Binop as Binop
31+import 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
35+import qualified Reporting.Annotation as A
36+
37+
38+
39+-- EXPRESSIONS
40+
41+
42+type Expr = A.Located Expr_
43+
44+
45+data Expr_
46+ = Chr ES.String
47+ | Str ES.String
48+ | Int Int
49+ | Float EF.Float
50+ | Var VarType Name
51+ | VarQual VarType Name Name
52+ | List [Expr]
53+ | Op Name
54+ | Negate Expr
55+ | Binops [(Expr, A.Located Name)] Expr
56+ | Lambda [Pattern] Expr
57+ | Call Expr [Expr]
58+ | If [(Expr, Expr)] Expr
59+ | Let [A.Located Def] Expr
60+ | 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)]
65+ | Unit
66+ | Tuple Expr Expr [Expr]
67+ | Shader Shader.Source Shader.Types
68+
69+
70+data VarType = LowVar | CapVar
71+
72+
73+
74+-- DEFINITIONS
75+
76+
77+data Def
78+ = Define (A.Located Name) [Pattern] Expr (Maybe Type)
79+ | Destruct Pattern Expr
80+
81+
82+
83+-- PATTERN
84+
85+
86+type Pattern = A.Located Pattern_
87+
88+
89+data Pattern_
90+ = PAnything
91+ | PVar Name
92+ | PRecord [A.Located Name]
93+ | PAlias Pattern (A.Located Name)
94+ | PUnit
95+ | PTuple Pattern Pattern [Pattern]
96+ | PCtor A.Region Name [Pattern]
97+ | PCtorQual A.Region Name Name [Pattern]
98+ | PList [Pattern]
99+ | PCons Pattern Pattern
100+ | PChr ES.String
101+ | PStr ES.String
102+ | PInt Int
103+
104+
105+
106+-- TYPE
107+
108+
109+type Type =
110+ A.Located Type_
111+
112+
113+data Type_
114+ = 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))
119+ | TUnit
120+ | TTuple Type Type [Type]
121+
122+
123+
124+-- MODULE
125+
126+
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+ }
139+
140+
141+getName :: Module -> Name
142+getName (Module maybeName _ _ _ _ _ _ _ _) =
143+ case maybeName of
144+ Just (A.At _ name) ->
145+ name
146+
147+ Nothing ->
148+ Name._Main
149+
150+
151+getImportName :: Import -> Name
152+getImportName (Import (A.At _ name) _ _) =
153+ name
154+
155+
156+data Import =
157+ Import
158+ { _import :: A.Located Name
159+ , _alias :: Maybe Name
160+ , _exposing :: Exposing
161+ }
162+
163+
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
169+
170+
171+data Effects
172+ = NoEffects
173+ | Ports [Port]
174+ | Manager A.Region Manager
175+
176+
177+data 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
190+
191+
192+
193+-- EXPOSING
194+
195+
196+data Exposing
197+ = Open
198+ | Explicit [Exposed]
199+
200+
201+data Exposed
202+ = Lower (A.Located Name)
203+ | Upper (A.Located Name) Privacy
204+ | Operator A.Region Name
205+
206+
207+data Privacy
208+ = Public A.Region
209+ | Private
compiler/src/AST/Utils/Binop.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Utils.Binop
3+ ( Precedence(..)
4+ , Associativity(..)
5+ )
6+ where
7+
8+
9+import Prelude hiding (Either(..))
10+import Control.Monad (liftM)
11+import Data.Binary
12+
13+
14+
15+-- BINOP STUFF
16+
17+
18+newtype Precedence = Precedence Int
19+ deriving (Eq, Ord)
20+
21+
22+data Associativity
23+ = Left
24+ | Non
25+ | Right
26+ deriving (Eq)
27+
28+
29+
30+-- BINARY
31+
32+
33+instance Binary Precedence where
34+ get =
35+ liftM Precedence get
36+
37+ put (Precedence n) =
38+ put n
39+
40+
41+instance Binary Associativity where
42+ get =
43+ 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"
49+
50+ put assoc =
51+ putWord8 $
52+ case assoc of
53+ Left -> 0
54+ Non -> 1
55+ Right -> 2
compiler/src/AST/Utils/Shader.hsnew file+91
@@ -0,0 +1,91 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+module AST.Utils.Shader
4+ ( Source
5+ , Types(..)
6+ , Type(..)
7+ , fromChars
8+ , toJsStringBuilder
9+ )
10+ where
11+
12+
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
18+import qualified Data.Map as Map
19+import qualified Data.Name as Name
20+
21+
22+
23+-- SOURCE
24+
25+
26+newtype Source =
27+ Source BS.ByteString
28+
29+
30+
31+-- TYPES
32+
33+
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+ }
40+
41+
42+data Type
43+ = Int
44+ | Float
45+ | V2
46+ | V3
47+ | V4
48+ | M4
49+ | 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.hsnew file+125
@@ -0,0 +1,125 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Utils.Type
3+ ( delambda
4+ , dealias
5+ , deepDealias
6+ , iteratedDealias
7+ )
8+ where
9+
10+
11+import qualified Data.Map as Map
12+import qualified Data.Name as Name
13+
14+import AST.Canonical (Type(..), AliasType(..), FieldType(..))
15+
16+
17+
18+-- DELAMBDA
19+
20+
21+delambda :: Type -> [Type]
22+delambda tipe =
23+ case tipe of
24+ TLambda arg result ->
25+ arg : delambda result
26+
27+ _ ->
28+ [tipe]
29+
30+
31+
32+-- DEALIAS
33+
34+
35+dealias :: [(Name.Name, Type)] -> AliasType -> Type
36+dealias args aliasType =
37+ case aliasType of
38+ Holey tipe ->
39+ dealiasHelp (Map.fromList args) tipe
40+
41+ Filled tipe ->
42+ tipe
43+
44+
45+dealiasHelp :: Map.Map Name.Name Type -> Type -> Type
46+dealiasHelp typeTable tipe =
47+ case tipe of
48+ TLambda a b ->
49+ TLambda
50+ (dealiasHelp typeTable a)
51+ (dealiasHelp typeTable b)
52+
53+ TVar x ->
54+ Map.findWithDefault tipe x typeTable
55+
56+ TRecord fields ext ->
57+ TRecord (Map.map (dealiasField typeTable) fields) ext
58+
59+ TAlias home name args t' ->
60+ TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'
61+
62+ TType home name args ->
63+ TType home name (map (dealiasHelp typeTable) args)
64+
65+ TUnit ->
66+ TUnit
67+
68+ TTuple a b maybeC ->
69+ TTuple
70+ (dealiasHelp typeTable a)
71+ (dealiasHelp typeTable b)
72+ (fmap (dealiasHelp typeTable) maybeC)
73+
74+
75+dealiasField :: Map.Map Name.Name Type -> FieldType -> FieldType
76+dealiasField typeTable (FieldType index tipe) =
77+ FieldType index (dealiasHelp typeTable tipe)
78+
79+
80+
81+-- DEEP DEALIAS
82+
83+
84+deepDealias :: Type -> Type
85+deepDealias tipe =
86+ case tipe of
87+ TLambda a b ->
88+ TLambda (deepDealias a) (deepDealias b)
89+
90+ TVar _ ->
91+ tipe
92+
93+ TRecord fields ext ->
94+ TRecord (Map.map deepDealiasField fields) ext
95+
96+ TAlias _ _ args tipe' ->
97+ deepDealias (dealias args tipe')
98+
99+ TType home name args ->
100+ TType home name (map deepDealias args)
101+
102+ TUnit ->
103+ TUnit
104+
105+ TTuple a b c ->
106+ TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)
107+
108+
109+deepDealiasField :: FieldType -> FieldType
110+deepDealiasField (FieldType index tipe) =
111+ FieldType index (deepDealias tipe)
112+
113+
114+
115+-- ITERATED DEALIAS
116+
117+
118+iteratedDealias :: Type -> Type
119+iteratedDealias tipe =
120+ case tipe of
121+ TAlias _ _ args realType ->
122+ iteratedDealias (dealias args realType)
123+
124+ _ ->
125+ tipe
compiler/src/Canonicalize/Effects.hsnew file+251
@@ -0,0 +1,251 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Effects
4+ ( canonicalize
5+ , checkPayload
6+ )
7+ where
8+
9+import qualified Data.Foldable as F
10+import qualified Data.Map as Map
11+import qualified Data.Name as Name
12+
13+import qualified AST.Canonical as Can
14+import qualified AST.Source as Src
15+import qualified AST.Utils.Type as Type
16+import qualified Canonicalize.Environment as Env
17+import qualified Canonicalize.Type as Type
18+import qualified Elm.ModuleName as ModuleName
19+import qualified Reporting.Annotation as A
20+import qualified Reporting.Error.Canonicalize as Error
21+import qualified Reporting.Result as Result
22+
23+
24+
25+-- RESULT
26+
27+
28+type Result i w a =
29+ Result.Result i w Error.Error a
30+
31+
32+
33+-- CANONICALIZE
34+
35+
36+canonicalize
37+ :: Env.Env
38+ -> [A.Located Src.Value]
39+ -> Map.Map Name.Name union
40+ -> Src.Effects
41+ -> Result i w Can.Effects
42+canonicalize env values unions effects =
43+ case effects of
44+ Src.NoEffects ->
45+ Result.ok Can.NoEffects
46+
47+ Src.Ports ports ->
48+ do pairs <- traverse (canonicalizePort env) ports
49+ return $ Can.Ports (Map.fromList pairs)
50+
51+ Src.Manager region manager ->
52+ let dict = Map.fromList (map toNameRegion values) in
53+ Can.Manager
54+ <$> verifyManager region dict "init"
55+ <*> verifyManager region dict "onEffects"
56+ <*> verifyManager region dict "onSelfMsg"
57+ <*>
58+ case manager of
59+ Src.Cmd cmdType ->
60+ Can.Cmd
61+ <$> verifyEffectType cmdType unions
62+ <* verifyManager region dict "cmdMap"
63+
64+ Src.Sub subType ->
65+ Can.Sub
66+ <$> verifyEffectType subType unions
67+ <* verifyManager region dict "subMap"
68+
69+ Src.Fx cmdType subType ->
70+ Can.Fx
71+ <$> verifyEffectType cmdType unions
72+ <*> verifyEffectType subType unions
73+ <* verifyManager region dict "cmdMap"
74+ <* verifyManager region dict "subMap"
75+
76+
77+
78+-- CANONICALIZE PORT
79+
80+
81+canonicalizePort :: Env.Env -> Src.Port -> Result i w (Name.Name, Can.Port)
82+canonicalizePort env (Src.Port (A.At region portName) tipe) =
83+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
84+ case reverse (Type.delambda (Type.deepDealias ctipe)) of
85+ Can.TType home name [msg] : revArgs
86+ | home == ModuleName.cmd && name == Name.cmd ->
87+ case revArgs of
88+ [] ->
89+ Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg)
90+
91+ [outgoingType] ->
92+ case msg of
93+ Can.TVar _ ->
94+ case checkPayload outgoingType of
95+ Right () ->
96+ Result.ok (portName, Can.Outgoing freeVars outgoingType ctipe)
97+
98+ Left (badType, err) ->
99+ Result.throw (Error.PortPayloadInvalid region portName badType err)
100+
101+ _ ->
102+ Result.throw (Error.PortTypeInvalid region portName Error.CmdBadMsg)
103+
104+ _ ->
105+ Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs)))
106+
107+ | home == ModuleName.sub && name == Name.sub ->
108+ case revArgs of
109+ [Can.TLambda incomingType (Can.TVar msg1)] ->
110+ case msg of
111+ Can.TVar msg2 | msg1 == msg2 ->
112+ case checkPayload incomingType of
113+ Right () ->
114+ Result.ok (portName, Can.Incoming freeVars incomingType ctipe)
115+
116+ Left (badType, err) ->
117+ Result.throw (Error.PortPayloadInvalid region portName badType err)
118+
119+ _ ->
120+ Result.throw (Error.PortTypeInvalid region portName Error.SubBad)
121+
122+ _ ->
123+ Result.throw (Error.PortTypeInvalid region portName Error.SubBad)
124+
125+ _ ->
126+ Result.throw (Error.PortTypeInvalid region portName Error.NotCmdOrSub)
127+
128+
129+
130+-- VERIFY MANAGER
131+
132+
133+verifyEffectType :: A.Located Name.Name -> Map.Map Name.Name a -> Result i w Name.Name
134+verifyEffectType (A.At region name) unions =
135+ if Map.member name unions then
136+ Result.ok name
137+ else
138+ Result.throw (Error.EffectNotFound region name)
139+
140+
141+toNameRegion :: A.Located Src.Value -> (Name.Name, A.Region)
142+toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) =
143+ (name, region)
144+
145+
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
149+ Just region ->
150+ Result.ok region
151+
152+ Nothing ->
153+ Result.throw (Error.EffectFunctionNotFound tagRegion name)
154+
155+
156+
157+-- CHECK PAYLOAD TYPES
158+
159+
160+checkPayload :: Can.Type -> Either (Can.Type, Error.InvalidPayload) ()
161+checkPayload tipe =
162+ case tipe of
163+ Can.TAlias _ _ args aliasedType ->
164+ checkPayload (Type.dealias args aliasedType)
165+
166+ Can.TType home name args ->
167+ case args of
168+ []
169+ | isJson home name -> Right ()
170+ | isString home name -> Right ()
171+ | isIntFloatBool home name -> Right ()
172+
173+ [arg]
174+ | isList home name -> checkPayload arg
175+ | isMaybe home name -> checkPayload arg
176+ | isArray home name -> checkPayload arg
177+
178+ _ ->
179+ Left (tipe, Error.UnsupportedType name)
180+
181+ Can.TUnit ->
182+ Right ()
183+
184+ Can.TTuple a b maybeC ->
185+ do checkPayload a
186+ checkPayload b
187+ case maybeC of
188+ Nothing ->
189+ Right ()
190+
191+ Just c ->
192+ checkPayload c
193+
194+ Can.TVar name ->
195+ Left (tipe, Error.TypeVariable name)
196+
197+ Can.TLambda _ _ ->
198+ Left (tipe, Error.Function)
199+
200+ Can.TRecord _ (Just _) ->
201+ Left (tipe, Error.ExtendedRecord)
202+
203+ Can.TRecord fields Nothing ->
204+ F.traverse_ checkFieldPayload fields
205+
206+
207+checkFieldPayload :: Can.FieldType -> Either (Can.Type, Error.InvalidPayload) ()
208+checkFieldPayload (Can.FieldType _ tipe) =
209+ checkPayload tipe
210+
211+
212+isIntFloatBool :: ModuleName.Canonical -> Name.Name -> Bool
213+isIntFloatBool home name =
214+ home == ModuleName.basics
215+ &&
216+ (name == Name.int || name == Name.float || name == Name.bool)
217+
218+
219+isString :: ModuleName.Canonical -> Name.Name -> Bool
220+isString home name =
221+ home == ModuleName.string
222+ &&
223+ name == Name.string
224+
225+
226+isJson :: ModuleName.Canonical -> Name.Name -> Bool
227+isJson home name =
228+ home == ModuleName.jsonEncode
229+ &&
230+ name == Name.value
231+
232+
233+isList :: ModuleName.Canonical -> Name.Name -> Bool
234+isList home name =
235+ home == ModuleName.list
236+ &&
237+ name == Name.list
238+
239+
240+isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
241+isMaybe home name =
242+ home == ModuleName.maybe
243+ &&
244+ name == Name.maybe
245+
246+
247+isArray :: ModuleName.Canonical -> Name.Name -> Bool
248+isArray home name =
249+ home == ModuleName.array
250+ &&
251+ name == Name.array
compiler/src/Canonicalize/Environment.hsnew file+275
@@ -0,0 +1,275 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment
4+ ( Env(..)
5+ , Exposed
6+ , Qualified
7+ , Info(..)
8+ , mergeInfo
9+ , Var(..)
10+ , Type(..)
11+ , Ctor(..)
12+ , addLocals
13+ , findType
14+ , findTypeQual
15+ , findCtor
16+ , findCtorQual
17+ , findBinop
18+ , Binop(..)
19+ )
20+ where
21+
22+
23+import qualified Data.Map.Merge.Strict as Map
24+import qualified Data.Map.Strict as Map
25+import qualified Data.Name as Name
26+import qualified Data.OneOrMore as OneOrMore
27+
28+import qualified AST.Utils.Binop as Binop
29+import qualified AST.Canonical as Can
30+import qualified Data.Index as Index
31+import qualified Elm.ModuleName as ModuleName
32+import qualified Reporting.Annotation as A
33+import qualified Reporting.Error.Canonicalize as Error
34+import qualified Reporting.Result as Result
35+
36+
37+
38+-- RESULT
39+
40+
41+type Result i w a =
42+ Result.Result i w Error.Error a
43+
44+
45+
46+-- ENVIRONMENT
47+
48+
49+data Env =
50+ Env
51+ { _home :: ModuleName.Canonical
52+ , _vars :: Map.Map Name.Name Var
53+ , _types :: Exposed Type
54+ , _ctors :: Exposed Ctor
55+ , _binops :: Exposed Binop
56+ , _q_vars :: Qualified Can.Annotation
57+ , _q_types :: Qualified Type
58+ , _q_ctors :: Qualified Ctor
59+ }
60+
61+
62+type Exposed a =
63+ Map.Map Name.Name (Info a)
64+
65+
66+type 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))
91+
92+
93+
94+-- VARIABLES
95+
96+
97+data Var
98+ = Local A.Region
99+ | TopLevel A.Region
100+ | Foreign ModuleName.Canonical Can.Annotation
101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
102+
103+
104+
105+-- TYPES
106+
107+
108+data Type
109+ = Alias Int ModuleName.Canonical [Name.Name] Can.Type
110+ | Union Int ModuleName.Canonical
111+
112+
113+
114+-- CTORS
115+
116+
117+data Ctor
118+ = RecordCtor ModuleName.Canonical [Name.Name] Can.Type
119+ | Ctor
120+ { _c_home :: ModuleName.Canonical
121+ , _c_type :: Name.Name
122+ , _c_union :: Can.Union
123+ , _c_index :: Index.ZeroBased
124+ , _c_args :: [Can.Type]
125+ }
126+
127+
128+
129+-- BINOPS
130+
131+
132+data Binop =
133+ Binop
134+ { _op :: Name.Name
135+ , _op_home :: ModuleName.Canonical
136+ , _op_name :: Name.Name
137+ , _op_annotation :: Can.Annotation
138+ , _op_associativity :: Binop.Associativity
139+ , _op_precedence :: Binop.Precedence
140+ }
141+
142+
143+
144+-- VARIABLE -- ADD LOCALS
145+
146+
147+addLocals :: Map.Map Name.Name A.Region -> Env -> Result i w Env
148+addLocals names (Env home vars ts cs bs qvs qts qcs) =
149+ do newVars <-
150+ Map.mergeA
151+ (Map.mapMissing addLocalLeft)
152+ (Map.mapMissing (\_ homes -> homes))
153+ (Map.zipWithAMatched addLocalBoth)
154+ names
155+ vars
156+
157+ Result.ok (Env home newVars ts cs bs qvs qts qcs)
158+
159+
160+addLocalLeft :: Name.Name -> A.Region -> Var
161+addLocalLeft _ region =
162+ Local region
163+
164+
165+addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
166+addLocalBoth name region var =
167+ case var of
168+ Foreign _ _ ->
169+ Result.ok (Local region)
170+
171+ Foreigns _ _ ->
172+ Result.ok (Local region)
173+
174+ Local parentRegion ->
175+ Result.throw (Error.Shadowing name parentRegion region)
176+
177+ TopLevel parentRegion ->
178+ Result.throw (Error.Shadowing name parentRegion region)
179+
180+
181+
182+
183+-- FIND TYPE
184+
185+
186+findType :: A.Region -> Env -> Name.Name -> Result i w Type
187+findType region (Env _ _ ts _ _ _ qts _) name =
188+ case Map.lookup name ts of
189+ Just (Specific _ tipe) ->
190+ Result.ok tipe
191+
192+ Just (Ambiguous h hs) ->
193+ Result.throw (Error.AmbiguousType region Nothing name h hs)
194+
195+ Nothing ->
196+ Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
197+
198+
199+findTypeQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Type
200+findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
201+ case Map.lookup prefix qts of
202+ Just qualified ->
203+ case Map.lookup name qualified of
204+ Just (Specific _ tipe) ->
205+ Result.ok tipe
206+
207+ Just (Ambiguous h hs) ->
208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
209+
210+ Nothing ->
211+ Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
212+
213+ Nothing ->
214+ Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
215+
216+
217+
218+-- FIND CTOR
219+
220+
221+findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
222+findCtor region (Env _ _ _ cs _ _ _ qcs) name =
223+ case Map.lookup name cs of
224+ Just (Specific _ ctor) ->
225+ Result.ok ctor
226+
227+ Just (Ambiguous h hs) ->
228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)
229+
230+ Nothing ->
231+ Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
232+
233+
234+findCtorQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Ctor
235+findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
236+ case Map.lookup prefix qcs of
237+ Just qualified ->
238+ case Map.lookup name qualified of
239+ Just (Specific _ pattern) ->
240+ Result.ok pattern
241+
242+ Just (Ambiguous h hs) ->
243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
244+
245+ Nothing ->
246+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
247+
248+ Nothing ->
249+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
250+
251+
252+
253+-- FIND BINOP
254+
255+
256+findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
257+findBinop region (Env _ _ _ _ binops _ _ _) name =
258+ case Map.lookup name binops of
259+ Just (Specific _ binop) ->
260+ Result.ok binop
261+
262+ Just (Ambiguous h hs) ->
263+ Result.throw (Error.AmbiguousBinop region name h hs)
264+
265+ Nothing ->
266+ Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
267+
268+
269+
270+-- TO POSSIBLE NAMES
271+
272+
273+toPossibleNames :: Exposed a -> Qualified a -> Error.PossibleNames
274+toPossibleNames exposed qualified =
275+ Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)
compiler/src/Canonicalize/Environment/Dups.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Dups
4+ ( detect
5+ , checkFields
6+ , checkFields'
7+ , Dict
8+ , none
9+ , one
10+ , insert
11+ , union
12+ , unions
13+ )
14+ where
15+
16+
17+import qualified Data.Map as Map
18+import qualified Data.Name as Name
19+
20+import qualified Data.OneOrMore as OneOrMore
21+import qualified Reporting.Annotation as A
22+import qualified Reporting.Error.Canonicalize as Error
23+import qualified Reporting.Result as Result
24+
25+
26+
27+-- DUPLICATE TRACKER
28+
29+
30+type Dict value =
31+ Map.Map Name.Name (OneOrMore.OneOrMore (Info value))
32+
33+
34+data Info value =
35+ Info
36+ { _region :: A.Region
37+ , _value :: value
38+ }
39+
40+
41+
42+-- DETECT
43+
44+
45+type ToError =
46+ Name.Name -> A.Region -> A.Region -> Error.Error
47+
48+
49+detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name a)
50+detect toError dict =
51+ Map.traverseWithKey (detectHelp toError) dict
52+
53+
54+detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a
55+detectHelp toError name values =
56+ case values of
57+ OneOrMore.One (Info _ value) ->
58+ return value
59+
60+ OneOrMore.More left right ->
61+ let
62+ (Info r1 _, Info r2 _) =
63+ OneOrMore.getFirstTwo left right
64+ in
65+ Result.throw (toError name r1 r2)
66+
67+
68+
69+-- CHECK FIELDS
70+
71+
72+checkFields :: [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name a)
73+checkFields fields =
74+ detect Error.DuplicateField (foldr addField none fields)
75+
76+
77+addField :: (A.Located Name.Name, a) -> Dict a -> Dict a
78+addField (A.At region name, value) dups =
79+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups
80+
81+
82+checkFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name b)
83+checkFields' toValue fields =
84+ detect Error.DuplicateField (foldr (addField' toValue) none fields)
85+
86+
87+addField' :: (A.Region -> a -> b) -> (A.Located Name.Name, a) -> Dict b -> Dict b
88+addField' toValue (A.At region name, value) dups =
89+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups
90+
91+
92+
93+-- BUILDING DICTIONARIES
94+
95+
96+none :: Dict a
97+none =
98+ Map.empty
99+
100+
101+one :: Name.Name -> A.Region -> value -> Dict value
102+one name region value =
103+ Map.singleton name (OneOrMore.one (Info region value))
104+
105+
106+insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
107+insert name region value dict =
108+ Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
109+
110+
111+union :: Dict a -> Dict a -> Dict a
112+union a b =
113+ Map.unionWith OneOrMore.more a b
114+
115+
116+unions :: [Dict a] -> Dict a
117+unions dicts =
118+ Map.unionsWith OneOrMore.more dicts
compiler/src/Canonicalize/Environment/Foreign.hsnew file+304
@@ -0,0 +1,304 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module Canonicalize.Environment.Foreign
5+ ( createInitialEnv
6+ )
7+ where
8+
9+
10+import Control.Monad (foldM)
11+import qualified Data.List as List
12+import qualified Data.Map.Strict as Map
13+import Data.Map.Strict ((!))
14+import qualified Data.Name as Name
15+
16+import qualified AST.Canonical as Can
17+import qualified AST.Source as Src
18+import qualified Canonicalize.Environment as Env
19+import qualified Elm.Interface as I
20+import qualified Elm.ModuleName as ModuleName
21+import qualified Elm.Package as Pkg
22+import qualified Reporting.Annotation as A
23+import qualified Reporting.Error.Canonicalize as Error
24+import qualified Reporting.Result as Result
25+
26+
27+
28+-- RESULT
29+
30+
31+type Result i w a =
32+ Result.Result i w Error.Error a
33+
34+
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)
39+
40+
41+infoToVar :: Env.Info Can.Annotation -> Env.Var
42+infoToVar info =
43+ case info of
44+ Env.Specific home tipe -> Env.Foreign home tipe
45+ Env.Ambiguous h hs -> Env.Foreigns h hs
46+
47+
48+
49+-- STATE
50+
51+
52+data State =
53+ State
54+ { _vars :: Env.Exposed Can.Annotation
55+ , _types :: Env.Exposed Env.Type
56+ , _ctors :: Env.Exposed Env.Ctor
57+ , _binops :: Env.Exposed Env.Binop
58+ , _q_vars :: Env.Qualified Can.Annotation
59+ , _q_types :: Env.Qualified Env.Type
60+ , _q_ctors :: Env.Qualified Env.Ctor
61+ }
62+
63+
64+emptyState :: State
65+emptyState =
66+ State Map.empty emptyTypes Map.empty Map.empty Map.empty Map.empty Map.empty
67+
68+
69+emptyTypes :: Env.Exposed Env.Type
70+emptyTypes =
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
94+
95+
96+
97+-- ADD IMPORTS
98+
99+
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) =
102+ let
103+ (I.Interface pkg defs unions aliases binops) = ifaces ! name
104+ !prefix = maybe name id maybeAlias
105+ !home = ModuleName.Canonical pkg name
106+
107+ !rawTypeInfo =
108+ Map.union
109+ (Map.mapMaybeWithKey (unionToType home) unions)
110+ (Map.mapMaybeWithKey (aliasToType home) aliases)
111+
112+ !vars = Map.map (Env.Specific home) defs
113+ !types = Map.map (Env.Specific home . fst) rawTypeInfo
114+ !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
115+
116+ !qvs2 = addQualified prefix vars qvs
117+ !qts2 = addQualified prefix types qts
118+ !qcs2 = addQualified prefix ctors qcs
119+ in
120+ case exposing of
121+ Src.Open ->
122+ let
123+ !vs2 = addExposed vs vars
124+ !ts2 = addExposed ts types
125+ !cs2 = addExposed cs ctors
126+ !bs2 = addExposed bs (Map.mapWithKey (binopToBinop home) binops)
127+ in
128+ Result.ok (State vs2 ts2 cs2 bs2 qvs2 qts2 qcs2)
129+
130+ Src.Explicit exposedList ->
131+ foldM
132+ (addExposedValue home vars rawTypeInfo binops)
133+ (State vs ts cs bs qvs2 qts2 qcs2)
134+ exposedList
135+
136+
137+addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
138+addExposed =
139+ Map.unionWith Env.mergeInfo
140+
141+
142+addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
143+addQualified prefix exposed qualified =
144+ Map.insertWith addExposed prefix exposed qualified
145+
146+
147+
148+-- UNION
149+
150+
151+unionToType :: ModuleName.Canonical -> Name.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor)
152+unionToType home name union =
153+ unionToTypeHelp home name <$> I.toPublicUnion union
154+
155+
156+unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
157+unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
158+ let
159+ addCtor dict (Can.Ctor ctor index _ args) =
160+ Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
161+ in
162+ ( Env.Union (length vars) home
163+ , List.foldl' addCtor Map.empty ctors
164+ )
165+
166+
167+
168+-- ALIAS
169+
170+
171+aliasToType :: ModuleName.Canonical -> Name.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor)
172+aliasToType home name alias =
173+ aliasToTypeHelp home name <$> I.toPublicAlias alias
174+
175+
176+aliasToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
177+aliasToTypeHelp home name (Can.Alias vars tipe) =
178+ (
179+ Env.Alias (length vars) home vars tipe
180+ ,
181+ case tipe of
182+ Can.TRecord fields Nothing ->
183+ let
184+ avars = map (\var -> (var, Can.TVar var)) vars
185+ alias =
186+ foldr
187+ (\(_,t1) t2 -> Can.TLambda t1 t2)
188+ (Can.TAlias home name avars (Can.Filled tipe))
189+ (Can.fieldsToList fields)
190+ in
191+ Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
192+
193+ _ ->
194+ Map.empty
195+ )
196+
197+
198+
199+-- BINOP
200+
201+
202+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
203+binopToBinop home op (I.Binop name annotation associativity precedence) =
204+ Env.Specific home (Env.Binop op home name annotation associativity precedence)
205+
206+
207+
208+-- ADD EXPOSED VALUE
209+
210+
211+addExposedValue
212+ :: ModuleName.Canonical
213+ -> Env.Exposed Can.Annotation
214+ -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
215+ -> Map.Map Name.Name I.Binop
216+ -> State
217+ -> Src.Exposed
218+ -> Result i w State
219+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
220+ case exposed of
221+ Src.Lower (A.At region name) ->
222+ case Map.lookup name vars of
223+ Just info ->
224+ Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
225+
226+ Nothing ->
227+ Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
228+
229+ Src.Upper (A.At region name) privacy ->
230+ case privacy of
231+ Src.Private ->
232+ case Map.lookup name types of
233+ Just (tipe, ctors) ->
234+ case tipe of
235+ Env.Union _ _ ->
236+ let
237+ !ts2 = Map.insert name (Env.Specific home tipe) ts
238+ in
239+ Result.ok (State vs ts2 cs bs qvs qts qcs)
240+
241+ Env.Alias _ _ _ _ ->
242+ let
243+ !ts2 = Map.insert name (Env.Specific home tipe) ts
244+ !cs2 = addExposed cs ctors
245+ in
246+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)
247+
248+ Nothing ->
249+ case checkForCtorMistake name types of
250+ tipe:_ ->
251+ Result.throw $ Error.ImportCtorByName region name tipe
252+
253+ [] ->
254+ Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
255+
256+ Src.Public dotDotRegion ->
257+ case Map.lookup name types of
258+ Just (tipe, ctors) ->
259+ case tipe of
260+ Env.Union _ _ ->
261+ let
262+ !ts2 = Map.insert name (Env.Specific home tipe) ts
263+ !cs2 = addExposed cs ctors
264+ in
265+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)
266+
267+ Env.Alias _ _ _ _ ->
268+ Result.throw (Error.ImportOpenAlias dotDotRegion name)
269+
270+ Nothing ->
271+ Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
272+
273+ Src.Operator region op ->
274+ case Map.lookup op binops of
275+ Just binop ->
276+ let
277+ !bs2 = Map.insert op (binopToBinop home op binop) bs
278+ in
279+ Result.ok (State vs ts cs bs2 qvs qts qcs)
280+
281+ Nothing ->
282+ Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
283+
284+
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
288+ 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
compiler/src/Canonicalize/Environment/Local.hsnew file+355
@@ -0,0 +1,355 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Local
4+ ( add
5+ )
6+ where
7+
8+
9+import Control.Monad (foldM)
10+import qualified Data.Graph as Graph
11+import qualified Data.List as List
12+import qualified Data.Map.Strict as Map
13+import qualified Data.Name as Name
14+
15+import qualified AST.Canonical as Can
16+import qualified AST.Source as Src
17+import qualified Canonicalize.Environment as Env
18+import qualified Canonicalize.Environment.Dups as Dups
19+import qualified Canonicalize.Type as Type
20+import qualified Data.Index as Index
21+import qualified Elm.ModuleName as ModuleName
22+import qualified Reporting.Annotation as A
23+import qualified Reporting.Error.Canonicalize as Error
24+import qualified Reporting.Result as Result
25+
26+
27+
28+-- RESULT
29+
30+
31+type Result i w a =
32+ Result.Result i w Error.Error a
33+
34+
35+type Unions = Map.Map Name.Name Can.Union
36+type Aliases = Map.Map Name.Name Can.Alias
37+
38+
39+add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
40+add module_ env =
41+ addCtors module_ =<< addVars module_ =<< addTypes module_ env
42+
43+
44+
45+-- ADD VARS
46+
47+
48+addVars :: Src.Module -> Env.Env -> Result i w Env.Env
49+addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
50+ do topLevelVars <- collectVars module_
51+ let vs2 = Map.union topLevelVars vs
52+ -- Use union to overwrite foreign stuff.
53+ Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
54+
55+
56+collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57+collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
58+ let
59+ addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
60+ Dups.insert name region (Env.TopLevel region) dict
61+ in
62+ Dups.detect Error.DuplicateDecl $
63+ List.foldl' addDecl (toEffectDups effects) values
64+
65+
66+toEffectDups :: Src.Effects -> Dups.Dict Env.Var
67+toEffectDups effects =
68+ case effects of
69+ Src.NoEffects ->
70+ Dups.none
71+
72+ Src.Ports ports ->
73+ let
74+ addPort dict (Src.Port (A.At region name) _) =
75+ Dups.insert name region (Env.TopLevel region) dict
76+ in
77+ List.foldl' addPort Dups.none ports
78+
79+ Src.Manager _ manager ->
80+ case manager of
81+ Src.Cmd (A.At region _) ->
82+ Dups.one "command" region (Env.TopLevel region)
83+
84+ Src.Sub (A.At region _) ->
85+ Dups.one "subscription" region (Env.TopLevel region)
86+
87+ Src.Fx (A.At regionCmd _) (A.At regionSub _) ->
88+ Dups.union
89+ (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
90+ (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
91+
92+
93+
94+-- ADD TYPES
95+
96+
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+ 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+ typeNameDups =
103+ List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
104+ in
105+ do _ <- Dups.detect Error.DuplicateType typeNameDups
106+ ts1 <- foldM (addUnion home) ts unions
107+ addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
108+
109+
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+ do arity <- checkUnionFreeVars union
113+ let one = Env.Specific home (Env.Union arity home)
114+ Result.ok $ Map.insert name one types
115+
116+
117+
118+-- ADD TYPE ALIASES
119+
120+
121+addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env
122+addAliases aliases env =
123+ let
124+ nodes = map toNode aliases
125+ sccs = Graph.stronglyConnComp nodes
126+ in
127+ foldM addAlias env sccs
128+
129+
130+addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env
131+addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
132+ case scc of
133+ Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134+ do args <- checkAliasFreeVars alias
135+ ctype <- Type.canonicalize env tipe
136+ let one = Env.Specific home (Env.Alias (length args) home args ctype)
137+ let ts1 = Map.insert name one ts
138+ Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139+
140+ Graph.CyclicSCC [] ->
141+ Result.ok env
142+
143+ Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) ->
144+ do args <- checkAliasFreeVars alias
145+ let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name
146+ Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
147+
148+
149+
150+-- DETECT TYPE ALIAS CYCLES
151+
152+
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+ ( alias, name, getEdges [] tipe )
156+
157+
158+getEdges :: [Name.Name] -> Src.Type -> [Name.Name]
159+getEdges edges (A.At _ tipe) =
160+ case tipe of
161+ Src.TLambda arg result ->
162+ getEdges (getEdges edges arg) result
163+
164+ Src.TVar _ ->
165+ edges
166+
167+ Src.TType _ name args ->
168+ List.foldl' getEdges (name:edges) args
169+
170+ Src.TTypeQual _ _ _ args ->
171+ List.foldl' getEdges edges args
172+
173+ Src.TRecord fields _ ->
174+ List.foldl' (\es (_,t) -> getEdges es t) edges fields
175+
176+ Src.TUnit ->
177+ edges
178+
179+ Src.TTuple a b cs ->
180+ List.foldl' getEdges (getEdges (getEdges edges a) b) cs
181+
182+
183+
184+-- CHECK FREE VARIABLES
185+
186+
187+checkUnionFreeVars :: A.Located Src.Union -> Result i w Int
188+checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =
189+ let
190+ addArg (A.At region arg) dict =
191+ Dups.insert arg region region dict
192+
193+ addCtorFreeVars (_, tipes) freeVars =
194+ List.foldl' addFreeVars freeVars tipes
195+ in
196+ do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args)
197+ let freeVars = foldr addCtorFreeVars Map.empty ctors
198+ case Map.toList (Map.difference freeVars boundVars) of
199+ [] ->
200+ Result.ok (length args)
201+
202+ unbound:unbounds ->
203+ Result.throw $
204+ Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds
205+
206+
207+checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name]
208+checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =
209+ let
210+ addArg (A.At region arg) dict =
211+ Dups.insert arg region region dict
212+ in
213+ do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args)
214+ let freeVars = addFreeVars Map.empty tipe
215+ let overlap = Map.size (Map.intersection boundVars freeVars)
216+ if Map.size boundVars == overlap && Map.size freeVars == overlap
217+ then Result.ok (map A.toValue args)
218+ else
219+ Result.throw $
220+ Error.TypeVarsMessedUpInAlias aliasRegion name
221+ (map A.toValue args)
222+ (Map.toList (Map.difference boundVars freeVars))
223+ (Map.toList (Map.difference freeVars boundVars))
224+
225+
226+addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region
227+addFreeVars freeVars (A.At region tipe) =
228+ case tipe of
229+ Src.TLambda arg result ->
230+ addFreeVars (addFreeVars freeVars arg) result
231+
232+ Src.TVar name ->
233+ Map.insert name region freeVars
234+
235+ Src.TType _ _ args ->
236+ List.foldl' addFreeVars freeVars args
237+
238+ Src.TTypeQual _ _ _ args ->
239+ List.foldl' addFreeVars freeVars args
240+
241+ Src.TRecord fields maybeExt ->
242+ let
243+ extFreeVars =
244+ case maybeExt of
245+ Nothing ->
246+ freeVars
247+
248+ Just (A.At extRegion ext) ->
249+ Map.insert ext extRegion freeVars
250+ in
251+ List.foldl' (\fvs (_,t) -> addFreeVars fvs t) extFreeVars fields
252+
253+ Src.TUnit ->
254+ freeVars
255+
256+ Src.TTuple a b cs ->
257+ List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs
258+
259+
260+
261+-- ADD CTORS
262+
263+
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+ do unionInfo <- traverse (canonicalizeUnion env) unions
267+ aliasInfo <- traverse (canonicalizeAlias env) aliases
268+
269+ ctors <-
270+ Dups.detect Error.DuplicateCtor $
271+ Dups.union
272+ (Dups.unions (map snd unionInfo))
273+ (Dups.unions (map snd aliasInfo))
274+
275+ let cs2 = Map.union ctors cs
276+
277+ Result.ok
278+ ( Env.Env home vs ts cs2 bs qvs qts qcs
279+ , Map.fromList (map fst unionInfo)
280+ , Map.fromList (map fst aliasInfo)
281+ )
282+
283+
284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)
285+
286+
287+
288+-- CANONICALIZE ALIAS
289+
290+
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+ do let vars = map A.toValue args
294+ ctipe <- Type.canonicalize env tipe
295+ Result.ok
296+ ( (name, Can.Alias vars ctipe)
297+ ,
298+ case ctipe of
299+ Can.TRecord fields Nothing ->
300+ Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
301+
302+ _ ->
303+ Dups.none
304+ )
305+
306+toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor
307+toRecordCtor home name vars fields =
308+ let
309+ avars = map (\var -> (var, Can.TVar var)) vars
310+ alias =
311+ foldr
312+ (\(_,t1) t2 -> Can.TLambda t1 t2)
313+ (Can.TAlias home name avars (Can.Filled (Can.TRecord fields Nothing)))
314+ (Can.fieldsToList fields)
315+ in
316+ Env.RecordCtor home vars alias
317+
318+
319+
320+-- CANONICALIZE UNION
321+
322+
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+ do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
326+ let vars = map A.toValue avars
327+ let alts = map A.toValue cctors
328+ let union = Can.Union vars alts (length alts) (toOpts ctors)
329+ Result.ok
330+ ( (name, union)
331+ , Dups.unions $ map (toCtor home name union) cctors
332+ )
333+
334+
335+canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
336+canonicalizeCtor env index (A.At region ctor, tipes) =
337+ do ctipes <- traverse (Type.canonicalize env) tipes
338+ Result.ok $ A.At region $
339+ Can.Ctor ctor index (length ctipes) ctipes
340+
341+
342+toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts
343+toOpts ctors =
344+ case ctors of
345+ [ (_,[_]) ] ->
346+ Can.Unbox
347+
348+ _ ->
349+ if all (null . snd) ctors then Can.Enum else Can.Normal
350+
351+
352+toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353+toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354+ Dups.one name region $ Env.Specific home $
355+ Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hsnew file+761
@@ -0,0 +1,761 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Expression
4+ ( canonicalize
5+ , FreeLocals
6+ , Uses(..)
7+ , verifyBindings
8+ , gatherTypedArgs
9+ )
10+ where
11+
12+
13+import Control.Monad (foldM)
14+import qualified Data.Graph as Graph
15+import qualified Data.List as List
16+import qualified Data.Map.Strict as Map
17+import qualified Data.Name as Name
18+
19+import qualified AST.Canonical as Can
20+import qualified AST.Source as Src
21+import qualified AST.Utils.Binop as Binop
22+import qualified AST.Utils.Type as Type
23+import qualified Canonicalize.Environment as Env
24+import qualified Canonicalize.Environment.Dups as Dups
25+import qualified Canonicalize.Pattern as Pattern
26+import qualified Canonicalize.Type as Type
27+import qualified Data.Index as Index
28+import qualified Elm.ModuleName as ModuleName
29+import qualified Elm.Package as Pkg
30+import qualified Reporting.Annotation as A
31+import qualified Reporting.Error.Canonicalize as Error
32+import qualified Reporting.Result as Result
33+import qualified Reporting.Warning as W
34+
35+
36+
37+-- RESULTS
38+
39+
40+type Result i w a =
41+ Result.Result i w Error.Error a
42+
43+
44+type FreeLocals =
45+ Map.Map Name.Name Uses
46+
47+
48+data Uses =
49+ Uses
50+ { _direct :: {-# UNPACK #-} !Int
51+ , _delayed :: {-# UNPACK #-} !Int
52+ }
53+
54+
55+
56+-- CANONICALIZE
57+
58+
59+canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
60+canonicalize env (A.At region expression) =
61+ A.At region <$>
62+ case expression of
63+ Src.Str string ->
64+ Result.ok (Can.Str string)
65+
66+ Src.Chr char ->
67+ Result.ok (Can.Chr char)
68+
69+ Src.Int int ->
70+ Result.ok (Can.Int int)
71+
72+ Src.Float float ->
73+ Result.ok (Can.Float float)
74+
75+ Src.Var varType name ->
76+ case varType of
77+ Src.LowVar -> findVar region env name
78+ Src.CapVar -> toVarCtor name <$> Env.findCtor region env name
79+
80+ Src.VarQual varType prefix name ->
81+ case varType of
82+ Src.LowVar -> findVarQual region env prefix name
83+ Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name
84+
85+ Src.List exprs ->
86+ Can.List <$> traverse (canonicalize env) exprs
87+
88+ Src.Op op ->
89+ do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op
90+ return (Can.VarOperator op home name annotation)
91+
92+ Src.Negate expr ->
93+ Can.Negate <$> canonicalize env expr
94+
95+ Src.Binops ops final ->
96+ A.toValue <$> canonicalizeBinops region env ops final
97+
98+ Src.Lambda srcArgs body ->
99+ delayedUsage $
100+ do (args, bindings) <-
101+ Pattern.verify Error.DPLambdaArgs $
102+ traverse (Pattern.canonicalize env) srcArgs
103+
104+ newEnv <-
105+ Env.addLocals bindings env
106+
107+ (cbody, freeLocals) <-
108+ verifyBindings W.Pattern bindings (canonicalize newEnv body)
109+
110+ return (Can.Lambda args cbody, freeLocals)
111+
112+ Src.Call func args ->
113+ Can.Call
114+ <$> canonicalize env func
115+ <*> traverse (canonicalize env) args
116+
117+ Src.If branches finally ->
118+ Can.If
119+ <$> traverse (canonicalizeIfBranch env) branches
120+ <*> canonicalize env finally
121+
122+ Src.Let defs expr ->
123+ A.toValue <$> canonicalizeLet region env defs expr
124+
125+ Src.Case expr branches ->
126+ Can.Case
127+ <$> canonicalize env expr
128+ <*> traverse (canonicalizeCaseBranch env) branches
129+
130+ Src.Accessor field ->
131+ Result.ok $ Can.Accessor field
132+
133+ Src.Access record field ->
134+ Can.Access
135+ <$> canonicalize env record
136+ <*> Result.ok field
137+
138+ Src.Update (A.At reg name) fields ->
139+ let
140+ makeCanFields =
141+ Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields
142+ in
143+ Can.Update name
144+ <$> (A.At reg <$> findVar reg env name)
145+ <*> (sequenceA =<< makeCanFields)
146+
147+ Src.Record fields ->
148+ do fieldDict <- Dups.checkFields fields
149+ Can.Record <$> traverse (canonicalize env) fieldDict
150+
151+ Src.Unit ->
152+ Result.ok Can.Unit
153+
154+ Src.Tuple a b cs ->
155+ Can.Tuple
156+ <$> canonicalize env a
157+ <*> canonicalize env b
158+ <*> canonicalizeTupleExtras region env cs
159+
160+ Src.Shader src tipe ->
161+ Result.ok (Can.Shader src tipe)
162+
163+
164+
165+-- CANONICALIZE TUPLE EXTRAS
166+
167+
168+canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
169+canonicalizeTupleExtras region env extras =
170+ case extras of
171+ [] ->
172+ Result.ok Nothing
173+
174+ [three] ->
175+ Just <$> canonicalize env three
176+
177+ _ ->
178+ Result.throw (Error.TupleLargerThanThree region)
179+
180+
181+
182+-- CANONICALIZE IF BRANCH
183+
184+
185+canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
186+canonicalizeIfBranch env (condition, branch) =
187+ (,)
188+ <$> canonicalize env condition
189+ <*> canonicalize env branch
190+
191+
192+
193+-- CANONICALIZE CASE BRANCH
194+
195+
196+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
197+canonicalizeCaseBranch env (pattern, expr) =
198+ directUsage $
199+ do (cpattern, bindings) <-
200+ Pattern.verify Error.DPCaseBranch $
201+ Pattern.canonicalize env pattern
202+ newEnv <- Env.addLocals bindings env
203+
204+ (cexpr, freeLocals) <-
205+ verifyBindings W.Pattern bindings (canonicalize newEnv expr)
206+
207+ return (Can.CaseBranch cpattern cexpr, freeLocals)
208+
209+
210+
211+-- CANONICALIZE BINOPS
212+
213+
214+canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
215+canonicalizeBinops overallRegion env ops final =
216+ let
217+ canonicalizeHelp (expr, A.At region op) =
218+ (,)
219+ <$> canonicalize env expr
220+ <*> Env.findBinop region env op
221+ in
222+ runBinopStepper overallRegion =<< (
223+ More
224+ <$> traverse canonicalizeHelp ops
225+ <*> canonicalize env final
226+ )
227+
228+
229+data Step
230+ = Done Can.Expr
231+ | More [(Can.Expr, Env.Binop)] Can.Expr
232+ | Error Env.Binop Env.Binop
233+
234+
235+runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr
236+runBinopStepper overallRegion step =
237+ case step of
238+ Done expr ->
239+ Result.ok expr
240+
241+ More [] expr ->
242+ Result.ok expr
243+
244+ More ( (expr, op) : rest ) final ->
245+ runBinopStepper overallRegion $
246+ toBinopStep (toBinop op expr) op rest final
247+
248+ Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) ->
249+ Result.throw (Error.Binop overallRegion op1 op2)
250+
251+
252+toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step
253+toBinopStep makeBinop rootOp@(Env.Binop _ _ _ _ rootAssociativity rootPrecedence) middle final =
254+ case middle of
255+ [] ->
256+ Done (makeBinop final)
257+
258+ ( expr, op@(Env.Binop _ _ _ _ associativity precedence) ) : rest ->
259+ if precedence < rootPrecedence then
260+
261+ More ((makeBinop expr, op) : rest) final
262+
263+ else if precedence > rootPrecedence then
264+
265+ case toBinopStep (toBinop op expr) op rest final of
266+ Done newLast ->
267+ Done (makeBinop newLast)
268+
269+ More newMiddle newLast ->
270+ toBinopStep makeBinop rootOp newMiddle newLast
271+
272+ Error a b ->
273+ Error a b
274+
275+ else
276+
277+ case (rootAssociativity, associativity) of
278+ (Binop.Left, Binop.Left) ->
279+ toBinopStep (\right -> toBinop op (makeBinop expr) right) op rest final
280+
281+ (Binop.Right, Binop.Right) ->
282+ toBinopStep (\right -> makeBinop (toBinop op expr right)) op rest final
283+
284+ (_, _) ->
285+ Error rootOp op
286+
287+
288+toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr
289+toBinop (Env.Binop op home name annotation _ _) left right =
290+ A.merge left right (Can.Binop op home name annotation left right)
291+
292+
293+
294+-- CANONICALIZE LET
295+
296+
297+canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
298+canonicalizeLet letRegion env defs body =
299+ directUsage $
300+ do bindings <-
301+ Dups.detect (Error.DuplicatePattern Error.DPLetBinding) $
302+ List.foldl' addBindings Dups.none defs
303+
304+ newEnv <- Env.addLocals bindings env
305+
306+ verifyBindings W.Def bindings $
307+ do nodes <- foldM (addDefNodes newEnv) [] defs
308+ cbody <- canonicalize newEnv body
309+ detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
310+
311+
312+
313+-- ADD BINDINGS
314+
315+
316+addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region
317+addBindings bindings (A.At _ def) =
318+ case def of
319+ Src.Define (A.At region name) _ _ _ ->
320+ Dups.insert name region region bindings
321+
322+ Src.Destruct pattern _ ->
323+ addBindingsHelp bindings pattern
324+
325+
326+addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region
327+addBindingsHelp bindings (A.At region pattern) =
328+ case pattern of
329+ Src.PAnything ->
330+ bindings
331+
332+ Src.PVar name ->
333+ Dups.insert name region region bindings
334+
335+ Src.PRecord fields ->
336+ let
337+ addField dict (A.At fieldRegion name) =
338+ Dups.insert name fieldRegion fieldRegion dict
339+ in
340+ List.foldl' addField bindings fields
341+
342+ Src.PUnit ->
343+ bindings
344+
345+ Src.PTuple a b cs ->
346+ List.foldl' addBindingsHelp bindings (a:b:cs)
347+
348+ Src.PCtor _ _ patterns ->
349+ List.foldl' addBindingsHelp bindings patterns
350+
351+ Src.PCtorQual _ _ _ patterns ->
352+ List.foldl' addBindingsHelp bindings patterns
353+
354+ Src.PList patterns ->
355+ List.foldl' addBindingsHelp bindings patterns
356+
357+ Src.PCons hd tl ->
358+ addBindingsHelp (addBindingsHelp bindings hd) tl
359+
360+ Src.PAlias aliasPattern (A.At nameRegion name) ->
361+ Dups.insert name nameRegion nameRegion $
362+ addBindingsHelp bindings aliasPattern
363+
364+ Src.PChr _ ->
365+ bindings
366+
367+ Src.PStr _ ->
368+ bindings
369+
370+ Src.PInt _ ->
371+ bindings
372+
373+
374+
375+-- BUILD BINDINGS GRAPH
376+
377+
378+type Node =
379+ (Binding, Name.Name, [Name.Name])
380+
381+
382+data Binding
383+ = Define Can.Def
384+ | Edge (A.Located Name.Name)
385+ | Destruct Can.Pattern Can.Expr
386+
387+
388+addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node]
389+addDefNodes env nodes (A.At _ def) =
390+ case def of
391+ Src.Define aname@(A.At _ name) srcArgs body maybeType ->
392+ case maybeType of
393+ Nothing ->
394+ do (args, argBindings) <-
395+ Pattern.verify (Error.DPFuncArgs name) $
396+ traverse (Pattern.canonicalize env) srcArgs
397+
398+ newEnv <-
399+ Env.addLocals argBindings env
400+
401+ (cbody, freeLocals) <-
402+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
403+
404+ let cdef = Can.Def aname args cbody
405+ let node = ( Define cdef, name, Map.keys freeLocals )
406+ logLetLocals args freeLocals (node:nodes)
407+
408+ Just tipe ->
409+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
410+ ((args, resultType), argBindings) <-
411+ Pattern.verify (Error.DPFuncArgs name) $
412+ gatherTypedArgs env name srcArgs ctipe Index.first []
413+
414+ newEnv <-
415+ Env.addLocals argBindings env
416+
417+ (cbody, freeLocals) <-
418+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
419+
420+ let cdef = Can.TypedDef aname freeVars args cbody resultType
421+ let node = ( Define cdef, name, Map.keys freeLocals )
422+ logLetLocals args freeLocals (node:nodes)
423+
424+ Src.Destruct pattern body ->
425+ do (cpattern, _bindings) <-
426+ Pattern.verify Error.DPDestruct $
427+ Pattern.canonicalize env pattern
428+
429+ Result.Result $ \fs ws bad good ->
430+ case canonicalize env body of
431+ Result.Result k ->
432+ k Map.empty ws
433+ (\freeLocals warnings errors ->
434+ bad (Map.unionWith combineUses freeLocals fs) warnings errors
435+ )
436+ (\freeLocals warnings cbody ->
437+ let
438+ names = getPatternNames [] pattern
439+ name = Name.fromManyNames (map A.toValue names)
440+ node = ( Destruct cpattern cbody, name, Map.keys freeLocals )
441+ in
442+ good
443+ (Map.unionWith combineUses fs freeLocals)
444+ warnings
445+ (List.foldl' (addEdge [name]) (node:nodes) names)
446+ )
447+
448+
449+logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value
450+logLetLocals args letLocals value =
451+ Result.Result $ \freeLocals warnings _ good ->
452+ good
453+ ( Map.unionWith combineUses freeLocals $
454+ case args of
455+ [] -> letLocals
456+ _ -> Map.map delayUse letLocals
457+ )
458+ warnings
459+ value
460+
461+
462+addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node]
463+addEdge edges nodes aname@(A.At _ name) =
464+ (Edge aname, name, edges) : nodes
465+
466+
467+getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name]
468+getPatternNames names (A.At region pattern) =
469+ case pattern of
470+ Src.PAnything -> names
471+ Src.PVar name -> A.At region name : names
472+ Src.PRecord fields -> fields ++ names
473+ Src.PAlias ptrn name -> getPatternNames (name : names) ptrn
474+ Src.PUnit -> names
475+ Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs
476+ Src.PCtor _ _ args -> List.foldl' getPatternNames names args
477+ Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names args
478+ Src.PList patterns -> List.foldl' getPatternNames names patterns
479+ Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl
480+ Src.PChr _ -> names
481+ Src.PStr _ -> names
482+ Src.PInt _ -> names
483+
484+
485+
486+-- GATHER TYPED ARGS
487+
488+
489+gatherTypedArgs
490+ :: Env.Env
491+ -> Name.Name
492+ -> [Src.Pattern]
493+ -> Can.Type
494+ -> Index.ZeroBased
495+ -> [(Can.Pattern, Can.Type)]
496+ -> Result Pattern.DupsDict w ([(Can.Pattern, Can.Type)], Can.Type)
497+gatherTypedArgs env name srcArgs tipe index revTypedArgs =
498+ case srcArgs of
499+ [] ->
500+ return (reverse revTypedArgs, tipe)
501+
502+ srcArg : otherSrcArgs ->
503+ case Type.iteratedDealias tipe of
504+ Can.TLambda argType resultType ->
505+ do arg <- Pattern.canonicalize env srcArg
506+ gatherTypedArgs env name otherSrcArgs resultType (Index.next index) $
507+ (arg, argType) : revTypedArgs
508+
509+ _ ->
510+ let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
511+ Result.throw $
512+ Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs)
513+
514+
515+
516+-- DETECT CYCLES
517+
518+
519+detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
520+detectCycles letRegion sccs body =
521+ case sccs of
522+ [] ->
523+ Result.ok body
524+
525+ scc : subSccs ->
526+ case scc of
527+ Graph.AcyclicSCC binding ->
528+ case binding of
529+ Define def ->
530+ A.At letRegion . Can.Let def <$> detectCycles letRegion subSccs body
531+
532+ Edge _ ->
533+ detectCycles letRegion subSccs body
534+
535+ Destruct pattern expr ->
536+ A.At letRegion . Can.LetDestruct pattern expr <$> detectCycles letRegion subSccs body
537+
538+ Graph.CyclicSCC bindings ->
539+ A.At letRegion <$>
540+ (Can.LetRec
541+ <$> checkCycle bindings []
542+ <*> detectCycles letRegion subSccs body
543+ )
544+
545+
546+checkCycle :: [Binding] -> [Can.Def] -> Result i w [Can.Def]
547+checkCycle bindings defs =
548+ case bindings of
549+ [] ->
550+ Result.ok defs
551+
552+ binding : otherBindings ->
553+ case binding of
554+ Define def@(Can.Def name args _) ->
555+ if null args then
556+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
557+ else
558+ checkCycle otherBindings (def:defs)
559+
560+ Define def@(Can.TypedDef name _ args _ _) ->
561+ if null args then
562+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
563+ else
564+ checkCycle otherBindings (def:defs)
565+
566+ Edge name ->
567+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
568+
569+ Destruct _ _ ->
570+ -- a Destruct cannot appear in a cycle without any Edge values
571+ -- so we just keep going until we get to the edges
572+ checkCycle otherBindings defs
573+
574+
575+toNames :: [Binding] -> [Can.Def] -> [Name.Name]
576+toNames bindings revDefs =
577+ case bindings of
578+ [] ->
579+ reverse (map getDefName revDefs)
580+
581+ binding : otherBindings ->
582+ case binding of
583+ Define def -> getDefName def : toNames otherBindings revDefs
584+ Edge (A.At _ name) -> name : toNames otherBindings revDefs
585+ Destruct _ _ -> toNames otherBindings revDefs
586+
587+
588+getDefName :: Can.Def -> Name.Name
589+getDefName def =
590+ case def of
591+ Can.Def (A.At _ name) _ _ ->
592+ name
593+
594+ Can.TypedDef (A.At _ name) _ _ _ _ ->
595+ name
596+
597+
598+
599+-- LOG VARIABLE USES
600+
601+
602+logVar :: Name.Name -> a -> Result FreeLocals w a
603+logVar name value =
604+ Result.Result $ \freeLocals warnings _ good ->
605+ good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
606+
607+
608+{-# NOINLINE oneDirectUse #-}
609+oneDirectUse :: Uses
610+oneDirectUse =
611+ Uses 1 0
612+
613+
614+combineUses :: Uses -> Uses -> Uses
615+combineUses (Uses a b) (Uses x y) =
616+ Uses (a + x) (b + y)
617+
618+
619+delayUse :: Uses -> Uses
620+delayUse (Uses direct delayed) =
621+ Uses 0 (direct + delayed)
622+
623+
624+
625+-- MANAGING BINDINGS
626+
627+
628+verifyBindings
629+ :: W.Context
630+ -> Pattern.Bindings
631+ -> Result FreeLocals [W.Warning] value
632+ -> Result info [W.Warning] (value, FreeLocals)
633+verifyBindings context bindings (Result.Result k) =
634+ Result.Result $ \info warnings bad good ->
635+ k Map.empty warnings
636+ (\_ warnings1 err ->
637+ bad info warnings1 err
638+ )
639+ (\freeLocals warnings1 value ->
640+ let
641+ outerFreeLocals =
642+ Map.difference freeLocals bindings
643+
644+ warnings2 =
645+ -- NOTE: Uses Map.size for O(1) lookup. This means there is
646+ -- no dictionary allocation unless a problem is detected.
647+ if Map.size bindings + Map.size outerFreeLocals == Map.size freeLocals then
648+ warnings1
649+ else
650+ Map.foldlWithKey (addUnusedWarning context) warnings1 $
651+ Map.difference bindings freeLocals
652+ in
653+ good info warnings2 (value, outerFreeLocals)
654+ )
655+
656+
657+addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning]
658+addUnusedWarning context warnings name region =
659+ W.UnusedVariable region context name : warnings
660+
661+
662+directUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
663+directUsage (Result.Result k) =
664+ Result.Result $ \freeLocals warnings bad good ->
665+ k () warnings
666+ (\() ws es -> bad freeLocals ws es)
667+ (\() ws (value, newFreeLocals) ->
668+ good (Map.unionWith combineUses freeLocals newFreeLocals) ws value
669+ )
670+
671+
672+delayedUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
673+delayedUsage (Result.Result k) =
674+ Result.Result $ \freeLocals warnings bad good ->
675+ k () warnings
676+ (\() ws es -> bad freeLocals ws es)
677+ (\() ws (value, newFreeLocals) ->
678+ let delayedLocals = Map.map delayUse newFreeLocals in
679+ good (Map.unionWith combineUses freeLocals delayedLocals) ws value
680+ )
681+
682+
683+
684+-- FIND VARIABLE
685+
686+
687+findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_
688+findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
689+ case Map.lookup name vs of
690+ Just var ->
691+ case var of
692+ Env.Local _ ->
693+ logVar name (Can.VarLocal name)
694+
695+ Env.TopLevel _ ->
696+ logVar name (Can.VarTopLevel localHome name)
697+
698+ Env.Foreign home annotation ->
699+ Result.ok $
700+ if home == ModuleName.debug then
701+ Can.VarDebug localHome name annotation
702+ else
703+ Can.VarForeign home name annotation
704+
705+ Env.Foreigns h hs ->
706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)
707+
708+ Nothing ->
709+ Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
710+
711+
712+findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_
713+findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
714+ case Map.lookup prefix qvs of
715+ Just qualified ->
716+ case Map.lookup name qualified of
717+ Just (Env.Specific home annotation) ->
718+ Result.ok $
719+ if home == ModuleName.debug then
720+ Can.VarDebug localHome name annotation
721+ else
722+ Can.VarForeign home name annotation
723+
724+ Just (Env.Ambiguous h hs) ->
725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
726+
727+ Nothing ->
728+ Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
729+
730+ Nothing ->
731+ if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then
732+ Result.ok $ Can.VarKernel (Name.getKernel prefix) name
733+ else
734+ Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
735+
736+
737+toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames
738+toPossibleNames exposed qualified =
739+ Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)
740+
741+
742+
743+-- FIND CTOR
744+
745+
746+toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_
747+toVarCtor name ctor =
748+ case ctor of
749+ Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->
750+ let
751+ freeVars = Map.fromList (map (\v -> (v, ())) vars)
752+ result = Can.TType home typeName (map Can.TVar vars)
753+ tipe = foldr Can.TLambda result args
754+ in
755+ Can.VarCtor opts home name index (Can.Forall freeVars tipe)
756+
757+ Env.RecordCtor home vars tipe ->
758+ let
759+ freeVars = Map.fromList (map (\v -> (v, ())) vars)
760+ in
761+ Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe)
compiler/src/Canonicalize/Module.hsnew file+296
@@ -0,0 +1,296 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.Module
3+ ( canonicalize
4+ )
5+ where
6+
7+
8+import qualified Data.Graph as Graph
9+import qualified Data.Map as Map
10+import qualified Data.Name as Name
11+
12+import qualified AST.Canonical as Can
13+import qualified AST.Source as Src
14+import qualified Canonicalize.Effects as Effects
15+import qualified Canonicalize.Environment as Env
16+import qualified Canonicalize.Environment.Dups as Dups
17+import qualified Canonicalize.Environment.Foreign as Foreign
18+import qualified Canonicalize.Environment.Local as Local
19+import qualified Canonicalize.Expression as Expr
20+import qualified Canonicalize.Pattern as Pattern
21+import qualified Canonicalize.Type as Type
22+import qualified Data.Index as Index
23+import qualified Elm.Interface as I
24+import qualified Elm.ModuleName as ModuleName
25+import qualified Elm.Package as Pkg
26+import qualified Reporting.Annotation as A
27+import qualified Reporting.Error.Canonicalize as Error
28+import qualified Reporting.Result as Result
29+import qualified Reporting.Warning as W
30+
31+
32+
33+-- RESULT
34+
35+
36+type Result i w a =
37+ Result.Result i w Error.Error a
38+
39+
40+
41+-- MODULES
42+
43+
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)
47+ let cbinops = Map.fromList (map canonicalizeBinop binops)
48+
49+ (env, cunions, caliases) <-
50+ Local.add modul =<<
51+ Foreign.createInitialEnv home ifaces imports
52+
53+ cvalues <- canonicalizeValues env values
54+ ceffects <- Effects.canonicalize env values cunions effects
55+ cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
56+
57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
58+
59+
60+
61+-- CANONICALIZE BINOP
62+
63+
64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
66+ ( op, Can.Binop_ associativity precedence func )
67+
68+
69+
70+-- DECLARATIONS / CYCLE DETECTION
71+--
72+-- There are two phases of cycle detection:
73+--
74+-- 1. Detect cycles using ALL dependencies => needed for type inference
75+-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion
76+--
77+
78+
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
82+ detectCycles (Graph.stronglyConnComp nodes)
83+
84+
85+detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls
86+detectCycles sccs =
87+ case sccs of
88+ [] ->
89+ Result.ok Can.SaveTheEnvironment
90+
91+ scc : otherSccs ->
92+ case scc of
93+ Graph.AcyclicSCC (def, _, _) ->
94+ Can.Declare def <$> detectCycles otherSccs
95+
96+ 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
101+
102+
103+detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
104+detectBadCycles scc =
105+ case scc of
106+ Graph.AcyclicSCC def ->
107+ Result.ok def
108+
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
125+
126+
127+
128+-- DECLARATIONS / CYCLE DETECTION SETUP
129+--
130+-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases.
131+--
132+
133+-- Phase one nodes track ALL dependencies.
134+-- This allows us to find cyclic values for type inference.
135+type NodeOne =
136+ (NodeTwo, Name.Name, [Name.Name])
137+
138+
139+-- Phase two nodes track DIRECT dependencies.
140+-- This allows us to detect cycles that definitely do not terminate.
141+type NodeTwo =
142+ (Can.Def, Name.Name, [Name.Name])
143+
144+
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)) =
147+ case maybeType of
148+ Nothing ->
149+ do (args, argBindings) <-
150+ Pattern.verify (Error.DPFuncArgs name) $
151+ traverse (Pattern.canonicalize env) srcArgs
152+
153+ newEnv <-
154+ Env.addLocals argBindings env
155+
156+ (cbody, freeLocals) <-
157+ Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
158+
159+ let def = Can.Def aname args cbody
160+ return
161+ ( toNodeTwo name srcArgs def freeLocals
162+ , name
163+ , Map.keys freeLocals
164+ )
165+
166+ Just srcType ->
167+ do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
168+
169+ ((args,resultType), argBindings) <-
170+ Pattern.verify (Error.DPFuncArgs name) $
171+ Expr.gatherTypedArgs env name srcArgs tipe Index.first []
172+
173+ newEnv <-
174+ Env.addLocals argBindings env
175+
176+ (cbody, freeLocals) <-
177+ Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
178+
179+ let def = Can.TypedDef aname freeVars args cbody resultType
180+ return
181+ ( toNodeTwo name srcArgs def freeLocals
182+ , name
183+ , Map.keys freeLocals
184+ )
185+
186+
187+toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
188+toNodeTwo name args def freeLocals =
189+ case args of
190+ [] ->
191+ (def, name, Map.foldrWithKey addDirects [] freeLocals)
192+
193+ _ ->
194+ (def, name, [])
195+
196+
197+addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name]
198+addDirects name (Expr.Uses directUses _) directDeps =
199+ if directUses > 0 then
200+ name:directDeps
201+ else
202+ directDeps
203+
204+
205+
206+-- CANONICALIZE EXPORTS
207+
208+
209+canonicalizeExports
210+ :: [A.Located Src.Value]
211+ -> Map.Map Name.Name union
212+ -> Map.Map Name.Name alias
213+ -> Map.Map Name.Name binop
214+ -> Can.Effects
215+ -> A.Located Src.Exposing
216+ -> Result i w Can.Exports
217+canonicalizeExports values unions aliases binops effects (A.At region exposing) =
218+ case exposing of
219+ Src.Open ->
220+ Result.ok (Can.ExportEverything region)
221+
222+ Src.Explicit exposeds ->
223+ do let names = Map.fromList (map valueToName values)
224+ infos <- traverse (checkExposed names unions aliases binops effects) exposeds
225+ Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
226+
227+
228+valueToName :: A.Located Src.Value -> ( Name.Name, () )
229+valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) =
230+ ( name, () )
231+
232+
233+checkExposed
234+ :: Map.Map Name.Name value
235+ -> Map.Map Name.Name union
236+ -> Map.Map Name.Name alias
237+ -> Map.Map Name.Name binop
238+ -> Can.Effects
239+ -> Src.Exposed
240+ -> Result i w (Dups.Dict (A.Located Can.Export))
241+checkExposed values unions aliases binops effects exposed =
242+ case exposed of
243+ Src.Lower (A.At region name) ->
244+ if Map.member name values then
245+ ok name region Can.ExportValue
246+ else
247+ case checkPorts effects name of
248+ Nothing ->
249+ ok name region Can.ExportPort
250+
251+ Just ports ->
252+ Result.throw $ Error.ExportNotFound region Error.BadVar name $
253+ ports ++ Map.keys values
254+
255+ Src.Operator region name ->
256+ if Map.member name binops then
257+ ok name region Can.ExportBinop
258+ else
259+ Result.throw $ Error.ExportNotFound region Error.BadOp name $
260+ Map.keys binops
261+
262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
263+ if Map.member name unions then
264+ ok name region Can.ExportUnionOpen
265+ else if Map.member name aliases then
266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name
267+ else
268+ Result.throw $ Error.ExportNotFound region Error.BadType name $
269+ Map.keys unions ++ Map.keys aliases
270+
271+ Src.Upper (A.At region name) Src.Private ->
272+ if Map.member name unions then
273+ ok name region Can.ExportUnionClosed
274+ else if Map.member name aliases then
275+ ok name region Can.ExportAlias
276+ else
277+ Result.throw $ Error.ExportNotFound region Error.BadType name $
278+ Map.keys unions ++ Map.keys aliases
279+
280+
281+checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name]
282+checkPorts effects name =
283+ case effects of
284+ Can.NoEffects ->
285+ Just []
286+
287+ Can.Ports ports ->
288+ if Map.member name ports then Nothing else Just (Map.keys ports)
289+
290+ Can.Manager _ _ _ _ ->
291+ Just []
292+
293+
294+ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
295+ok name region export =
296+ Result.ok $ Dups.one name region (A.At region export)
compiler/src/Canonicalize/Pattern.hsnew file+181
@@ -0,0 +1,181 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.Pattern
3+ ( verify
4+ , Bindings
5+ , DupsDict
6+ , canonicalize
7+ )
8+ where
9+
10+
11+import qualified Data.List as List
12+import qualified Data.Map.Strict as Map
13+import qualified Data.Name as Name
14+
15+import qualified AST.Canonical as Can
16+import qualified AST.Source as Src
17+import qualified Canonicalize.Environment as Env
18+import qualified Canonicalize.Environment.Dups as Dups
19+import qualified Data.Index as Index
20+import qualified Elm.ModuleName as ModuleName
21+import qualified Reporting.Annotation as A
22+import qualified Reporting.Error.Canonicalize as Error
23+import qualified Reporting.Result as Result
24+
25+
26+
27+-- RESULTS
28+
29+
30+type Result i w a =
31+ Result.Result i w Error.Error a
32+
33+
34+type Bindings =
35+ Map.Map Name.Name A.Region
36+
37+
38+
39+-- VERIFY
40+
41+
42+verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings)
43+verify context (Result.Result k) =
44+ Result.Result $ \info warnings bad good ->
45+ k Dups.none warnings
46+ (\_ warnings1 errors ->
47+ bad info warnings1 errors
48+ )
49+ (\bindings warnings1 value ->
50+ case Dups.detect (Error.DuplicatePattern context) bindings of
51+ Result.Result k1 ->
52+ k1 () ()
53+ (\() () errs -> bad info warnings1 errs)
54+ (\() () dict -> good info warnings1 (value, dict))
55+ )
56+
57+
58+
59+-- CANONICALIZE
60+
61+
62+type DupsDict =
63+ Dups.Dict A.Region
64+
65+
66+canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
67+canonicalize env (A.At region pattern) =
68+ A.At region <$>
69+ case pattern of
70+ Src.PAnything ->
71+ Result.ok Can.PAnything
72+
73+ Src.PVar name ->
74+ logVar name region (Can.PVar name)
75+
76+ Src.PRecord fields ->
77+ logFields fields (Can.PRecord (map A.toValue fields))
78+
79+ Src.PUnit ->
80+ Result.ok Can.PUnit
81+
82+ Src.PTuple a b cs ->
83+ Can.PTuple
84+ <$> canonicalize env a
85+ <*> canonicalize env b
86+ <*> canonicalizeTuple region env cs
87+
88+ Src.PCtor nameRegion name patterns ->
89+ canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name
90+
91+ Src.PCtorQual nameRegion home name patterns ->
92+ canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name
93+
94+ Src.PList patterns ->
95+ Can.PList <$> canonicalizeList env patterns
96+
97+ Src.PCons first rest ->
98+ Can.PCons
99+ <$> canonicalize env first
100+ <*> canonicalize env rest
101+
102+ Src.PAlias ptrn (A.At reg name) ->
103+ do cpattern <- canonicalize env ptrn
104+ logVar name reg (Can.PAlias cpattern name)
105+
106+ Src.PChr chr ->
107+ Result.ok (Can.PChr chr)
108+
109+ Src.PStr str ->
110+ Result.ok (Can.PStr str)
111+
112+ Src.PInt int ->
113+ Result.ok (Can.PInt int)
114+
115+
116+canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
117+canonicalizeCtor env region name patterns ctor =
118+ case ctor of
119+ Env.Ctor home tipe union index args ->
120+ let
121+ toCanonicalArg argIndex argPattern argTipe =
122+ Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern
123+ in
124+ do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
125+ case verifiedList of
126+ 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)
131+
132+ Index.LengthMismatch actualLength expectedLength ->
133+ Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)
134+
135+ Env.RecordCtor _ _ _ ->
136+ Result.throw (Error.PatternHasRecordCtor region name)
137+
138+
139+canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
140+canonicalizeTuple tupleRegion env extras =
141+ case extras of
142+ [] ->
143+ Result.ok Nothing
144+
145+ [three] ->
146+ Just <$> canonicalize env three
147+
148+ _ ->
149+ Result.throw $ Error.TupleLargerThanThree tupleRegion
150+
151+
152+canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
153+canonicalizeList env list =
154+ case list of
155+ [] ->
156+ Result.ok []
157+
158+ pattern : otherPatterns ->
159+ (:)
160+ <$> canonicalize env pattern
161+ <*> canonicalizeList env otherPatterns
162+
163+
164+
165+-- LOG BINDINGS
166+
167+
168+logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a
169+logVar name region value =
170+ Result.Result $ \bindings warnings _ ok ->
171+ ok (Dups.insert name region region bindings) warnings value
172+
173+
174+logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
175+logFields fields value =
176+ let
177+ addField dict (A.At region name) =
178+ Dups.insert name region region dict
179+ in
180+ Result.Result $ \bindings warnings _ ok ->
181+ ok (List.foldl' addField bindings fields) warnings value
compiler/src/Canonicalize/Type.hsnew file+162
@@ -0,0 +1,162 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Type
4+ ( toAnnotation
5+ , canonicalize
6+ )
7+ where
8+
9+
10+import qualified Data.List as List
11+import qualified Data.Map as Map
12+import qualified Data.Name as Name
13+
14+import qualified AST.Canonical as Can
15+import qualified AST.Source as Src
16+import qualified Canonicalize.Environment as Env
17+import qualified Canonicalize.Environment.Dups as Dups
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Error.Canonicalize as Error
20+import qualified Reporting.Result as Result
21+
22+
23+
24+-- RESULT
25+
26+
27+type Result i w a =
28+ Result.Result i w Error.Error a
29+
30+
31+
32+-- TO ANNOTATION
33+
34+
35+toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation
36+toAnnotation env srcType =
37+ do tipe <- canonicalize env srcType
38+ Result.ok $ Can.Forall (addFreeVars Map.empty tipe) tipe
39+
40+
41+
42+-- CANONICALIZE TYPES
43+
44+
45+canonicalize :: Env.Env -> Src.Type -> Result i w Can.Type
46+canonicalize env (A.At typeRegion tipe) =
47+ case tipe of
48+ Src.TVar x ->
49+ Result.ok (Can.TVar x)
50+
51+ Src.TType region name args ->
52+ canonicalizeType env typeRegion name args =<<
53+ Env.findType region env name
54+
55+ Src.TTypeQual region home name args ->
56+ canonicalizeType env typeRegion name args =<<
57+ Env.findTypeQual region env home name
58+
59+ Src.TLambda a b ->
60+ Can.TLambda
61+ <$> canonicalize env a
62+ <*> canonicalize env b
63+
64+ Src.TRecord fields ext ->
65+ do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields)
66+ return $ Can.TRecord cfields (fmap A.toValue ext)
67+
68+ Src.TUnit ->
69+ Result.ok Can.TUnit
70+
71+ Src.TTuple a b cs ->
72+ Can.TTuple
73+ <$> canonicalize env a
74+ <*> canonicalize env b
75+ <*>
76+ case cs of
77+ [] ->
78+ Result.ok Nothing
79+
80+ [c] ->
81+ Just <$> canonicalize env c
82+
83+ _ ->
84+ Result.throw $ Error.TupleLargerThanThree typeRegion
85+
86+
87+canonicalizeFields :: Env.Env -> [(A.Located Name.Name, Src.Type)] -> [(A.Located Name.Name, Result i w Can.FieldType)]
88+canonicalizeFields env fields =
89+ let
90+ len = fromIntegral (length fields)
91+ canonicalizeField index (name, srcType) =
92+ (name, Can.FieldType index <$> canonicalize env srcType)
93+ in
94+ zipWith canonicalizeField [0..len] fields
95+
96+
97+
98+-- CANONICALIZE TYPE
99+
100+
101+canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type
102+canonicalizeType env region name args info =
103+ do cargs <- traverse (canonicalize env) args
104+ case info of
105+ Env.Alias arity home argNames aliasedType ->
106+ checkArity arity region name args $
107+ Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType)
108+
109+ Env.Union arity home ->
110+ checkArity arity region name args $
111+ Can.TType home name cargs
112+
113+
114+checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer
115+checkArity expected region name args answer =
116+ let actual = length args in
117+ if expected == actual then
118+ Result.ok answer
119+ else
120+ Result.throw (Error.BadArity region Error.TypeArity name expected actual)
121+
122+
123+
124+-- ADD FREE VARS
125+
126+
127+addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name ()
128+addFreeVars freeVars tipe =
129+ case tipe of
130+ Can.TLambda arg result ->
131+ addFreeVars (addFreeVars freeVars result) arg
132+
133+ Can.TVar var ->
134+ Map.insert var () freeVars
135+
136+ Can.TType _ _ args ->
137+ List.foldl' addFreeVars freeVars args
138+
139+ Can.TRecord fields Nothing ->
140+ Map.foldl addFieldFreeVars freeVars fields
141+
142+ Can.TRecord fields (Just ext) ->
143+ Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields
144+
145+ Can.TUnit ->
146+ freeVars
147+
148+ Can.TTuple a b maybeC ->
149+ case maybeC of
150+ Nothing ->
151+ addFreeVars (addFreeVars freeVars a) b
152+
153+ Just c ->
154+ addFreeVars (addFreeVars (addFreeVars freeVars a) b) c
155+
156+ Can.TAlias _ _ args _ ->
157+ List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args
158+
159+
160+addFieldFreeVars :: Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name ()
161+addFieldFreeVars freeVars (Can.FieldType _ tipe) =
162+ addFreeVars freeVars tipe
compiler/src/Compile.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+module Compile
3+ ( Artifacts(..)
4+ , compile
5+ )
6+ where
7+
8+
9+import qualified Data.Map as Map
10+import qualified Data.Name as Name
11+
12+import qualified AST.Source as Src
13+import qualified AST.Canonical as Can
14+import qualified AST.Optimized as Opt
15+import qualified Canonicalize.Module as Canonicalize
16+import qualified Elm.Interface as I
17+import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Package as Pkg
19+import qualified Nitpick.PatternMatches as PatternMatches
20+import 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
24+import qualified Type.Constrain.Module as Type
25+import qualified Type.Solve as Type
26+
27+import System.IO.Unsafe (unsafePerformIO)
28+
29+
30+
31+-- COMPILE
32+
33+
34+data Artifacts =
35+ Artifacts
36+ { _modul :: Can.Module
37+ , _types :: Map.Map Name.Name Can.Annotation
38+ , _graph :: Opt.LocalGraph
39+ }
40+
41+
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)
49+
50+
51+
52+-- PHASES
53+
54+
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
60+
61+ Left errors ->
62+ Left $ E.BadNames errors
63+
64+
65+typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
66+typeCheck modul canonical =
67+ case unsafePerformIO (Type.run =<< Type.constrain canonical) of
68+ Right annotations ->
69+ Right annotations
70+
71+ Left errors ->
72+ Left (E.BadTypes (Localizer.fromModule modul) errors)
73+
74+
75+nitpick :: Can.Module -> Either E.Error ()
76+nitpick canonical =
77+ case PatternMatches.check canonical of
78+ Right () ->
79+ Right ()
80+
81+ Left errors ->
82+ Left (E.BadPatterns errors)
83+
84+
85+optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
86+optimize modul annotations canonical =
87+ case snd $ R.run $ Optimize.optimize annotations canonical of
88+ Right localGraph ->
89+ Right localGraph
90+
91+ Left errors ->
92+ Left (E.BadMains (Localizer.fromModule modul) errors)
compiler/src/Data/Bag.hsnew file+110
@@ -0,0 +1,110 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Data.Bag
3+ ( Bag(..)
4+ , empty
5+ , one
6+ , append
7+ , map
8+ , toList
9+ , fromList
10+ )
11+ where
12+
13+
14+import Prelude hiding (map)
15+import qualified Data.List as List
16+
17+
18+
19+-- BAGS
20+
21+
22+data Bag a
23+ = Empty
24+ | One a
25+ | Two (Bag a) (Bag a)
26+
27+
28+
29+-- HELPERS
30+
31+
32+empty :: Bag a
33+empty =
34+ Empty
35+
36+
37+one :: a -> Bag a
38+one =
39+ One
40+
41+
42+append :: Bag a -> Bag a -> Bag a
43+append left right =
44+ case (left, right) of
45+ (other, Empty) ->
46+ other
47+
48+ (Empty, other) ->
49+ other
50+
51+ (_, _) ->
52+ Two left right
53+
54+
55+
56+-- MAP
57+
58+
59+map :: (a -> b) -> Bag a -> Bag b
60+map func bag =
61+ case bag of
62+ Empty ->
63+ Empty
64+
65+ One a ->
66+ One (func a)
67+
68+ Two left right ->
69+ Two (map func left) (map func right)
70+
71+
72+
73+-- TO LIST
74+
75+
76+toList :: Bag a -> [a]
77+toList bag =
78+ toListHelp bag []
79+
80+
81+toListHelp :: Bag a -> [a] -> [a]
82+toListHelp bag list =
83+ case bag of
84+ Empty ->
85+ list
86+
87+ One x ->
88+ x : list
89+
90+ Two a b ->
91+ toListHelp a (toListHelp b list)
92+
93+
94+
95+-- FROM LIST
96+
97+
98+fromList :: (a -> b) -> [a] -> Bag b
99+fromList func list =
100+ case list of
101+ [] ->
102+ Empty
103+
104+ first : rest ->
105+ List.foldl' (add func) (One (func first)) rest
106+
107+
108+add :: (a -> b) -> Bag b -> a -> Bag b
109+add func bag value =
110+ Two (One (func value)) bag
compiler/src/Data/Index.hsnew file+132
@@ -0,0 +1,132 @@
1+module Data.Index
2+ ( ZeroBased
3+ , first
4+ , second
5+ , third
6+ , next
7+ , toMachine
8+ , toHuman
9+ , indexedMap
10+ , indexedTraverse
11+ , indexedForA
12+ , VerifiedList(..)
13+ , indexedZipWith
14+ , indexedZipWithA
15+ )
16+ where
17+
18+
19+import Control.Monad (liftM)
20+import Data.Binary
21+
22+
23+
24+-- ZERO BASED
25+
26+
27+newtype ZeroBased = ZeroBased Int
28+ deriving (Eq, Ord)
29+
30+
31+first :: ZeroBased
32+first =
33+ ZeroBased 0
34+
35+
36+second :: ZeroBased
37+second =
38+ ZeroBased 1
39+
40+
41+third :: ZeroBased
42+third =
43+ ZeroBased 2
44+
45+
46+{-# INLINE next #-}
47+next :: ZeroBased -> ZeroBased
48+next (ZeroBased i) =
49+ ZeroBased (i + 1)
50+
51+
52+
53+-- DESTRUCT
54+
55+
56+toMachine :: ZeroBased -> Int
57+toMachine (ZeroBased index) =
58+ index
59+
60+
61+toHuman :: ZeroBased -> Int
62+toHuman (ZeroBased index) =
63+ index + 1
64+
65+
66+
67+-- INDEXED MAP
68+
69+
70+{-# INLINE indexedMap #-}
71+indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b]
72+indexedMap func xs =
73+ zipWith func (map ZeroBased [0 .. length xs]) xs
74+
75+
76+{-# INLINE indexedTraverse #-}
77+indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b]
78+indexedTraverse func xs =
79+ sequenceA (indexedMap func xs)
80+
81+
82+{-# INLINE indexedForA #-}
83+indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b]
84+indexedForA xs func =
85+ sequenceA (indexedMap func xs)
86+
87+
88+
89+-- VERIFIED/INDEXED ZIP
90+
91+
92+data VerifiedList a
93+ = LengthMatch [a]
94+ | LengthMismatch Int Int
95+
96+
97+indexedZipWith :: (ZeroBased -> a -> b -> c) -> [a] -> [b] -> VerifiedList c
98+indexedZipWith func listX listY =
99+ indexedZipWithHelp func 0 listX listY []
100+
101+
102+indexedZipWithHelp :: (ZeroBased -> a -> b -> c) -> Int -> [a] -> [b] -> [c] -> VerifiedList c
103+indexedZipWithHelp func index listX listY revListZ =
104+ case (listX, listY) of
105+ ([], []) ->
106+ LengthMatch (reverse revListZ)
107+
108+ (x:xs, y:ys) ->
109+ indexedZipWithHelp func (index + 1) xs ys $
110+ func (ZeroBased index) x y : revListZ
111+
112+ (_, _) ->
113+ LengthMismatch (index + length listX) (index + length listY)
114+
115+
116+indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c)
117+indexedZipWithA func listX listY =
118+ case indexedZipWith func listX listY of
119+ LengthMatch xs ->
120+ LengthMatch <$> sequenceA xs
121+
122+ LengthMismatch x y ->
123+ pure (LengthMismatch x y)
124+
125+
126+
127+-- BINARY
128+
129+
130+instance Binary ZeroBased where
131+ get = liftM ZeroBased get
132+ put (ZeroBased n) = put n
compiler/src/Data/Map/Utils.hsnew file+43
@@ -0,0 +1,43 @@
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.hsnew file+610
@@ -0,0 +1,610 @@
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.hsnew file+78
@@ -0,0 +1,78 @@
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.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Data.OneOrMore
3+ ( OneOrMore(..)
4+ , one
5+ , more
6+ , map
7+ , destruct
8+ , getFirstTwo
9+ )
10+ where
11+
12+
13+import Prelude hiding (map)
14+
15+
16+
17+-- ONE OR MORE
18+
19+
20+data OneOrMore a
21+ = One a
22+ | More (OneOrMore a) (OneOrMore a)
23+
24+
25+one :: a -> OneOrMore a
26+one =
27+ One
28+
29+
30+more :: OneOrMore a -> OneOrMore a -> OneOrMore a
31+more =
32+ More
33+
34+
35+
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 []
56+
57+
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)
66+
67+
68+destructRight :: OneOrMore a -> [a] -> [a]
69+destructRight oneOrMore xs =
70+ case oneOrMore of
71+ One x ->
72+ x : xs
73+
74+ More a b ->
75+ destructRight a (destructRight b xs)
76+
77+
78+
79+-- GET FIRST TWO
80+
81+
82+getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)
83+getFirstTwo left right =
84+ case left of
85+ One x ->
86+ (x, getFirstOne right)
87+
88+ More lleft lright ->
89+ getFirstTwo lleft lright
90+
91+
92+getFirstOne :: OneOrMore a -> a
93+getFirstOne oneOrMore =
94+ case oneOrMore of
95+ One x ->
96+ x
97+
98+ More left _ ->
99+ getFirstOne left
compiler/src/Data/Utf8.hsnew file+618
@@ -0,0 +1,618 @@
1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
3+module Data.Utf8
4+ ( Utf8(..)
5+ , isEmpty
6+ , empty
7+ , size
8+ , contains
9+ , startsWith
10+ , startsWithChar
11+ , endsWithWord8
12+ , split
13+ , join
14+ --
15+ , getUnder256
16+ , putUnder256
17+ --
18+ , getVeryLong
19+ , putVeryLong
20+ --
21+ , toChars
22+ , toBuilder
23+ , toEscapedBuilder
24+ --
25+ , fromPtr
26+ , fromSnippet
27+ , fromChars
28+ --
29+ , MBA
30+ , newByteArray
31+ , copyFromPtr
32+ , writeWord8
33+ , freeze
34+ )
35+ where
36+
37+
38+import Prelude hiding (String, all, any, concat)
39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)
40+import Data.Binary.Put (putBuilder)
41+import Data.Binary.Get.Internal (readN)
42+import Data.Bits ((.&.), shiftR)
43+import qualified Data.ByteString.Internal as B
44+import qualified Data.ByteString.Builder.Internal as B
45+import qualified Data.Char as Char
46+import qualified Data.List as List
47+import Foreign.ForeignPtr (touchForeignPtr)
48+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
49+import Foreign.Ptr (minusPtr, plusPtr)
50+import GHC.Exts
51+ ( Int(I#), Ptr(Ptr), Char(C#)
52+ , RealWorld
53+ , ByteArray#, MutableByteArray#
54+ , isTrue#
55+ , newByteArray#
56+ , unsafeFreezeByteArray#
57+ , sizeofByteArray#
58+ , copyByteArray#
59+ , copyAddrToByteArray#
60+ , copyByteArrayToAddr#
61+ , writeWord8Array#
62+ )
63+import GHC.IO
64+import GHC.ST (ST(ST), runST)
65+import GHC.Prim
66+import GHC.Word (Word8(W8#))
67+
68+import qualified Parse.Primitives as P
69+
70+
71+
72+-- UTF-8
73+
74+
75+data Utf8 tipe =
76+ Utf8 ByteArray#
77+
78+
79+
80+-- EMPTY
81+
82+
83+{-# NOINLINE empty #-}
84+empty :: Utf8 t
85+empty =
86+ runST (freeze =<< newByteArray 0)
87+
88+
89+isEmpty :: Utf8 t -> Bool
90+isEmpty (Utf8 ba#) =
91+ isTrue# (sizeofByteArray# ba# ==# 0#)
92+
93+
94+
95+-- SIZE
96+
97+
98+size :: Utf8 t -> Int
99+size (Utf8 ba#) =
100+ I# (sizeofByteArray# ba#)
101+
102+
103+
104+-- CONTAINS
105+
106+
107+contains :: Word8 -> Utf8 t -> Bool
108+contains (W8# word#) (Utf8 ba#) =
109+ containsHelp word# ba# 0# (sizeofByteArray# ba#)
110+
111+
112+containsHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
113+containsHelp word# ba# !offset# len# =
114+ if isTrue# (offset# <# len#) then
115+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset#))
116+ then True
117+ else containsHelp word# ba# (offset# +# 1#) len#
118+ else
119+ False
120+
121+
122+
123+-- STARTS WITH
124+
125+
126+{-# INLINE startsWith #-}
127+startsWith :: Utf8 t -> Utf8 t -> Bool
128+startsWith (Utf8 ba1#) (Utf8 ba2#) =
129+ let
130+ !len1# = sizeofByteArray# ba1#
131+ !len2# = sizeofByteArray# ba2#
132+ in
133+ isTrue# (len1# <=# len2#)
134+ &&
135+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
136+
137+
138+
139+-- STARTS WITH CHAR
140+
141+
142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
143+startsWithChar isGood bytes@(Utf8 ba#) =
144+ if isEmpty bytes then
145+ False
146+ else
147+ let
148+ !w# = indexWord8Array# ba# 0#
149+ !char
150+ | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#))
151+ | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w#
152+ | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w#
153+ | True = chr4 ba# 0# w#
154+ in
155+ isGood char
156+
157+
158+
159+-- ENDS WITH WORD
160+
161+
162+endsWithWord8 :: Word8 -> Utf8 t -> Bool
163+endsWithWord8 (W8# w#) (Utf8 ba#) =
164+ let len# = sizeofByteArray# ba# in
165+ isTrue# (len# ># 0#)
166+ &&
167+ isTrue# (eqWord# w# (indexWord8Array# ba# (len# -# 1#)))
168+
169+
170+
171+-- SPLIT
172+
173+
174+split :: Word8 -> Utf8 t -> [Utf8 t]
175+split (W8# divider#) str@(Utf8 ba#) =
176+ splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
177+
178+
179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
180+splitHelp str start offsets =
181+ case offsets of
182+ [] ->
183+ [ unsafeSlice str start (size str) ]
184+
185+ offset : offsets ->
186+ unsafeSlice str start offset : splitHelp str (offset + 1) offsets
187+
188+
189+findDividers :: Word# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int]
190+findDividers divider# ba# !offset# len# revOffsets =
191+ if isTrue# (offset# <# len#) then
192+ findDividers divider# ba# (offset# +# 1#) len# $
193+ if isTrue# (eqWord# divider# (indexWord8Array# ba# offset#))
194+ then I# offset# : revOffsets
195+ else revOffsets
196+ else
197+ reverse revOffsets
198+
199+
200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
201+unsafeSlice str start end =
202+ let !len = end - start in
203+ if len == 0 then
204+ empty
205+ else
206+ runST $
207+ do mba <- newByteArray len
208+ copy str start mba 0 len
209+ freeze mba
210+
211+
212+
213+-- JOIN
214+
215+
216+join :: Word8 -> [Utf8 t] -> Utf8 t
217+join sep strings =
218+ case strings of
219+ [] ->
220+ empty
221+
222+ str:strs ->
223+ runST $
224+ do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs
225+ mba <- newByteArray len
226+ joinHelp sep mba 0 str strs
227+ freeze mba
228+
229+
230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
231+joinHelp sep mba offset str strings =
232+ let
233+ !len = size str
234+ in
235+ case strings of
236+ [] ->
237+ copy str 0 mba offset len
238+
239+ s:ss ->
240+ do copy str 0 mba offset len
241+ let !dotOffset = offset + len
242+ writeWord8 mba dotOffset sep
243+ let !newOffset = dotOffset + 1
244+ joinHelp sep mba newOffset s ss
245+
246+
247+
248+-- EQUAL
249+
250+
251+instance Eq (Utf8 t) where
252+ (==) (Utf8 ba1#) (Utf8 ba2#) =
253+ let
254+ !len1# = sizeofByteArray# ba1#
255+ !len2# = sizeofByteArray# ba2#
256+ in
257+ isTrue# (len1# ==# len2#)
258+ &&
259+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
260+
261+
262+
263+-- COMPARE
264+--
265+-- TODO: is it fine to sort by length and only compare bytes on length ties?
266+--
267+
268+instance Ord (Utf8 t) where
269+ compare (Utf8 ba1#) (Utf8 ba2#) =
270+ let
271+ !len1# = sizeofByteArray# ba1#
272+ !len2# = sizeofByteArray# ba2#
273+ !len# = if isTrue# (len1# <# len2#) then len1# else len2#
274+ !cmp# = compareByteArrays# ba1# 0# ba2# 0# len#
275+ in
276+ case () of
277+ _ | isTrue# (cmp# <# 0#) -> LT
278+ | isTrue# (cmp# ># 0#) -> GT
279+ | isTrue# (len1# <# len2#) -> LT
280+ | isTrue# (len1# ># len2#) -> GT
281+ | True -> EQ
282+
283+
284+
285+-- FROM STRING
286+
287+
288+fromChars :: [Char] -> Utf8 t
289+fromChars chars =
290+ runST
291+ (
292+ do mba <- newByteArray (sum (map getWidth chars))
293+ writeChars mba 0 chars
294+ )
295+
296+
297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
298+writeChars !mba !offset chars =
299+ case chars of
300+ [] ->
301+ freeze mba
302+
303+ char : chars
304+ | n < 0x80 ->
305+ do writeWord8 mba (offset ) (fromIntegral n)
306+ writeChars mba (offset + 1) chars
307+
308+ | n < 0x800 ->
309+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
310+ writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
311+ writeChars mba (offset + 2) chars
312+
313+ | n < 0x10000 ->
314+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
315+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
316+ writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
317+ writeChars mba (offset + 3) chars
318+
319+ | otherwise ->
320+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
321+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
322+ writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
323+ writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
324+ writeChars mba (offset + 4) chars
325+
326+ where
327+ n = Char.ord char
328+
329+
330+{-# INLINE getWidth #-}
331+getWidth :: Char -> Int
332+getWidth char
333+ | code < 0x80 = 1
334+ | code < 0x800 = 2
335+ | code < 0x10000 = 3
336+ | otherwise = 4
337+ where
338+ code = Char.ord char
339+
340+
341+
342+-- TO CHARS
343+
344+
345+toChars :: Utf8 t -> [Char]
346+toChars (Utf8 ba#) =
347+ toCharsHelp ba# 0# (sizeofByteArray# ba#)
348+
349+
350+toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char]
351+toCharsHelp ba# offset# len# =
352+ if isTrue# (offset# >=# len#) then
353+ []
354+ else
355+ let
356+ !w# = indexWord8Array# ba# offset#
357+ !(# char, width# #)
358+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
359+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
360+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
361+ | True = (# chr4 ba# offset# w#, 4# #)
362+
363+ !newOffset# = offset# +# width#
364+ in
365+ char : toCharsHelp ba# newOffset# len#
366+
367+
368+{-# INLINE chr2 #-}
369+chr2 :: ByteArray# -> Int# -> Word# -> Char
370+chr2 ba# offset# firstWord# =
371+ let
372+ !i1# = word2Int# firstWord#
373+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
374+ !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
375+ !c2# = i2# -# 0x80#
376+ in
377+ C# (chr# (c1# +# c2#))
378+
379+
380+{-# INLINE chr3 #-}
381+chr3 :: ByteArray# -> Int# -> Word# -> Char
382+chr3 ba# offset# firstWord# =
383+ let
384+ !i1# = word2Int# firstWord#
385+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
386+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
387+ !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
388+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
389+ !c3# = i3# -# 0x80#
390+ in
391+ C# (chr# (c1# +# c2# +# c3#))
392+
393+
394+{-# INLINE chr4 #-}
395+chr4 :: ByteArray# -> Int# -> Word# -> Char
396+chr4 ba# offset# firstWord# =
397+ let
398+ !i1# = word2Int# firstWord#
399+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
400+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
401+ !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))
402+ !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
403+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
404+ !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
405+ !c4# = i4# -# 0x80#
406+ in
407+ C# (chr# (c1# +# c2# +# c3# +# c4#))
408+
409+
410+
411+-- TO BUILDER
412+
413+
414+{-# INLINE toBuilder #-}
415+toBuilder :: Utf8 t -> B.Builder
416+toBuilder =
417+ \bytes -> B.builder (toBuilderHelp bytes)
418+
419+
420+{-# INLINE toBuilderHelp #-}
421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
422+toBuilderHelp !bytes@(Utf8 ba#) k =
423+ go 0 (I# (sizeofByteArray# ba#))
424+ where
425+ go !offset !end !(B.BufferRange bOffset bEnd) =
426+ let
427+ !bLen = minusPtr bEnd bOffset
428+ !len = end - offset
429+ in
430+ if len <= bLen then
431+ do copyToPtr bytes offset bOffset len
432+ let !br' = B.BufferRange (plusPtr bOffset len) bEnd
433+ k br'
434+ else
435+ do copyToPtr bytes offset bOffset bLen
436+ let !offset' = offset + bLen
437+ return $ B.bufferFull 1 bEnd (go offset' end)
438+
439+
440+
441+-- TO ESCAPED BUILDER
442+
443+
444+{-# INLINE toEscapedBuilder #-}
445+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
446+toEscapedBuilder before after =
447+ \name -> B.builder (toEscapedBuilderHelp before after name)
448+
449+
450+{-# INLINE toEscapedBuilderHelp #-}
451+toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a
452+toEscapedBuilderHelp before after !name@(Utf8 ba#) k =
453+ go 0 (I# (sizeofByteArray# ba#))
454+ where
455+ go !offset !len !(B.BufferRange bOffset bEnd) =
456+ let
457+ !bLen = minusPtr bEnd bOffset
458+ in
459+ if len <= bLen then
460+ do -- PERF test if writing word-by-word is faster
461+ copyToPtr name offset bOffset len
462+ escape before after bOffset name offset len 0
463+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
464+ k newBufferRange
465+ else
466+ do copyToPtr name offset bOffset bLen
467+ escape before after bOffset name offset bLen 0
468+ let !newOffset = offset + bLen
469+ let !newLength = len - bLen
470+ return $ B.bufferFull 1 bEnd (go newOffset newLength)
471+
472+
473+escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()
474+escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
475+ if isTrue# (i# <# len#) then
476+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
477+ then
478+ do writeWordToPtr ptr i after
479+ escape before after ptr name offset len (i + 1)
480+ else
481+ do escape before after ptr name offset len (i + 1)
482+
483+ else
484+ return ()
485+
486+
487+
488+-- FROM PTR
489+
490+
491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
492+fromPtr pos end =
493+ unsafeDupablePerformIO (stToIO (
494+ do let !len = minusPtr end pos
495+ mba <- newByteArray len
496+ copyFromPtr pos mba 0 len
497+ freeze mba
498+ ))
499+
500+
501+
502+-- FROM SNIPPET
503+
504+
505+fromSnippet :: P.Snippet -> Utf8 t
506+fromSnippet (P.Snippet fptr off len _ _) =
507+ unsafeDupablePerformIO (stToIO (
508+ do mba <- newByteArray len
509+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
510+ copyFromPtr pos mba 0 len
511+ freeze mba
512+ ))
513+
514+
515+
516+-- BINARY
517+
518+
519+putUnder256 :: Utf8 t -> Put
520+putUnder256 bytes =
521+ do putWord8 (fromIntegral (size bytes))
522+ putBuilder (toBuilder bytes)
523+
524+
525+getUnder256 :: Get (Utf8 t)
526+getUnder256 =
527+ do word <- getWord8
528+ let !n = fromIntegral word
529+ readN n (copyFromByteString n)
530+
531+
532+putVeryLong :: Utf8 t -> Put
533+putVeryLong bytes =
534+ do put (size bytes)
535+ putBuilder (toBuilder bytes)
536+
537+
538+getVeryLong :: Get (Utf8 t)
539+getVeryLong =
540+ do n <- get
541+ if n > 0
542+ then readN n (copyFromByteString n)
543+ else return empty
544+
545+
546+
547+-- COPY FROM BYTESTRING
548+
549+
550+{-# INLINE copyFromByteString #-}
551+copyFromByteString :: Int -> B.ByteString -> Utf8 t
552+copyFromByteString len (B.PS fptr offset _) =
553+ unsafeDupablePerformIO
554+ (
555+ do mba <- stToIO (newByteArray len)
556+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
557+ touchForeignPtr fptr
558+ stToIO (freeze mba)
559+ )
560+
561+
562+
563+-- PRIMITIVES
564+
565+
566+data MBA s =
567+ MBA# (MutableByteArray# s)
568+
569+
570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
571+newByteArray (I# len#) =
572+ ST $ \s ->
573+ case newByteArray# len# s of
574+ (# s, mba# #) -> (# s, MBA# mba# #)
575+
576+
577+freeze :: MBA s -> ST s (Utf8 t)
578+freeze (MBA# mba#) =
579+ ST $ \s ->
580+ case unsafeFreezeByteArray# mba# s of
581+ (# s, ba# #) -> (# s, Utf8 ba# #)
582+
583+
584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
585+copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
586+ ST $ \s ->
587+ case copyByteArray# ba# offset# mba# i# len# s of
588+ s -> (# s, () #)
589+
590+
591+copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
592+copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
593+ ST $ \s ->
594+ case copyAddrToByteArray# src# mba# offset# len# s of
595+ s -> (# s, () #)
596+
597+
598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
599+copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
600+ IO $ \s ->
601+ case copyByteArrayToAddr# ba# offset# mba# len# s of
602+ s -> (# s, () #)
603+
604+
605+{-# INLINE writeWord8 #-}
606+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
607+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
608+ ST $ \s ->
609+ case writeWord8Array# mba# offset# w# s of
610+ s -> (# s, () #)
611+
612+
613+{-# INLINE writeWordToPtr #-}
614+writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()
615+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
616+ IO $ \s ->
617+ case writeWord8OffAddr# addr# offset# word# s of
618+ s -> (# s, () #)
compiler/src/Elm/Compiler/Imports.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Compiler.Imports
4+ ( defaults
5+ )
6+ where
7+
8+
9+import qualified Data.Name as Name
10+
11+import qualified AST.Source as Src
12+import qualified Elm.ModuleName as ModuleName
13+import qualified Reporting.Annotation as A
14+
15+
16+
17+-- DEFAULTS
18+
19+
20+defaults :: [Src.Import]
21+defaults =
22+ [ import_ ModuleName.basics Nothing Src.Open
23+ , import_ ModuleName.debug Nothing closed
24+ , import_ ModuleName.list Nothing (operator "::")
25+ , import_ ModuleName.maybe Nothing (typeOpen Name.maybe)
26+ , import_ ModuleName.result Nothing (typeOpen Name.result)
27+ , import_ ModuleName.string Nothing (typeClosed Name.string)
28+ , import_ ModuleName.char Nothing (typeClosed Name.char)
29+ , import_ ModuleName.tuple Nothing closed
30+ , import_ ModuleName.platform Nothing (typeClosed Name.program)
31+ , import_ ModuleName.cmd (Just Name.cmd) (typeClosed Name.cmd)
32+ , import_ ModuleName.sub (Just Name.sub) (typeClosed Name.sub)
33+ ]
34+
35+
36+import_ :: ModuleName.Canonical -> Maybe Name.Name -> Src.Exposing -> Src.Import
37+import_ (ModuleName.Canonical _ name) maybeAlias exposing =
38+ Src.Import (A.At A.zero name) maybeAlias exposing
39+
40+
41+
42+-- EXPOSING
43+
44+
45+closed :: Src.Exposing
46+closed =
47+ Src.Explicit []
48+
49+
50+typeOpen :: Name.Name -> Src.Exposing
51+typeOpen name =
52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
53+
54+
55+typeClosed :: Name.Name -> Src.Exposing
56+typeClosed name =
57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
58+
59+
60+operator :: Name.Name -> Src.Exposing
61+operator op =
62+ Src.Explicit [ Src.Operator A.zero op ]
compiler/src/Elm/Compiler/Type.hsnew file+194
@@ -0,0 +1,194 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Compiler.Type
4+ ( Type(..)
5+ , RT.Context(..)
6+ , toDoc
7+ , DebugMetadata(..)
8+ , Alias(..)
9+ , Union(..)
10+ , encode
11+ , decoder
12+ , encodeMetadata
13+ )
14+ where
15+
16+
17+import qualified Data.Name as Name
18+
19+import qualified AST.Source as Src
20+import qualified Json.Decode as D
21+import qualified Json.Encode as E
22+import Json.Encode ((==>))
23+import qualified Json.String as Json
24+import qualified Parse.Primitives as P
25+import qualified Parse.Type as Type
26+import qualified Reporting.Annotation as A
27+import qualified Reporting.Doc as D
28+import qualified Reporting.Render.Type as RT
29+import qualified Reporting.Render.Type.Localizer as L
30+
31+
32+
33+-- TYPES
34+
35+
36+data Type
37+ = Lambda Type Type
38+ | Var Name.Name
39+ | Type Name.Name [Type]
40+ | Record [(Name.Name, Type)] (Maybe Name.Name)
41+ | Unit
42+ | Tuple Type Type [Type]
43+
44+
45+data DebugMetadata =
46+ DebugMetadata
47+ { _message :: Type
48+ , _aliases :: [Alias]
49+ , _unions :: [Union]
50+ }
51+
52+
53+data Alias = Alias Name.Name [Name.Name] Type
54+data Union = Union Name.Name [Name.Name] [(Name.Name, [Type])]
55+
56+
57+
58+-- TO DOC
59+
60+
61+toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
62+toDoc localizer context tipe =
63+ case tipe of
64+ Lambda _ _ ->
65+ let
66+ a:b:cs =
67+ map (toDoc localizer RT.Func) (collectLambdas tipe)
68+ in
69+ RT.lambda context a b cs
70+
71+ Var name ->
72+ D.fromName name
73+
74+ Unit ->
75+ "()"
76+
77+ Tuple a b cs ->
78+ RT.tuple
79+ (toDoc localizer RT.None a)
80+ (toDoc localizer RT.None b)
81+ (map (toDoc localizer RT.None) cs)
82+
83+ Type name args ->
84+ RT.apply
85+ context
86+ (D.fromName name)
87+ (map (toDoc localizer RT.App) args)
88+
89+ Record fields ext ->
90+ RT.record
91+ (map (entryToDoc localizer) fields)
92+ (fmap D.fromName ext)
93+
94+
95+entryToDoc :: L.Localizer -> (Name.Name, Type) -> (D.Doc, D.Doc)
96+entryToDoc localizer (field, fieldType) =
97+ ( D.fromName field, toDoc localizer RT.None fieldType )
98+
99+
100+collectLambdas :: Type -> [Type]
101+collectLambdas tipe =
102+ case tipe of
103+ Lambda arg body ->
104+ arg : collectLambdas body
105+
106+ _ ->
107+ [tipe]
108+
109+
110+
111+-- JSON for TYPE
112+
113+
114+encode :: Type -> E.Value
115+encode tipe =
116+ E.chars $ D.toLine (toDoc L.empty RT.None tipe)
117+
118+
119+decoder :: D.Decoder () Type
120+decoder =
121+ let
122+ parser =
123+ P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
124+ in
125+ D.customString parser (\_ _ -> ())
126+
127+
128+fromRawType :: Src.Type -> Type
129+fromRawType (A.At _ astType) =
130+ case astType of
131+ Src.TLambda t1 t2 ->
132+ Lambda (fromRawType t1) (fromRawType t2)
133+
134+ Src.TVar x ->
135+ Var x
136+
137+ Src.TUnit ->
138+ Unit
139+
140+ Src.TTuple a b cs ->
141+ Tuple
142+ (fromRawType a)
143+ (fromRawType b)
144+ (map fromRawType cs)
145+
146+ Src.TType _ name args ->
147+ Type name (map fromRawType args)
148+
149+ Src.TTypeQual _ _ name args ->
150+ Type name (map fromRawType args)
151+
152+ Src.TRecord fields ext ->
153+ let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
154+ Record
155+ (map fromField fields)
156+ (fmap A.toValue ext)
157+
158+
159+
160+-- JSON for PROGRAM
161+
162+
163+encodeMetadata :: DebugMetadata -> E.Value
164+encodeMetadata (DebugMetadata msg aliases unions) =
165+ E.object
166+ [ "message" ==> encode msg
167+ , "aliases" ==> E.object (map toTypeAliasField aliases)
168+ , "unions" ==> E.object (map toCustomTypeField unions)
169+ ]
170+
171+
172+toTypeAliasField :: Alias -> ( Json.String, E.Value )
173+toTypeAliasField (Alias name args tipe) =
174+ ( Json.fromName name
175+ , E.object
176+ [ "args" ==> E.list E.name args
177+ , "type" ==> encode tipe
178+ ]
179+ )
180+
181+
182+toCustomTypeField :: Union -> ( Json.String, E.Value )
183+toCustomTypeField (Union name args constructors) =
184+ ( Json.fromName name
185+ , E.object
186+ [ "args" ==> E.list E.name args
187+ , "tags" ==> E.object (map toVariantObject constructors)
188+ ]
189+ )
190+
191+
192+toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )
193+toVariantObject (name, args) =
194+ ( Json.fromName name, E.list encode args )
compiler/src/Elm/Compiler/Type/Extract.hsnew file+285
@@ -0,0 +1,285 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}
3+module Elm.Compiler.Type.Extract
4+ ( fromAnnotation
5+ , fromType
6+ , Types(..)
7+ , mergeMany
8+ , merge
9+ , fromInterface
10+ , fromDependencyInterface
11+ , fromMsg
12+ )
13+ where
14+
15+
16+import Data.Map ((!))
17+import qualified Data.Map as Map
18+import qualified Data.Maybe as Maybe
19+import qualified Data.Name as Name
20+import qualified Data.Set as Set
21+
22+import qualified AST.Canonical as Can
23+import qualified AST.Optimized as Opt
24+import qualified AST.Utils.Type as Type
25+import qualified Elm.Compiler.Type as T
26+import qualified Elm.Interface as I
27+import qualified Elm.ModuleName as ModuleName
28+
29+
30+
31+-- EXTRACTION
32+
33+
34+fromAnnotation :: Can.Annotation -> T.Type
35+fromAnnotation (Can.Forall _ astType) =
36+ fromType astType
37+
38+
39+fromType :: Can.Type -> T.Type
40+fromType astType =
41+ snd (run (extract astType))
42+
43+
44+extract :: Can.Type -> Extractor T.Type
45+extract astType =
46+ case astType of
47+ Can.TLambda arg result ->
48+ T.Lambda
49+ <$> extract arg
50+ <*> extract result
51+
52+ Can.TVar x ->
53+ pure (T.Var x)
54+
55+ Can.TType home name args ->
56+ addUnion (Opt.Global home name) (T.Type (toPublicName home name))
57+ <*> traverse extract args
58+
59+ Can.TRecord fields ext ->
60+ do efields <- traverse (traverse extract) (Can.fieldsToList fields)
61+ pure (T.Record efields ext)
62+
63+ Can.TUnit ->
64+ pure T.Unit
65+
66+ Can.TTuple a b maybeC ->
67+ T.Tuple
68+ <$> extract a
69+ <*> extract b
70+ <*> traverse extract (Maybe.maybeToList maybeC)
71+
72+ Can.TAlias home name args aliasType ->
73+ do addAlias (Opt.Global home name) ()
74+ _ <- extract (Type.dealias args aliasType)
75+ T.Type (toPublicName home name)
76+ <$> traverse (extract . snd) args
77+
78+
79+toPublicName :: ModuleName.Canonical -> Name.Name -> Name.Name
80+toPublicName (ModuleName.Canonical _ home) name =
81+ Name.sepBy 0x2E {- . -} home name
82+
83+
84+
85+-- TRANSITIVELY AVAILABLE TYPES
86+
87+
88+newtype Types =
89+ Types (Map.Map ModuleName.Canonical Types_)
90+ -- PERF profile Opt.Global representation
91+ -- current representation needs less allocation
92+ -- but maybe the lookup is much worse
93+
94+
95+data Types_ =
96+ Types_
97+ { _union_info :: Map.Map Name.Name Can.Union
98+ , _alias_info :: Map.Map Name.Name Can.Alias
99+ }
100+
101+
102+mergeMany :: [Types] -> Types
103+mergeMany listOfTypes =
104+ case listOfTypes of
105+ [] -> Types Map.empty
106+ t:ts -> foldr merge t ts
107+
108+
109+merge :: Types -> Types -> Types
110+merge (Types types1) (Types types2) =
111+ Types (Map.union types1 types2)
112+
113+
114+fromInterface :: ModuleName.Raw -> I.Interface -> Types
115+fromInterface name (I.Interface pkg _ unions aliases _) =
116+ Types $ Map.singleton (ModuleName.Canonical pkg name) $
117+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
118+
119+
120+fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types
121+fromDependencyInterface home di =
122+ Types $ Map.singleton home $
123+ case di of
124+ I.Public (I.Interface _ _ unions aliases _) ->
125+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
126+
127+ I.Private _ unions aliases ->
128+ Types_ unions aliases
129+
130+
131+
132+-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
133+
134+
135+fromMsg :: Types -> Can.Type -> T.DebugMetadata
136+fromMsg types message =
137+ let
138+ (msgDeps, msgType) =
139+ run (extract message)
140+
141+ (aliases, unions) =
142+ extractTransitive types noDeps msgDeps
143+ in
144+ T.DebugMetadata msgType aliases unions
145+
146+
147+extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )
148+extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
149+ let
150+ aliases = Set.difference nextAliases seenAliases
151+ unions = Set.difference nextUnions seenUnions
152+ in
153+ if Set.null aliases && Set.null unions then
154+ ( [], [] )
155+
156+ else
157+ let
158+ (newDeps, result) =
159+ run $
160+ (,)
161+ <$> traverse (extractAlias types) (Set.toList aliases)
162+ <*> traverse (extractUnion types) (Set.toList unions)
163+
164+ oldDeps =
165+ Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
166+
167+ remainingResult =
168+ extractTransitive types oldDeps newDeps
169+ in
170+ mappend result remainingResult
171+
172+
173+extractAlias :: Types -> Opt.Global -> Extractor T.Alias
174+extractAlias (Types dict) (Opt.Global home name) =
175+ let
176+ (Can.Alias args aliasType) = _alias_info (dict ! home) ! name
177+ in
178+ T.Alias (toPublicName home name) args <$> extract aliasType
179+
180+
181+extractUnion :: Types -> Opt.Global -> Extractor T.Union
182+extractUnion (Types dict) (Opt.Global home name) =
183+ if name == Name.list && home == ModuleName.list
184+ then return $ T.Union (toPublicName home name) ["a"] []
185+ else
186+ let
187+ pname = toPublicName home name
188+ (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name
189+ in
190+ T.Union pname vars <$> traverse extractCtor ctors
191+
192+
193+extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])
194+extractCtor (Can.Ctor ctor _ _ args) =
195+ (,) ctor <$> traverse extract args
196+
197+
198+
199+-- DEPS
200+
201+
202+data Deps =
203+ Deps
204+ { _aliases :: Set.Set Opt.Global
205+ , _unions :: Set.Set Opt.Global
206+ }
207+
208+
209+{-# NOINLINE noDeps #-}
210+noDeps :: Deps
211+noDeps =
212+ Deps Set.empty Set.empty
213+
214+
215+
216+-- EXTRACTOR
217+
218+
219+newtype Extractor a =
220+ Extractor (
221+ forall result.
222+ Set.Set Opt.Global
223+ -> Set.Set Opt.Global
224+ -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result)
225+ -> result
226+ )
227+
228+
229+run :: Extractor a -> (Deps, a)
230+run (Extractor k) =
231+ k Set.empty Set.empty $ \aliases unions value ->
232+ ( Deps aliases unions, value )
233+
234+
235+addAlias :: Opt.Global -> a -> Extractor a
236+addAlias alias value =
237+ Extractor $ \aliases unions ok ->
238+ ok (Set.insert alias aliases) unions value
239+
240+
241+addUnion :: Opt.Global -> a -> Extractor a
242+addUnion union value =
243+ Extractor $ \aliases unions ok ->
244+ ok aliases (Set.insert union unions) value
245+
246+
247+instance Functor Extractor where
248+ fmap func (Extractor k) =
249+ Extractor $ \aliases unions ok ->
250+ let
251+ ok1 a1 u1 value =
252+ ok a1 u1 (func value)
253+ in
254+ k aliases unions ok1
255+
256+
257+instance Applicative Extractor where
258+ pure value =
259+ Extractor $ \aliases unions ok ->
260+ ok aliases unions value
261+
262+ (<*>) (Extractor kf) (Extractor kv) =
263+ Extractor $ \aliases unions ok ->
264+ let
265+ ok1 a1 u1 func =
266+ let
267+ ok2 a2 u2 value =
268+ ok a2 u2 (func value)
269+ in
270+ kv a1 u1 ok2
271+ in
272+ kf aliases unions ok1
273+
274+
275+instance Monad Extractor where
276+ return = pure
277+
278+ (>>=) (Extractor ka) callback =
279+ Extractor $ \aliases unions ok ->
280+ let
281+ ok1 a1 u1 value =
282+ case callback value of
283+ Extractor kb -> kb a1 u1 ok
284+ in
285+ ka aliases unions ok1
compiler/src/Elm/Constraint.hsnew file+260
@@ -0,0 +1,260 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Constraint
4+ ( Constraint
5+ , exactly
6+ , anything
7+ , toChars
8+ , satisfies
9+ , check
10+ , intersect
11+ , goodElm
12+ , defaultElm
13+ , untilNextMajor
14+ , untilNextMinor
15+ , expand
16+ --
17+ , Error(..)
18+ , decoder
19+ , encode
20+ )
21+ where
22+
23+
24+import Control.Monad (liftM4)
25+import Data.Binary (Binary, get, put, getWord8, putWord8)
26+
27+import qualified Elm.Version as V
28+import qualified Json.Decode as D
29+import qualified Json.Encode as E
30+import qualified Parse.Primitives as P
31+import Parse.Primitives (Row, Col)
32+
33+
34+
35+-- CONSTRAINTS
36+
37+
38+data Constraint
39+ = Range V.Version Op Op V.Version
40+ deriving (Eq)
41+
42+
43+data Op
44+ = Less
45+ | LessOrEqual
46+ deriving (Eq)
47+
48+
49+
50+-- COMMON CONSTRAINTS
51+
52+
53+exactly :: V.Version -> Constraint
54+exactly version =
55+ Range version LessOrEqual LessOrEqual version
56+
57+
58+anything :: Constraint
59+anything =
60+ Range V.one LessOrEqual LessOrEqual V.max
61+
62+
63+
64+-- TO CHARS
65+
66+
67+toChars :: Constraint -> [Char]
68+toChars constraint =
69+ case constraint of
70+ Range lower lowerOp upperOp upper ->
71+ V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper
72+
73+
74+opToChars :: Op -> [Char]
75+opToChars op =
76+ case op of
77+ Less -> " < "
78+ LessOrEqual -> " <= "
79+
80+
81+
82+-- IS SATISFIED
83+
84+
85+satisfies :: Constraint -> V.Version -> Bool
86+satisfies constraint version =
87+ case constraint of
88+ Range lower lowerOp upperOp upper ->
89+ isLess lowerOp lower version
90+ &&
91+ isLess upperOp version upper
92+
93+
94+isLess :: (Ord a) => Op -> (a -> a -> Bool)
95+isLess op =
96+ case op of
97+ Less ->
98+ (<)
99+
100+ LessOrEqual ->
101+ (<=)
102+
103+
104+check :: Constraint -> V.Version -> Ordering
105+check constraint version =
106+ case constraint of
107+ Range lower lowerOp upperOp upper ->
108+ if not (isLess lowerOp lower version) then
109+ LT
110+
111+ else if not (isLess upperOp version upper) then
112+ GT
113+
114+ else
115+ EQ
116+
117+
118+
119+-- INTERSECT
120+
121+
122+intersect :: Constraint -> Constraint -> Maybe Constraint
123+intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) =
124+ let
125+ (newLo, newLop) =
126+ case compare lo lo_ of
127+ LT -> (lo_, lop_)
128+ EQ -> (lo, if elem Less [lop,lop_] then Less else LessOrEqual)
129+ GT -> (lo, lop)
130+
131+ (newHi, newHop) =
132+ case compare hi hi_ of
133+ LT -> (hi, hop)
134+ EQ -> (hi, if elem Less [hop, hop_] then Less else LessOrEqual)
135+ GT -> (hi_, hop_)
136+ in
137+ if newLo <= newHi then
138+ Just (Range newLo newLop newHop newHi)
139+ else
140+ Nothing
141+
142+
143+
144+-- ELM CONSTRAINT
145+
146+
147+goodElm :: Constraint -> Bool
148+goodElm constraint =
149+ satisfies constraint V.compiler
150+
151+
152+defaultElm :: Constraint
153+defaultElm =
154+ if V._major V.compiler > 0
155+ then untilNextMajor V.compiler
156+ else untilNextMinor V.compiler
157+
158+
159+
160+-- CREATE CONSTRAINTS
161+
162+
163+untilNextMajor :: V.Version -> Constraint
164+untilNextMajor version =
165+ Range version LessOrEqual Less (V.bumpMajor version)
166+
167+
168+untilNextMinor :: V.Version -> Constraint
169+untilNextMinor version =
170+ Range version LessOrEqual Less (V.bumpMinor version)
171+
172+
173+expand :: Constraint -> V.Version -> Constraint
174+expand constraint@(Range lower lowerOp upperOp upper) version
175+ | version < lower =
176+ Range version LessOrEqual upperOp upper
177+
178+ | version > upper =
179+ Range lower lowerOp Less (V.bumpMajor version)
180+
181+ | otherwise =
182+ constraint
183+
184+
185+
186+-- JSON
187+
188+
189+encode :: Constraint -> E.Value
190+encode constraint =
191+ E.chars (toChars constraint)
192+
193+
194+decoder :: D.Decoder Error Constraint
195+decoder =
196+ D.customString parser BadFormat
197+
198+
199+
200+-- BINARY
201+
202+
203+instance Binary Constraint where
204+ get = liftM4 Range get get get get
205+ put (Range a b c d) = put a >> put b >> put c >> put d
206+
207+
208+instance Binary Op where
209+ put op =
210+ case op of
211+ Less -> putWord8 0
212+ LessOrEqual -> putWord8 1
213+
214+ get =
215+ do n <- getWord8
216+ case n of
217+ 0 -> return Less
218+ 1 -> return LessOrEqual
219+ _ -> fail "binary encoding of Op was corrupted"
220+
221+
222+
223+-- PARSER
224+
225+
226+data Error
227+ = BadFormat Row Col
228+ | InvalidRange V.Version V.Version
229+
230+
231+parser :: P.Parser Error Constraint
232+parser =
233+ do lower <- parseVersion
234+ P.word1 0x20 {- -} BadFormat
235+ loOp <- parseOp
236+ P.word1 0x20 {- -} BadFormat
237+ P.word1 0x76 {-v-} BadFormat
238+ P.word1 0x20 {- -} BadFormat
239+ hiOp <- parseOp
240+ P.word1 0x20 {- -} BadFormat
241+ higher <- parseVersion
242+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
243+ if lower < higher
244+ then eok (Range lower loOp hiOp higher) state
245+ else eerr row col (\_ _ -> InvalidRange lower higher)
246+
247+
248+parseVersion :: P.Parser Error V.Version
249+parseVersion =
250+ P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser
251+
252+
253+parseOp :: P.Parser Error Op
254+parseOp =
255+ do P.word1 0x3C {-<-} BadFormat
256+ P.oneOfWithFallback
257+ [ do P.word1 0x3D {-=-} BadFormat
258+ return LessOrEqual
259+ ]
260+ Less
compiler/src/Elm/Docs.hsnew file+587
@@ -0,0 +1,587 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
3+module Elm.Docs
4+ ( Documentation
5+ , Module(..)
6+ , fromModule
7+ , Union(..)
8+ , Alias(..)
9+ , Value(..)
10+ , Binop(..)
11+ , Binop.Associativity(..)
12+ , Binop.Precedence(..)
13+ , Error(..)
14+ , decoder
15+ , encode
16+ )
17+ where
18+
19+
20+import qualified Data.Coerce as Coerce
21+import qualified Data.List as List
22+import Data.Map ((!))
23+import qualified Data.Map as Map
24+import qualified Data.Map.Merge.Strict as Map
25+import qualified Data.Name as Name
26+import qualified Data.NonEmptyList as NE
27+import qualified Data.OneOrMore as OneOrMore
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr)
30+
31+import qualified AST.Canonical as Can
32+import qualified AST.Source as Src
33+import qualified AST.Utils.Binop as Binop
34+import qualified Elm.Compiler.Type as Type
35+import qualified Elm.Compiler.Type.Extract as Extract
36+import qualified Elm.ModuleName as ModuleName
37+import qualified Json.Decode as D
38+import qualified Json.Encode as E
39+import Json.Encode ((==>))
40+import qualified Json.String as Json
41+import Parse.Primitives (Row, Col, word1)
42+import qualified Parse.Primitives as P
43+import qualified Parse.Space as Space
44+import qualified Parse.Symbol as Symbol
45+import qualified Parse.Variable as Var
46+import qualified Reporting.Annotation as A
47+import qualified Reporting.Error.Docs as E
48+import qualified Reporting.Result as Result
49+
50+
51+
52+-- DOCUMENTATION
53+
54+
55+type Documentation =
56+ Map.Map Name.Name Module
57+
58+
59+data Module =
60+ Module
61+ { _name :: Name.Name
62+ , _comment :: Comment
63+ , _unions :: Map.Map Name.Name Union
64+ , _aliases :: Map.Map Name.Name Alias
65+ , _values :: Map.Map Name.Name Value
66+ , _binops :: Map.Map Name.Name Binop
67+ }
68+
69+type Comment = Json.String
70+
71+data Alias = Alias Comment [Name.Name] Type.Type
72+data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
73+data Value = Value Comment Type.Type
74+data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
75+
76+
77+
78+-- JSON
79+
80+
81+encode :: Documentation -> E.Value
82+encode docs =
83+ E.list encodeModule (Map.elems docs)
84+
85+
86+encodeModule :: Module -> E.Value
87+encodeModule (Module name comment unions aliases values binops) =
88+ E.object $
89+ [ "name" ==> ModuleName.encode name
90+ , "comment" ==> E.string comment
91+ , "unions" ==> E.list encodeUnion (Map.toList unions)
92+ , "aliases" ==> E.list encodeAlias (Map.toList aliases)
93+ , "values" ==> E.list encodeValue (Map.toList values)
94+ , "binops" ==> E.list encodeBinop (Map.toList binops)
95+ ]
96+
97+
98+data Error
99+ = BadAssociativity
100+ | BadModuleName
101+ | BadType
102+
103+
104+decoder :: D.Decoder Error Documentation
105+decoder =
106+ toDict <$> D.list moduleDecoder
107+
108+
109+toDict :: [Module] -> Documentation
110+toDict modules =
111+ Map.fromList (map toDictHelp modules)
112+
113+
114+toDictHelp :: Module -> (Name.Name, Module)
115+toDictHelp modul@(Module name _ _ _ _ _) =
116+ (name, modul)
117+
118+
119+moduleDecoder :: D.Decoder Error Module
120+moduleDecoder =
121+ Module
122+ <$> D.field "name" moduleNameDecoder
123+ <*> D.field "comment" D.string
124+ <*> D.field "unions" (dictDecoder union)
125+ <*> D.field "aliases" (dictDecoder alias)
126+ <*> D.field "values" (dictDecoder value)
127+ <*> D.field "binops" (dictDecoder binop)
128+
129+
130+dictDecoder :: D.Decoder Error a -> D.Decoder Error (Map.Map Name.Name a)
131+dictDecoder entryDecoder =
132+ Map.fromList <$> D.list (named entryDecoder)
133+
134+
135+named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
136+named entryDecoder =
137+ (,)
138+ <$> D.field "name" nameDecoder
139+ <*> entryDecoder
140+
141+
142+nameDecoder :: D.Decoder e Name.Name
143+nameDecoder =
144+ fmap Coerce.coerce D.string
145+
146+
147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148+moduleNameDecoder =
149+ D.mapError (const BadModuleName) ModuleName.decoder
150+
151+
152+typeDecoder :: D.Decoder Error Type.Type
153+typeDecoder =
154+ D.mapError (const BadType) Type.decoder
155+
156+
157+
158+-- UNION JSON
159+
160+
161+encodeUnion :: (Name.Name, Union) -> E.Value
162+encodeUnion (name, Union comment args cases) =
163+ E.object
164+ [ "name" ==> E.name name
165+ , "comment" ==> E.string comment
166+ , "args" ==> E.list E.name args
167+ , "cases" ==> E.list encodeCase cases
168+ ]
169+
170+
171+union :: D.Decoder Error Union
172+union =
173+ Union
174+ <$> D.field "comment" D.string
175+ <*> D.field "args" (D.list nameDecoder)
176+ <*> D.field "cases" (D.list caseDecoder)
177+
178+
179+encodeCase :: ( Name.Name, [Type.Type] ) -> E.Value
180+encodeCase ( tag, args ) =
181+ E.list id [ E.name tag, E.list Type.encode args ]
182+
183+
184+caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
185+caseDecoder =
186+ D.pair nameDecoder (D.list typeDecoder)
187+
188+
189+
190+-- ALIAS JSON
191+
192+
193+encodeAlias :: (Name.Name, Alias) -> E.Value
194+encodeAlias ( name, Alias comment args tipe) =
195+ E.object
196+ [ "name" ==> E.name name
197+ , "comment" ==> E.string comment
198+ , "args" ==> E.list E.name args
199+ , "type" ==> Type.encode tipe
200+ ]
201+
202+
203+alias :: D.Decoder Error Alias
204+alias =
205+ Alias
206+ <$> D.field "comment" D.string
207+ <*> D.field "args" (D.list nameDecoder)
208+ <*> D.field "type" typeDecoder
209+
210+
211+
212+-- VALUE JSON
213+
214+
215+encodeValue :: (Name.Name, Value) -> E.Value
216+encodeValue (name, Value comment tipe) =
217+ E.object
218+ [ "name" ==> E.name name
219+ , "comment" ==> E.string comment
220+ , "type" ==> Type.encode tipe
221+ ]
222+
223+
224+value :: D.Decoder Error Value
225+value =
226+ Value
227+ <$> D.field "comment" D.string
228+ <*> D.field "type" typeDecoder
229+
230+
231+
232+-- BINOP JSON
233+
234+
235+encodeBinop :: (Name.Name, Binop) -> E.Value
236+encodeBinop (name, Binop comment tipe assoc prec) =
237+ E.object
238+ [ "name" ==> E.name name
239+ , "comment" ==> E.string comment
240+ , "type" ==> Type.encode tipe
241+ , "associativity" ==> encodeAssoc assoc
242+ , "precedence" ==> encodePrec prec
243+ ]
244+
245+
246+binop :: D.Decoder Error Binop
247+binop =
248+ Binop
249+ <$> D.field "comment" D.string
250+ <*> D.field "type" typeDecoder
251+ <*> D.field "associativity" assocDecoder
252+ <*> D.field "precedence" precDecoder
253+
254+
255+
256+-- ASSOCIATIVITY JSON
257+
258+
259+encodeAssoc :: Binop.Associativity -> E.Value
260+encodeAssoc assoc =
261+ case assoc of
262+ Binop.Left -> E.chars "left"
263+ Binop.Non -> E.chars "non"
264+ Binop.Right -> E.chars "right"
265+
266+
267+assocDecoder :: D.Decoder Error Binop.Associativity
268+assocDecoder =
269+ let
270+ left = Json.fromChars "left"
271+ non = Json.fromChars "non"
272+ right = Json.fromChars "right"
273+ in
274+ do str <- D.string
275+ if | str == left -> return Binop.Left
276+ | str == non -> return Binop.Non
277+ | str == right -> return Binop.Right
278+ | otherwise -> D.failure BadAssociativity
279+
280+
281+
282+-- PRECEDENCE JSON
283+
284+
285+encodePrec :: Binop.Precedence -> E.Value
286+encodePrec (Binop.Precedence n) =
287+ E.int n
288+
289+
290+precDecoder :: D.Decoder Error Binop.Precedence
291+precDecoder =
292+ Binop.Precedence <$> D.int
293+
294+
295+
296+-- FROM MODULE
297+
298+
299+fromModule :: Can.Module -> Either E.Error Module
300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
301+ case exports of
302+ Can.ExportEverything region ->
303+ Left (E.ImplicitExposing region)
304+
305+ Can.Export exportDict ->
306+ case docs of
307+ Src.NoDocs region ->
308+ Left (E.NoDocs region)
309+
310+ Src.YesDocs overview comments ->
311+ do names <- parseOverview overview
312+ checkNames exportDict names
313+ checkDefs exportDict overview (Map.fromList comments) modul
314+
315+
316+
317+-- PARSE OVERVIEW
318+
319+
320+parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
321+parseOverview (Src.Comment snippet) =
322+ case P.fromSnippet (chompOverview []) E.BadEnd snippet of
323+ Left err ->
324+ Left (E.SyntaxProblem err)
325+
326+ Right names ->
327+ Right names
328+
329+
330+type Parser a =
331+ P.Parser E.SyntaxProblem a
332+
333+
334+chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335+chompOverview names =
336+ do isDocs <- chompUntilDocs
337+ if isDocs
338+ then
339+ do Space.chomp E.Space
340+ chompOverview =<< chompDocs names
341+ else
342+ return names
343+
344+
345+chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
346+chompDocs names =
347+ do name <-
348+ P.addLocation $
349+ P.oneOf E.Name
350+ [ Var.lower E.Name
351+ , Var.upper E.Name
352+ , chompOperator
353+ ]
354+
355+ Space.chomp E.Space
356+
357+ P.oneOfWithFallback
358+ [ do pos <- P.getPosition
359+ Space.checkIndent pos E.Comma
360+ word1 0x2C {-,-} E.Comma
361+ Space.chomp E.Space
362+ chompDocs (name:names)
363+ ]
364+ (name:names)
365+
366+
367+chompOperator :: Parser Name.Name
368+chompOperator =
369+ do word1 0x28 {-(-} E.Op
370+ op <- Symbol.operator E.Op E.OpBad
371+ word1 0x29 {-)-} E.Op
372+ return op
373+
374+
375+-- TODO add rule that @docs must be after newline in 0.20
376+--
377+chompUntilDocs :: Parser Bool
378+chompUntilDocs =
379+ P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
380+ let
381+ (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col
382+ !newState = P.State src newPos end indent newRow newCol
383+ in
384+ cok isDocs newState
385+
386+
387+untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)
388+untilDocs pos end row col =
389+ if pos >= end then
390+ (# False, pos, row, col #)
391+ else
392+ let !word = P.unsafeIndex pos in
393+ if word == 0x0A {-\n-} then
394+ untilDocs (plusPtr pos 1) end (row + 1) 1
395+ else
396+ let !pos5 = plusPtr pos 5 in
397+ if pos5 <= end
398+ && P.unsafeIndex ( pos ) == 0x40 {-@-}
399+ && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}
400+ && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}
401+ && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}
402+ && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}
403+ && Var.getInnerWidth pos5 end == 0
404+ then
405+ (# True, pos5, row, col + 5 #)
406+ else
407+ let !newPos = plusPtr pos (P.getCharWidth word) in
408+ untilDocs newPos end row (col + 1)
409+
410+
411+
412+-- CHECK NAMES
413+
414+
415+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
416+checkNames exports names =
417+ let
418+ docs = List.foldl' addName Map.empty names
419+ loneDoc = Map.traverseMissing onlyInDocs
420+ loneExport = Map.traverseMissing onlyInExports
421+ checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)
422+ in
423+ case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of
424+ (_, Right _) -> Right ()
425+ (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))
426+
427+
428+type DocNameRegions =
429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
430+
431+
432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
433+addName dict (A.At region name) =
434+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
435+
436+
437+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
438+isUnique name regions =
439+ case regions of
440+ OneOrMore.One region ->
441+ Result.ok region
442+
443+ OneOrMore.More left right ->
444+ let (r1, r2) = OneOrMore.getFirstTwo left right in
445+ Result.throw (E.NameDuplicate name r1 r2)
446+
447+
448+onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
449+onlyInDocs name regions =
450+ do region <- isUnique name regions
451+ Result.throw $ E.NameOnlyInDocs name region
452+
453+
454+onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
455+onlyInExports name (A.At region _) =
456+ Result.throw $ E.NameOnlyInExports name region
457+
458+
459+
460+-- CHECK DEFS
461+
462+
463+checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module
464+checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =
465+ let
466+ types = gatherTypes decls Map.empty
467+ info = Info comments types unions aliases infixes effects
468+ in
469+ case Result.run (Map.traverseWithKey (checkExport info) exportDict) of
470+ (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)
471+ (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters
472+
473+
474+emptyModule :: ModuleName.Canonical -> Src.Comment -> Module
475+emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =
476+ Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty
477+
478+
479+data Info =
480+ Info
481+ { _iComments :: Map.Map Name.Name Src.Comment
482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
483+ , _iUnions :: Map.Map Name.Name Can.Union
484+ , _iAliases :: Map.Map Name.Name Can.Alias
485+ , _iBinops :: Map.Map Name.Name Can.Binop
486+ , _iEffects :: Can.Effects
487+ }
488+
489+
490+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
491+checkExport info name (A.At region export) =
492+ case export of
493+ Can.ExportValue ->
494+ do tipe <- getType name info
495+ comment <- getComment region name info
496+ Result.ok $ \m ->
497+ m { _values = Map.insert name (Value comment tipe) (_values m) }
498+
499+ Can.ExportBinop ->
500+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
501+ tipe <- getType realName info
502+ comment <- getComment region realName info
503+ Result.ok $ \m ->
504+ m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
505+
506+ Can.ExportAlias ->
507+ do let (Can.Alias tvars tipe) = _iAliases info ! name
508+ comment <- getComment region name info
509+ Result.ok $ \m ->
510+ m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
511+
512+ Can.ExportUnionOpen ->
513+ do let (Can.Union tvars ctors _ _) = _iUnions info ! name
514+ comment <- getComment region name info
515+ Result.ok $ \m ->
516+ m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
517+
518+ Can.ExportUnionClosed ->
519+ do let (Can.Union tvars _ _ _) = _iUnions info ! name
520+ comment <- getComment region name info
521+ Result.ok $ \m ->
522+ m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
523+
524+ Can.ExportPort ->
525+ do tipe <- getType name info
526+ comment <- getComment region name info
527+ Result.ok $ \m ->
528+ m { _values = Map.insert name (Value comment tipe) (_values m) }
529+
530+
531+getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
532+getComment region name info =
533+ case Map.lookup name (_iComments info) of
534+ Nothing ->
535+ Result.throw (E.NoComment name region)
536+
537+ Just (Src.Comment snippet) ->
538+ Result.ok (Json.fromComment snippet)
539+
540+
541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
542+getType name info =
543+ case _iValues info ! name of
544+ Left region ->
545+ Result.throw (E.NoAnnotation name region)
546+
547+ Right tipe ->
548+ Result.ok (Extract.fromType tipe)
549+
550+
551+dector :: Can.Ctor -> (Name.Name, [Type.Type])
552+dector (Can.Ctor name _ _ args) =
553+ ( name, map Extract.fromType args )
554+
555+
556+
557+-- GATHER TYPES
558+
559+
560+type Types =
561+ Map.Map Name.Name (Either A.Region Can.Type)
562+
563+
564+gatherTypes :: Can.Decls -> Types -> Types
565+gatherTypes decls types =
566+ case decls of
567+ Can.Declare def subDecls ->
568+ gatherTypes subDecls (addDef types def)
569+
570+ Can.DeclareRec def defs subDecls ->
571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
572+
573+ Can.SaveTheEnvironment ->
574+ types
575+
576+
577+addDef :: Types -> Can.Def -> Types
578+addDef types def =
579+ case def of
580+ Can.Def (A.At region name) _ _ ->
581+ Map.insert name (Left region) types
582+
583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
584+ let
585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)
586+ in
587+ Map.insert name (Right tipe) types
compiler/src/Elm/Float.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}
3+module Elm.Float
4+ ( Float
5+ , fromPtr
6+ , toBuilder
7+ )
8+ where
9+
10+
11+import Prelude hiding (Float)
12+import Data.Binary (Binary, get, put)
13+import qualified Data.ByteString.Builder as B
14+import qualified Data.Utf8 as Utf8
15+import Data.Word (Word8)
16+import Foreign.Ptr (Ptr)
17+
18+
19+
20+-- FLOATS
21+
22+
23+type Float =
24+ Utf8.Utf8 ELM_FLOAT
25+
26+
27+data ELM_FLOAT
28+
29+
30+
31+-- HELPERS
32+
33+
34+fromPtr :: Ptr Word8 -> Ptr Word8 -> Float
35+fromPtr =
36+ Utf8.fromPtr
37+
38+
39+{-# INLINE toBuilder #-}
40+toBuilder :: Float -> B.Builder
41+toBuilder =
42+ Utf8.toBuilder
43+
44+
45+
46+-- BINARY
47+
48+
49+instance Binary (Utf8.Utf8 ELM_FLOAT) where
50+ get = Utf8.getUnder256
51+ put = Utf8.putUnder256
compiler/src/Elm/Interface.hsnew file+254

This diff is too big to show here.

compiler/src/Elm/Kernel.hsnew file+365

This diff is too big to show here.

compiler/src/Elm/Licenses.hsnew file+185

This diff is too big to show here.

compiler/src/Elm/Magnitude.hsnew file+24

This diff is too big to show here.

compiler/src/Elm/ModuleName.hsnew file+283

This diff is too big to show here.

compiler/src/Elm/Package.hsnew file+374

This diff is too big to show here.

compiler/src/Elm/String.hsnew file+133

This diff is too big to show here.

compiler/src/Elm/Version.hsnew file+196

This diff is too big to show here.

compiler/src/Generate/Html.hsnew file+54

This diff is too big to show here.

compiler/src/Generate/JavaScript.hsnew file+590

This diff is too big to show here.

compiler/src/Generate/JavaScript/Builder.hsnew file+530

This diff is too big to show here.

compiler/src/Generate/JavaScript/Expression.hsnew file+1070

This diff is too big to show here.

compiler/src/Generate/JavaScript/Functions.hsnew file+95

This diff is too big to show here.

compiler/src/Generate/JavaScript/Name.hsnew file+261

This diff is too big to show here.

compiler/src/Generate/Mode.hsnew file+63

This diff is too big to show here.

compiler/src/Json/Decode.hsnew file+799

This diff is too big to show here.

compiler/src/Json/Encode.hsnew file+310

This diff is too big to show here.

compiler/src/Json/String.hsnew file+192

This diff is too big to show here.

compiler/src/Nitpick/Debug.hsnew file+87

This diff is too big to show here.

compiler/src/Nitpick/PatternMatches.hsnew file+653

This diff is too big to show here.

src/Optimize/Case.hs → compiler/src/Optimize/Case.hsrenamed+18−30

This diff is too big to show here.

compiler/src/Optimize/DecisionTree.hsnew file+637

This diff is too big to show here.

compiler/src/Optimize/Expression.hsnew file+490

This diff is too big to show here.

compiler/src/Optimize/Module.hsnew file+369

This diff is too big to show here.

compiler/src/Optimize/Names.hsnew file+173

This diff is too big to show here.

compiler/src/Optimize/Port.hsnew file+327

This diff is too big to show here.

compiler/src/Parse/Declaration.hsnew file+266

This diff is too big to show here.

compiler/src/Parse/Expression.hsnew file+577

This diff is too big to show here.

compiler/src/Parse/Keyword.hsnew file+265

This diff is too big to show here.

compiler/src/Parse/Module.hsnew file+487

This diff is too big to show here.

compiler/src/Parse/Number.hsnew file+305

This diff is too big to show here.

compiler/src/Parse/Pattern.hsnew file+279

This diff is too big to show here.

compiler/src/Parse/Primitives.hsnew file+404

This diff is too big to show here.

compiler/src/Parse/Shader.hsnew file+181

This diff is too big to show here.

compiler/src/Parse/Space.hsnew file+273

This diff is too big to show here.

compiler/src/Parse/String.hsnew file+343

This diff is too big to show here.

compiler/src/Parse/Symbol.hsnew file+79

This diff is too big to show here.

compiler/src/Parse/Type.hsnew file+203

This diff is too big to show here.

compiler/src/Parse/Variable.hsnew file+387

This diff is too big to show here.

compiler/src/Reporting/Annotation.hsnew file+103

This diff is too big to show here.

compiler/src/Reporting/Doc.hsnew file+431

This diff is too big to show here.

compiler/src/Reporting/Error.hsnew file+210

This diff is too big to show here.

compiler/src/Reporting/Error/Canonicalize.hsnew file+1261

This diff is too big to show here.

compiler/src/Reporting/Error/Docs.hsnew file+250

This diff is too big to show here.

compiler/src/Reporting/Error/Import.hsnew file+162

This diff is too big to show here.

compiler/src/Reporting/Error/Json.hsnew file+344

This diff is too big to show here.

compiler/src/Reporting/Error/Main.hsnew file+124

This diff is too big to show here.

compiler/src/Reporting/Error/Pattern.hsnew file+195

This diff is too big to show here.

compiler/src/Reporting/Error/Syntax.hsnew file+5848

This diff is too big to show here.

compiler/src/Reporting/Error/Type.hsnew file+1613

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hsnew file+288

This diff is too big to show here.

compiler/src/Reporting/Render/Type.hsnew file+257

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hsnew file+120

This diff is too big to show here.

compiler/src/Reporting/Report.hsnew file+22

This diff is too big to show here.

compiler/src/Reporting/Result.hsnew file+129

This diff is too big to show here.

compiler/src/Reporting/Suggest.hsnew file+52

This diff is too big to show here.

compiler/src/Reporting/Warning.hsnew file+104

This diff is too big to show here.

compiler/src/Type/Constrain/Expression.hsnew file+746

This diff is too big to show here.

compiler/src/Type/Constrain/Module.hsnew file+183

This diff is too big to show here.

compiler/src/Type/Constrain/Pattern.hsnew file+237

This diff is too big to show here.

compiler/src/Type/Error.hsnew file+589

This diff is too big to show here.

compiler/src/Type/Instantiate.hsnew file+77

This diff is too big to show here.

compiler/src/Type/Occurs.hsnew file+80

This diff is too big to show here.

compiler/src/Type/Solve.hsnew file+727

This diff is too big to show here.

compiler/src/Type/Type.hsnew file+726

This diff is too big to show here.

compiler/src/Type/Unify.hsnew file+695

This diff is too big to show here.

compiler/src/Type/UnionFind.hsnew file+172

This diff is too big to show here.

docs/elm.json/application.mdnew file+69

This diff is too big to show here.

docs/elm.json/package.mdnew file+93

This diff is too big to show here.

docs/upgrade-instructions/0.16.mdnew file+174

This diff is too big to show here.

docs/upgrade-instructions/0.17.mdnew file+275

This diff is too big to show here.

docs/upgrade-instructions/0.18.mdnew file+161

This diff is too big to show here.

docs/upgrade-instructions/0.19.0.mdnew file+164

This diff is too big to show here.

docs/upgrade-instructions/0.19.1.mdnew file+60

This diff is too big to show here.

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

The content is the same.

elm-compiler.cabaldeleted−235

This diff is too big to show here.

elm.cabalnew file+238

This diff is too big to show here.

hints/bad-recursion.mdnew file+133

This diff is too big to show here.

hints/comparing-custom-types.mdnew file+98

This diff is too big to show here.

hints/comparing-records.mdnew file+85

This diff is too big to show here.

hints/implicit-casts.mdnew file+50

This diff is too big to show here.

hints/import-cycles.mdnew file+184

This diff is too big to show here.

hints/imports.mdnew file+126

This diff is too big to show here.

hints/infinite-type.md+20−94

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.md+66−69

This diff is too big to show here.

hints/optimize.mdnew file+59

This diff is too big to show here.

hints/port-modules.mdnew file+32

This diff is too big to show here.

hints/recursive-alias.md+4−3

This diff is too big to show here.

hints/repl.mdnew file+73

This diff is too big to show here.

hints/shadowing.mdnew file+70

This diff is too big to show here.

hints/tuples.mdnew file+19

This diff is too big to show here.

hints/type-annotations.md+2−8

This diff is too big to show here.

installers/README.mdnew file+32

This diff is too big to show here.

installers/linux/Dockerfilenew file+39

This diff is too big to show here.

installers/linux/README.mdnew file+93

This diff is too big to show here.

installers/mac/Distribution.xmlnew file+33

This diff is too big to show here.

installers/mac/README.mdnew file+93

This diff is too big to show here.

installers/mac/Resources/en.lproj/conclusion.rtfnew file+16

This diff is too big to show here.

installers/mac/Resources/en.lproj/welcome.rtfnew file+12

This diff is too big to show here.

installers/mac/helper-scripts/elm-startup.shnew file+3

This diff is too big to show here.

installers/mac/helper-scripts/uninstall.shnew file+21

This diff is too big to show here.

installers/mac/make-installer.shnew file+81

This diff is too big to show here.

installers/mac/postinstallnew file+5

This diff is too big to show here.

installers/mac/preinstallnew file+18

This diff is too big to show here.

installers/npm/.gitignorenew file+1

This diff is too big to show here.

installers/npm/.npmignorenew file+3

This diff is too big to show here.

installers/npm/PUBLISHING.mdnew file+59

This diff is too big to show here.

installers/npm/README.mdnew file+45

This diff is too big to show here.

installers/npm/bin/elmnew file+54

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/install.jsnew file+4

This diff is too big to show here.

installers/npm/package.jsonnew file+42

This diff is too big to show here.

installers/npm/troubleshooting.mdnew file+76

This diff is too big to show here.

installers/win/CreateInternetShortcut.nshnew file+5

This diff is too big to show here.

installers/win/Nsisfile.nsinew file+264

This diff is too big to show here.

installers/win/README.mdnew file+24

This diff is too big to show here.

installers/win/inst.datnew file+6

This diff is too big to show here.

installers/win/logo.iconew file

Binary file not shown.

installers/win/make_installer.cmdnew file+18

This diff is too big to show here.

installers/win/removefrompath.vbsnew file+17

This diff is too big to show here.

installers/win/uninst.datnew file+6

This diff is too big to show here.

installers/win/updatepath.vbsnew file+14

This diff is too big to show here.

installers/win/welcome.bmpnew file

Binary file not shown.

reactor/assets/favicon.iconew file

Binary file not shown.

reactor/assets/source-code-pro.ttfnew file

Binary file not shown.

reactor/assets/source-sans-pro.ttfnew file

Binary file not shown.

reactor/assets/styles.cssnew file+157

This diff is too big to show here.

reactor/check.pynew file+48

This diff is too big to show here.

reactor/elm.jsonnew file+31

This diff is too big to show here.

reactor/src/Deps.elmnew file+1210

This diff is too big to show here.

reactor/src/Errors.elmnew file+207

This diff is too big to show here.

reactor/src/Index.elmnew file+280

This diff is too big to show here.

reactor/src/Index/Icon.elmnew file+111

This diff is too big to show here.

reactor/src/Index/Navigator.elmnew file+63

This diff is too big to show here.

reactor/src/Index/Skeleton.elmnew file+61

This diff is too big to show here.

reactor/src/NotFound.elmnew file+29

This diff is too big to show here.

reactor/src/mock.txtnew file+33

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

src/AST/Declaration.hsdeleted−152

This diff is too big to show here.

src/AST/Effects.hsdeleted−68

This diff is too big to show here.

src/AST/Expression/Canonical.hsdeleted−72

This diff is too big to show here.

src/AST/Expression/General.hsdeleted−112

This diff is too big to show here.

src/AST/Expression/Optimized.hsdeleted−81

This diff is too big to show here.

src/AST/Expression/Source.hsdeleted−31

This diff is too big to show here.

src/AST/Expression/Valid.hsdeleted−30

This diff is too big to show here.

src/AST/Helpers.hsdeleted−32

This diff is too big to show here.

src/AST/Literal.hsdeleted−54

This diff is too big to show here.

src/AST/Module.hsdeleted−222

This diff is too big to show here.

src/AST/Module/Name.hsdeleted−54

This diff is too big to show here.

src/AST/Pattern.hsdeleted−109

This diff is too big to show here.

src/AST/Type.hsdeleted−219

This diff is too big to show here.

src/AST/Variable.hsdeleted−334

This diff is too big to show here.

src/Canonicalize.hsdeleted−481

This diff is too big to show here.

src/Canonicalize/Body.hsdeleted−170

This diff is too big to show here.

src/Canonicalize/Effects.hsdeleted−137

This diff is too big to show here.

src/Canonicalize/Environment.hsdeleted−160

This diff is too big to show here.

src/Canonicalize/Setup.hsdeleted−452

This diff is too big to show here.

src/Canonicalize/Sort.hsdeleted−235

This diff is too big to show here.

src/Canonicalize/Type.hsdeleted−92

This diff is too big to show here.

src/Canonicalize/Variable.hsdeleted−293

This diff is too big to show here.

src/CommandLineRouter.hsdeleted−84

This diff is too big to show here.

src/Compile.hsdeleted−80

This diff is too big to show here.

src/Docs/AST.hsdeleted−44

This diff is too big to show here.

src/Docs/Centralize.hsdeleted−80

This diff is too big to show here.

src/Docs/Check.hsdeleted−181

This diff is too big to show here.

src/Elm/Compiler.hsdeleted−194

This diff is too big to show here.

src/Elm/Compiler/Imports.hsdeleted−39

This diff is too big to show here.

src/Elm/Compiler/Module.hsdeleted−138

This diff is too big to show here.

src/Elm/Compiler/Type.hsdeleted−197

This diff is too big to show here.

src/Elm/Compiler/Type/Extract.hsdeleted−45

This diff is too big to show here.

src/Elm/Compiler/Version.hsdeleted−27

This diff is too big to show here.

src/Elm/Docs.hsdeleted−250

This diff is too big to show here.

src/Elm/Package.hsdeleted−254

This diff is too big to show here.

src/Elm/Utils.hsdeleted−107

This diff is too big to show here.

src/Generate/JavaScript.hsdeleted−91

This diff is too big to show here.

src/Generate/JavaScript/Builder.hsdeleted−528

This diff is too big to show here.

src/Generate/JavaScript/BuiltIn.hsdeleted−135

This diff is too big to show here.

src/Generate/JavaScript/Expression.hsdeleted−545

This diff is too big to show here.

src/Generate/JavaScript/Foreign.hsdeleted−219

This diff is too big to show here.

src/Generate/JavaScript/Helpers.hsdeleted−68

This diff is too big to show here.

src/Generate/JavaScript/Literal.hsdeleted−25

This diff is too big to show here.

src/Generate/JavaScript/Variable.hsdeleted−181

This diff is too big to show here.

src/Nitpick/Pattern.hsdeleted−118

This diff is too big to show here.

src/Nitpick/PatternMatches.hsdeleted−386

This diff is too big to show here.

src/Nitpick/TopLevelTypes.hsdeleted−125

This diff is too big to show here.

src/Optimize.hsdeleted−517

This diff is too big to show here.

src/Optimize/DecisionTree.hsdeleted−467

This diff is too big to show here.

src/Optimize/Environment.hsdeleted−59

This diff is too big to show here.

src/Optimize/Inline.hsdeleted−305

This diff is too big to show here.

src/Parse/Binop.hsdeleted−131

This diff is too big to show here.

src/Parse/Declaration.hsdeleted−99

This diff is too big to show here.

src/Parse/Expression.hsdeleted−330

This diff is too big to show here.

src/Parse/Helpers.hsdeleted−652

This diff is too big to show here.

src/Parse/Literal.hsdeleted−71

This diff is too big to show here.

src/Parse/Module.hsdeleted−178

This diff is too big to show here.

src/Parse/Parse.hsdeleted−140

This diff is too big to show here.

src/Parse/Pattern.hsdeleted−113

This diff is too big to show here.

src/Parse/Type.hsdeleted−105

This diff is too big to show here.

src/Reporting/Annotation.hsdeleted−54

This diff is too big to show here.

src/Reporting/Bag.hsdeleted−101

This diff is too big to show here.

src/Reporting/Error.hsdeleted−89

This diff is too big to show here.

src/Reporting/Error/Canonicalize.hsdeleted−328

This diff is too big to show here.

src/Reporting/Error/Docs.hsdeleted−74

This diff is too big to show here.

src/Reporting/Error/Helpers.hsdeleted−198

This diff is too big to show here.

src/Reporting/Error/Pattern.hsdeleted−92

This diff is too big to show here.

src/Reporting/Error/Syntax.hsdeleted−430

This diff is too big to show here.

src/Reporting/Error/Type.hsdeleted−728

This diff is too big to show here.

src/Reporting/Region.hsdeleted−64

This diff is too big to show here.

src/Reporting/Render/Code.hsdeleted−113

This diff is too big to show here.

src/Reporting/Render/Type.hsdeleted−504

This diff is too big to show here.

src/Reporting/Report.hsdeleted−106

This diff is too big to show here.

src/Reporting/Result.hsdeleted−179

This diff is too big to show here.

src/Reporting/Warning.hsdeleted−67

This diff is too big to show here.

src/Type/Constrain/Effects.hsdeleted−114

This diff is too big to show here.

src/Type/Constrain/Expression.hsdeleted−598

This diff is too big to show here.

src/Type/Constrain/Literal.hsdeleted−48

This diff is too big to show here.

src/Type/Constrain/Pattern.hsdeleted−86

This diff is too big to show here.

src/Type/Environment.hsdeleted−239

This diff is too big to show here.

src/Type/Fragment.hsdeleted−44

This diff is too big to show here.

src/Type/Inference.hsdeleted−108

This diff is too big to show here.

src/Type/Solve.hsdeleted−344

This diff is too big to show here.

src/Type/State.hsdeleted−327

This diff is too big to show here.

src/Type/Type.hsdeleted−457

This diff is too big to show here.

src/Type/Unify.hsdeleted−670

This diff is too big to show here.

src/Validate.hsdeleted−706

This diff is too big to show here.

terminal/impl/Terminal.hsnew file+375

This diff is too big to show here.

terminal/impl/Terminal/Chomp.hsnew file+514

This diff is too big to show here.

terminal/impl/Terminal/Error.hsnew file+457

This diff is too big to show here.

terminal/impl/Terminal/Helpers.hsnew file+148

This diff is too big to show here.

terminal/impl/Terminal/Internal.hsnew file+93

This diff is too big to show here.

terminal/src/Bump.hsnew file+169

This diff is too big to show here.

terminal/src/Develop.hsnew file+256

This diff is too big to show here.

terminal/src/Develop/Generate/Help.hsnew file+65

This diff is too big to show here.

terminal/src/Develop/Generate/Index.hsnew file+213

This diff is too big to show here.

terminal/src/Develop/Socket.hsnew file+43

This diff is too big to show here.

terminal/src/Develop/StaticFiles.hsnew file+123

This diff is too big to show here.

terminal/src/Develop/StaticFiles/Build.hsnew file+73

This diff is too big to show here.

terminal/src/Diff.hsnew file+359

This diff is too big to show here.

terminal/src/Init.hsnew file+104

This diff is too big to show here.

terminal/src/Install.hsnew file+425

This diff is too big to show here.

terminal/src/Main.hsnew file+338

This diff is too big to show here.

terminal/src/Make.hsnew file+319

This diff is too big to show here.

terminal/src/Publish.hsnew file+540

This diff is too big to show here.

terminal/src/Repl.hsnew file+726

This diff is too big to show here.

tests/Test.hsdeleted−14

This diff is too big to show here.

tests/Test/Compiler.hsdeleted−225

This diff is too big to show here.

tests/Test/Property.hsdeleted−68

This diff is too big to show here.

tests/Test/Property/Arbitrary.hsdeleted−192

This diff is too big to show here.

tests/test-files/bad/BBTArgsdeleted−1

This diff is too big to show here.

tests/test-files/bad/IncompletePatternMatch.elmdeleted−17

This diff is too big to show here.

tests/test-files/bad/InfiniteType.elmdeleted−2

This diff is too big to show here.

tests/test-files/bad/NonElementMain.elmdeleted−2

This diff is too big to show here.

tests/test-files/bad/RepeatedArgument.elmdeleted−4

This diff is too big to show here.

tests/test-files/bad/Strings/ExtraClose.elmdeleted−4

This diff is too big to show here.

tests/test-files/good-expected-js/Cases/CharCase.elm.jsdeleted−8

This diff is too big to show here.

tests/test-files/good-expected-js/Cases/ListZip.elm.jsdeleted−21

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/CommentInterpretedAsInfix.elm.jsdeleted−13

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/NestedPatternMatch.elm.jsdeleted−4

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/Shadowing.elm.jsdeleted−16

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/Shadowing2.elm.jsdeleted−13

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_ListAny.elm.jsdeleted−20

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_NameNormalization.elm.jsdeleted−12

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_UnsafeLabel.elm.jsdeleted−23

This diff is too big to show here.

tests/test-files/good-expected-js/Crash/CrashCase.elm.jsdeleted−14

This diff is too big to show here.

tests/test-files/good-expected-js/Crash/CrashIf.elm.jsdeleted−8

This diff is too big to show here.

tests/test-files/good-expected-js/Declarations/NoDefinitions.elm.jsdeleted

No changes to the content.

tests/test-files/good-expected-js/Lists/EmptyList.elm.jsdeleted−2

This diff is too big to show here.

tests/test-files/good-expected-js/Lists/ListRange.elm.jsdeleted−1

This diff is too big to show here.

tests/test-files/good-expected-js/Lists/NonEmptyList.elm.jsdeleted−2

This diff is too big to show here.

tests/test-files/good-expected-js/Records/AliasSubstitution.elm.jsdeleted−3

This diff is too big to show here.

tests/test-files/good-expected-js/Records/NonHomogeneousRecords.elm.jsdeleted−9

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/Apply.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/ApplyAnnotated.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/Id.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/IdAnnotated.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/SpecificAnnotationInt.elm.jsdeleted−3

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/SpecificAnnotationNumber.elm.jsdeleted−3

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/TrickyId.elm.jsdeleted−4

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/TrickyIdAnnotated.elm.jsdeleted−4

This diff is too big to show here.

tests/test-files/good-expected-js/Strings/Multiline.elm.jsdeleted−1

This diff is too big to show here.

tests/test-files/good-expected-js/Strings/MultilineNormal.elm.jsdeleted−1

This diff is too big to show here.

tests/test-files/good-expected-js/Strings/QuotesAndComments.elm.jsdeleted−7

This diff is too big to show here.

tests/test-files/good/Cases/CharCase.elmdeleted−8

This diff is too big to show here.

tests/test-files/good/Cases/ListZip.elmdeleted−17

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/CommentInterpretedAsInfix.elmdeleted−12

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/NestedPatternMatch.elmdeleted−5

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/Shadowing.elmdeleted−22

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/Shadowing2.elmdeleted−25

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/TailRecursion_ListAny.elmdeleted−12

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/TailRecursion_NameNormalization.elmdeleted−8

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/TailRecursion_UnsafeLabel.elmdeleted−20

This diff is too big to show here.

tests/test-files/good/Crash/CrashCase.elmdeleted−9

This diff is too big to show here.

tests/test-files/good/Crash/CrashIf.elmdeleted−8

This diff is too big to show here.

tests/test-files/good/Declarations/NoDefinitions.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Lists/EmptyList.elmdeleted−2

This diff is too big to show here.

tests/test-files/good/Lists/ListRange.elmdeleted−2

This diff is too big to show here.

tests/test-files/good/Lists/NonEmptyList.elmdeleted−2

This diff is too big to show here.

tests/test-files/good/Records/AliasSubstitution.elmdeleted−13

This diff is too big to show here.

tests/test-files/good/Records/NonHomogeneousRecords.elmdeleted−14

This diff is too big to show here.

tests/test-files/good/Soundness/Apply.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Soundness/ApplyAnnotated.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/Id.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Soundness/IdAnnotated.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/SpecificAnnotationInt.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/SpecificAnnotationNumber.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/TrickyId.elmdeleted−2

This diff is too big to show here.

tests/test-files/good/Soundness/TrickyIdAnnotated.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Strings/Multiline.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Strings/MultilineNormal.elmdeleted−5

This diff is too big to show here.

tests/test-files/good/Strings/QuotesAndComments.elmdeleted−16

This diff is too big to show here.

worker/elm.cabalnew file+210

This diff is too big to show here.

worker/elm.jsonnew file+26

This diff is too big to show here.

worker/nginx.confnew file+22

This diff is too big to show here.

worker/outlines/compile/elm.jsonnew file+32

This diff is too big to show here.

worker/outlines/repl/elm.jsonnew file+19

This diff is too big to show here.

worker/src/Artifacts.hsnew file+155

This diff is too big to show here.

worker/src/Cors.hsnew file+48

This diff is too big to show here.

worker/src/Endpoint/Compile.hsnew file+323

This diff is too big to show here.

worker/src/Endpoint/Quotes.hsnew file+114

This diff is too big to show here.

worker/src/Endpoint/Repl.hsnew file+244

This diff is too big to show here.

worker/src/Errors.elmnew file+217

This diff is too big to show here.

worker/src/Main.hsnew file+73

This diff is too big to show here.