on master help sign in
196 files changed+18293−8054
since splitsnapshots
unifiedsplit
.github/CONTRIBUTING.md+18−20 .github/PULL_REQUEST_TEMPLATE.md+18 .github/workflows/set-issue-expectations.yml+21 .github/workflows/set-pull-expectations.yml+19 .gitignore+1 .travis.yml+28 ContributorAgreement.pdf LICENSE+6−25 README.md+10−5 builder/src/BackgroundWriter.hs+42 builder/src/Build.hs+557−296 builder/src/Deps/Bump.hs+37 builder/src/Deps/Diff.hs+7−5 builder/src/Deps/Registry.hs+35−68 builder/src/Deps/Solver.hs+31−29 builder/src/Elm/Bump.hs−137 builder/src/Elm/Details.hs+194−97 builder/src/Elm/Diff.hs−284 builder/src/Elm/Outline.hs+148−115 builder/src/Elm/Publish.hs−255 builder/src/File.hs+28−5 builder/src/Generate.hs+211 builder/src/Http.hs+14−1 builder/src/Reporting.hs+43−22 builder/src/Reporting/Exit.hs+1624−365 builder/src/Reporting/Exit/Assets.hs−227 builder/src/Reporting/Exit/Crawl.hs−345 builder/src/Reporting/Exit/Deps.hs−123 builder/src/Reporting/Exit/Help.hs+11−12 builder/src/Reporting/Exit/Http.hs−104 builder/src/Reporting/Task.hs+17 builder/src/Stuff.hs+8−9 cabal.config+2 compiler/src/AST/Canonical.hs+11−8 compiler/src/AST/Optimized.hs+14−13 compiler/src/AST/Source.hs+31−23 compiler/src/AST/Utils/Binop.hs+5−6 compiler/src/AST/Utils/Shader.hs+51−4 compiler/src/AST/Utils/Type.hs−1 compiler/src/Canonicalize/Environment.hs+50−20 compiler/src/Canonicalize/Environment/Dups.hs+1−1 compiler/src/Canonicalize/Environment/Foreign.hs+49−37 compiler/src/Canonicalize/Environment/Local.hs+8−8 compiler/src/Canonicalize/Expression.hs+6−7 compiler/src/Canonicalize/Module.hs+11−11 compiler/src/Canonicalize/Pattern.hs+3−2 compiler/src/Data/Map/Utils.hs+6 compiler/src/Data/Name.hs+166−177 compiler/src/Data/NonEmptyList.hs+23−2 compiler/src/Data/Utf8.hs+157−300 compiler/src/Elm/Compiler/Imports.hs+4−13 compiler/src/Elm/Compiler/Type.hs+26−27 compiler/src/Elm/Compiler/Type/Extract.hs+1−1 compiler/src/Elm/Constraint.hs+55−77 compiler/src/Elm/Docs.hs+218−158 compiler/src/Elm/Float.hs+51 compiler/src/Elm/Interface.hs+4−4 compiler/src/Elm/Kernel.hs+48−46 compiler/src/Elm/Licenses.hs+48−65 compiler/src/Elm/ModuleName.hs+65−39 compiler/src/Elm/Package.hs+205−83 compiler/src/Elm/String.hs+133 compiler/src/Elm/Version.hs+73−43 compiler/src/Generate/Html.hs+11−10 compiler/src/Generate/JavaScript.hs+76−55 compiler/src/Generate/JavaScript/Builder.hs+207−217 compiler/src/Generate/JavaScript/Expression.hs+46−45 compiler/src/Generate/JavaScript/Name.hs+22−12 compiler/src/Generate/Mode.hs−1 compiler/src/Json/Decode.hs+329−177 compiler/src/Json/Encode.hs+37−21 compiler/src/Json/String.hs+192 compiler/src/Nitpick/PatternMatches.hs+4−4 compiler/src/Optimize/DecisionTree.hs+5−5 compiler/src/Optimize/Module.hs+4−4 compiler/src/Optimize/Port.hs+3−3 compiler/src/Parse/Declaration.hs+18−19 compiler/src/Parse/Docs.hs−275 compiler/src/Parse/Expression.hs+57−45 compiler/src/Parse/Keyword.hs+16−16 compiler/src/Parse/Module.hs+238−187 compiler/src/Parse/Number.hs+16−13 compiler/src/Parse/Pattern.hs+46−21 compiler/src/Parse/Primitives.hs+95−47 compiler/src/Parse/Repl.hs−117 compiler/src/Parse/Shader.hs+20−19 compiler/src/Parse/Space.hs+25−29 compiler/src/Parse/Utf8.hs → compiler/src/Parse/String.hs+64−66 compiler/src/Parse/Symbol.hs+19−34 compiler/src/Parse/Type.hs+3−3 compiler/src/Parse/Variable.hs+30−23 compiler/src/Reporting/Annotation.hs+1−1 compiler/src/Reporting/Doc.hs+79−47 compiler/src/Reporting/Error.hs+36−33 compiler/src/Reporting/Error/Canonicalize.hs+74−73 compiler/src/Reporting/Error/Docs.hs+132−23 compiler/src/Reporting/Error/Import.hs+113−9 compiler/src/Reporting/Error/Json.hs+281−269 compiler/src/Reporting/Error/Main.hs+3−3 compiler/src/Reporting/Error/Pattern.hs+9−8 compiler/src/Reporting/Error/Syntax.hs+5183−909 compiler/src/Reporting/Error/Type.hs+53−32 compiler/src/Reporting/Render/Code.hs+150−8 compiler/src/Reporting/Render/Type/Localizer.hs+6−26 compiler/src/Reporting/Report.hs−40 compiler/src/Reporting/Result.hs+10 compiler/src/Reporting/Warning.hs+3−3 compiler/src/Type/Constrain/Module.hs+1−1 compiler/src/Type/Error.hs+14−123 compiler/src/Type/Solve.hs+7 compiler/src/Type/Unify.hs+12−10 docs/elm.json/application.md+2−2 docs/elm.json/package.md+1−1 upgrade-docs/0.16.md → docs/upgrade-instructions/0.16.md upgrade-docs/0.17.md → docs/upgrade-instructions/0.17.md upgrade-docs/0.18.md → docs/upgrade-instructions/0.18.md upgrade-docs/0.19.md → docs/upgrade-instructions/0.19.0.md docs/upgrade-instructions/0.19.1.md+60 upgrade-docs/earlier.md → docs/upgrade-instructions/earlier.md elm.cabal+34−16 hints/bad-recursion.md+133 hints/comparing-custom-types.md+98 hints/comparing-records.md+85 hints/implicit-casts.md+50 hints/import-cycles.md+184 hints/imports.md+126 hints/infinite-type.md+42 hints/init.md+55 hints/missing-patterns.md+139 hints/optimize.md+59 hints/port-modules.md+32 hints/recursive-alias.md+162 hints/repl.md+73 hints/shadowing.md+70 hints/tuples.md+19 hints/type-annotations.md+60 installers/README.md+32 installers/linux/Dockerfile+39 installers/linux/README.md+93 installers/mac/Distribution.xml+5−3 installers/mac/README.md+93 installers/mac/Resources/en.lproj/background.png installers/mac/Resources/en.lproj/conclusion.rtf+13−6 installers/mac/Resources/en.lproj/welcome.rtf+9−4 installers/mac/helper-scripts/elm-startup.sh+1−1 installers/mac/make-installer.sh+30−3 installers/npm/PUBLISHING.md+29−141 installers/npm/README.md+30−23 installers/npm/bin/elm+47−41 installers/npm/download.js+114 installers/npm/index.js−21 installers/npm/install.js+4 installers/npm/package.json+13−15 installers/npm/troubleshooting.md+76 installers/win/Nsisfile.nsi+16−16 installers/win/README.md+18−3 installers/win/file.ico installers/win/inst.dat+1−2 installers/win/logo.ico installers/win/uninst.dat+1−2 installers/win/welcome.bmp reactor/assets/waiting.gif reactor/elm.json+2−2 reactor/src/Index.elm+20−15 reactor/src/Index/Navigator.elm+1−1 roadmap.md+29 terminal/src/Terminal/Args.hs → terminal/impl/Terminal.hs+33−27 terminal/src/Terminal/Args/Chomp.hs → terminal/impl/Terminal/Chomp.hs+4−5 terminal/src/Terminal/Args/Error.hs → terminal/impl/Terminal/Error.hs+28−18 terminal/impl/Terminal/Helpers.hs+148 terminal/src/Terminal/Args/Internal.hs → terminal/impl/Terminal/Internal.hs+8−8 terminal/src/Bump.hs+158−8 terminal/src/Develop.hs+70−77 terminal/src/Develop/Generate/Index.hs+149−74 terminal/src/Develop/StaticFiles.hs+1−7 terminal/src/Develop/StaticFiles/Build.hs+46−29 terminal/src/Diff.hs+348−6 terminal/src/Init.hs+2−1 terminal/src/Install.hs+16−31 terminal/src/Main.hs+32−36 terminal/src/Make.hs+113−268 terminal/src/Publish.hs+529−8 terminal/src/Repl.hs+522−197 terminal/src/Terminal/Args/Helpers.hs−125 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/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
.travis.ymlnew file+28
@@ -0,0 +1,28 @@
1+language: minimal
2+services: docker
3+
4+env:
5+ global:
6+ - LINUX_ARCHIVE=binary-for-linux-64-bit.gz
7+
8+before_install:
9+ - docker build -t elm -f installers/linux/Dockerfile .
10+ - docker cp $(docker create elm):/usr/local/bin/elm .
11+ - gzip -9 -c elm > $LINUX_ARCHIVE
12+
13+deploy:
14+ provider: releases
15+ api_key:
16+ secure: Yz2Lo4u9rZQ7Ee7ohAsrZpkqsYDUerCSMdSQIH8ryrf7phHhiloPEkTKsM+NupHqU/LEAVsunxbau4QrCEjA2vPavAPVk8cKomRUWK/YjbXHKa24hPkal2c+A2bnMQ6w3qYk/PjL9rW+Goq++/SNLcYZwHBV0Chl2blivMwWCSA=
17+ file: $LINUX_ARCHIVE
18+ skip_cleanup: true
19+ on:
20+ branch: master
21+ tags: true
22+
23+notifications:
24+ email:
25+ recipients:
26+ - rlefevre@dmy.fr
27+ on_success: change
28+ on_failure: change
ContributorAgreement.pdfdeleted

Binary file not shown.

LICENSE+6−25
@@ -1,30 +1,11 @@
1−Copyright (c) 2012-present, 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+10−5
@@ -1,17 +1,22 @@
1−# The Elm Compiler
1+# Elm
22
3−Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
3+A delightful language for reliable webapps.
44
5+Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
6+
7+
8+<br>
59
610## Install
711
8−Follow [these instructions][installer]!
12+✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
913
10− [installer]: https://guide.elm-lang.org/install.html
14+For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
1115
16+<br>
1217
1318## Help
1419
1520If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
1621
17−[slack]: http://elmlang.herokuapp.com/
22+[slack]: http://elmlang.herokuapp.com/
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.hs+557−296
@@ -1,12 +1,16 @@
11{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
33module Build
44 ( fromExposed
5− , fromMains
5+ , fromPaths
6+ , fromRepl
67 , Artifacts(..)
7− , Main(..)
8+ , Root(..)
89 , Module(..)
910 , CachedInterface(..)
11+ , ReplArtifacts(..)
12+ , DocsGoal(..)
13+ , getRootNames
1014 )
1115 where
1216
@@ -16,7 +20,6 @@ import Control.Concurrent.MVar
1620import Control.Monad (filterM, mapM_, sequence_)
1721import qualified Data.ByteString as B
1822import qualified Data.Char as Char
19−import qualified Data.Either as Either
2023import qualified Data.Graph as Graph
2124import qualified Data.List as List
2225import qualified Data.Map.Utils as Map
@@ -31,22 +34,27 @@ import qualified System.Directory as Dir
3134import qualified System.FilePath as FP
3235import System.FilePath ((</>), (<.>))
3336
37+import qualified AST.Canonical as Can
3438import qualified AST.Source as Src
3539import qualified AST.Optimized as Opt
3640import qualified Compile
3741import qualified Elm.Details as Details
42+import qualified Elm.Docs as Docs
3843import qualified Elm.Interface as I
3944import qualified Elm.ModuleName as ModuleName
4045import qualified Elm.Outline as Outline
4146import qualified Elm.Package as Pkg
4247import qualified File
48+import qualified Json.Encode as E
4349import qualified Parse.Module as Parse
4450import qualified Reporting
4551import qualified Reporting.Annotation as A
4652import qualified Reporting.Error as Error
53+import qualified Reporting.Error.Docs as EDocs
4754import qualified Reporting.Error.Syntax as Syntax
4855import qualified Reporting.Error.Import as Import
4956import qualified Reporting.Exit as Exit
57+import qualified Reporting.Render.Type.Localizer as L
5058import qualified Stuff
5159
5260
@@ -58,27 +66,57 @@ data Env =
5866 Env
5967 { _key :: Reporting.BKey
6068 , _root :: FilePath
61− , _pkg :: Pkg.Name
62− , _srcDirs :: [FilePath]
69+ , _project :: Parse.ProjectType
70+ , _srcDirs :: [AbsoluteSrcDir]
71+ , _buildID :: Details.BuildID
6372 , _locals :: Map.Map ModuleName.Raw Details.Local
6473 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
6574 }
6675
6776
68−makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
69−makeEnv key root (Details.Details _ validOutline locals foreigns _) =
77+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
78+makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
7079 case validOutline of
71− Details.ValidApp (Outline.AppOutline _ srcDirs _ _ _ _) ->
72− Env key root Pkg.dummyName srcDirs locals foreigns
80+ Details.ValidApp givenSrcDirs ->
81+ do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82+ return $ Env key root Parse.Application srcDirs buildID locals foreigns
7383
74− Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->
75− Env key root pkg ["src"] locals foreigns
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
76110
77111
78112
79113-- FORK
80114
81115
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+--
82120fork :: IO a -> IO (MVar a)
83121fork work =
84122 do mvar <- newEmptyMVar
@@ -96,21 +134,22 @@ forkWithKey func dict =
96134-- FROM EXPOSED
97135
98136
99−fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
100−fromExposed style root details (NE.List e es) =
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) =
101139 Reporting.trackBuild style $ \key ->
102− do let env = makeEnv key root details
140+ do env <- makeEnv key root details
103141 dmvar <- Details.loadInterfaces root details
104142
105143 -- crawl
106144 mvar <- newEmptyMVar
107− roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
145+ let docsNeed = toDocsNeed docsGoal
146+ roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
108147 putMVar mvar roots
109148 mapM_ readMVar roots
110149 statuses <- traverse readMVar =<< readMVar mvar
111150
112151 -- compile
113− midpoint <- checkExposedMidpoint dmvar statuses
152+ midpoint <- checkMidpoint dmvar statuses
114153 case midpoint of
115154 Left problem ->
116155 return (Left (Exit.BuildProjectProblem problem))
@@ -121,18 +160,18 @@ fromExposed style root details (NE.List e es) =
121160 putMVar rmvar resultMVars
122161 results <- traverse readMVar resultMVars
123162 writeDetails root details results
124− return (detectProblems results)
163+ finalizeExposed root docsGoal exposed results
125164
126165
127166
128−-- FROM MAINS
167+-- FROM PATHS
129168
130169
131170data Artifacts =
132171 Artifacts
133172 { _name :: Pkg.Name
134173 , _deps :: Dependencies
135− , _mains :: NE.List Main
174+ , _roots :: NE.List Root
136175 , _modules :: [Module]
137176 }
138177
@@ -146,25 +185,25 @@ type Dependencies =
146185 Map.Map ModuleName.Canonical I.DependencyInterface
147186
148187
149−fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
150−fromMains style root details paths =
188+fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
189+fromPaths style root details paths =
151190 Reporting.trackBuild style $ \key ->
152− do let env = makeEnv key root details
191+ do env <- makeEnv key root details
153192
154− elmains <- findMains env paths
155− case elmains of
193+ elroots <- findRoots env paths
194+ case elroots of
156195 Left problem ->
157196 return (Left (Exit.BuildProjectProblem problem))
158197
159− Right lmains ->
198+ Right lroots ->
160199 do -- crawl
161200 dmvar <- Details.loadInterfaces root details
162201 smvar <- newMVar Map.empty
163− smainMVars <- traverse (fork . crawlMain env smvar) lmains
164− smains <- traverse readMVar smainMVars
202+ srootMVars <- traverse (fork . crawlRoot env smvar) lroots
203+ sroots <- traverse readMVar srootMVars
165204 statuses <- traverse readMVar =<< readMVar smvar
166205
167− midpoint <- checkMainsMidpoint dmvar statuses smains
206+ midpoint <- checkMidpointAndRoots dmvar statuses sroots
168207 case midpoint of
169208 Left problem ->
170209 return (Left (Exit.BuildProjectProblem problem))
@@ -174,10 +213,26 @@ fromMains style root details paths =
174213 rmvar <- newEmptyMVar
175214 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
176215 putMVar rmvar resultsMVars
177− rmainMVars <- traverse (fork . checkMain env foreigns resultsMVars) smains
216+ rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
178217 results <- traverse readMVar resultsMVars
179218 writeDetails root details results
180− toArtifacts env foreigns results <$> traverse readMVar rmainMVars
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
181236
182237
183238
@@ -190,7 +245,7 @@ type StatusDict =
190245
191246data Status
192247 = SCached Details.Local
193− | SChanged Details.Local B.ByteString Src.Module
248+ | SChanged Details.Local B.ByteString Src.Module DocsNeed
194249 | SBadImport Import.Problem
195250 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
196251 | SForeign Pkg.Name
@@ -207,15 +262,14 @@ crawlDeps env mvar deps blockedValue =
207262 mapM_ readMVar statuses
208263 return blockedValue
209264 where
210− crawlNew name () = fork (crawlModule env mvar name)
265+ crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
211266
212267
213−crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
214−crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
268+crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
269+crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
215270 do let fileName = ModuleName.toFilePath name <.> "elm"
216− let inRoot path = File.exists (root </> path)
217271
218− paths <- filterM inRoot (map (</> fileName) srcDirs)
272+ paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
219273
220274 case paths of
221275 [path] ->
@@ -224,21 +278,18 @@ crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
224278 return $ SBadImport $ Import.Ambiguous path [] dep deps
225279
226280 Nothing ->
227− case Map.lookup name locals of
228− Nothing ->
229− crawlFile env mvar name path
281+ do newTime <- File.getTime path
282+ case Map.lookup name locals of
283+ Nothing ->
284+ crawlFile env mvar docsNeed name path newTime buildID
230285
231− Just local@(Details.Local oldPath oldTime deps _) ->
232− if path /= oldPath
233− then crawlFile env mvar name path
234− else
235− do newTime <- File.getTime path
236− if oldTime < newTime
237− then crawlFile env mvar name path
238− else crawlDeps env mvar deps (SCached local)
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)
239290
240291 p1:p2:ps ->
241− return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
292+ return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
242293
243294 [] ->
244295 case Map.lookup name foreigns of
@@ -251,23 +302,22 @@ crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
251302 return $ SBadImport $ Import.AmbiguousForeign dep d ds
252303
253304 Nothing ->
254− if Name.isKernel name && Pkg.isKernel pkg then
305+ if Name.isKernel name && Parse.isKernel projectType then
255306 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
256307 return $ if exists then SKernel else SBadImport Import.NotFound
257308 else
258309 return $ SBadImport Import.NotFound
259310
260311
261−crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
262−crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
263− do time <- File.getTime path
264− source <- File.readUtf8 (root </> path)
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)
265315
266− case Parse.fromByteString pkg source of
316+ case Parse.fromByteString projectType source of
267317 Left err ->
268318 return $ SBadSyntax path time source err
269319
270− Right modul@(Src.Module maybeActualName _ imports values _ _ _ _) ->
320+ Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
271321 case maybeActualName of
272322 Nothing ->
273323 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
@@ -276,16 +326,16 @@ crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
276326 if expectedName == actualName then
277327 let
278328 deps = map Src.getImportName imports
279− local = Details.Local path time deps (any isMain values)
329+ local = Details.Local path time deps (any isMain values) lastChange buildID
280330 in
281− crawlDeps env mvar deps (SChanged local source modul)
331+ crawlDeps env mvar deps (SChanged local source modul docsNeed)
282332 else
283333 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
284334
285335
286336isMain :: A.Located Src.Value -> Bool
287337isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
288− name == Name.main
338+ name == Name._main
289339
290340
291341
@@ -297,9 +347,9 @@ type ResultDict =
297347
298348
299349data Result
300− = RNew Details.Local I.Interface Opt.LocalGraph
301− | RSame Details.Local I.Interface Opt.LocalGraph
302− | RCached Bool (MVar CachedInterface)
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)
303353 | RNotFound Import.Problem
304354 | RProblem Error.Module
305355 | RBlocked
@@ -314,23 +364,23 @@ data CachedInterface
314364
315365
316366checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
317−checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
367+checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
318368 case status of
319− SCached local@(Details.Local path time deps hasMain) ->
369+ SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
320370 do results <- readMVar resultsMVar
321− depsStatus <- checkDeps root results deps
371+ depsStatus <- checkDeps root results deps lastCompile
322372 case depsStatus of
323373 DepsChange ifaces ->
324374 do source <- File.readUtf8 path
325− case Parse.fromByteString pkg source of
326− Right modul -> compile env local source ifaces modul
375+ case Parse.fromByteString projectType source of
376+ Right modul -> compile env (DocsNeed False) local source ifaces modul
327377 Left err ->
328378 return $ RProblem $
329379 Error.Module name path time source (Error.BadSyntax err)
330380
331381 DepsSame _ _ ->
332382 do mvar <- newMVar Unneeded
333− return (RCached hasMain mvar)
383+ return (RCached hasMain lastChange mvar)
334384
335385 DepsBlock ->
336386 return RBlocked
@@ -338,36 +388,32 @@ checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
338388 DepsNotFound problems ->
339389 do source <- File.readUtf8 path
340390 return $ RProblem $ Error.Module name path time source $
341− case Parse.fromByteString pkg source of
342− Right (Src.Module _ _ imports _ _ _ _ _) ->
343− Error.BadImports (toImportErrors foreigns results imports problems)
391+ case Parse.fromByteString projectType source of
392+ Right (Src.Module _ _ _ imports _ _ _ _ _) ->
393+ Error.BadImports (toImportErrors env results imports problems)
344394
345395 Left err ->
346396 Error.BadSyntax err
347397
348− SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ imports _ _ _ _ _) ->
398+ SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
349399 do results <- readMVar resultsMVar
350− depsStatus <- checkDeps root results deps
400+ depsStatus <- checkDeps root results deps lastCompile
351401 case depsStatus of
352402 DepsChange ifaces ->
353− compile env local source ifaces modul
403+ compile env docsNeed local source ifaces modul
354404
355405 DepsSame same cached ->
356− do maybeLoaded <- checkCachedInterfaces root cached
406+ do maybeLoaded <- loadInterfaces root same cached
357407 case maybeLoaded of
358− Nothing ->
359− return RBlocked
360−
361− Just loaded ->
362− do let ifaces = Map.union loaded (Map.fromList same)
363− compile env local source ifaces modul
408+ Nothing -> return RBlocked
409+ Just ifaces -> compile env docsNeed local source ifaces modul
364410
365411 DepsBlock ->
366412 return RBlocked
367413
368414 DepsNotFound problems ->
369415 return $ RProblem $ Error.Module name path time source $
370− Error.BadImports (toImportErrors foreigns results imports problems)
416+ Error.BadImports (toImportErrors env results imports problems)
371417
372418 SBadImport importProblem ->
373419 return (RNotFound importProblem)
@@ -379,7 +425,7 @@ checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
379425 SForeign home ->
380426 case foreigns ! ModuleName.Canonical home name of
381427 I.Public iface -> return (RForeign iface)
382− I.Private _ _ _ -> error "loading private interface in Build"
428+ I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
383429
384430 SKernel ->
385431 return RKernel
@@ -396,32 +442,48 @@ data DepsStatus
396442 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
397443
398444
399−checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
400−checkDeps root results deps =
401− checkDepsHelp root results deps [] [] [] [] False
445+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
446+checkDeps root results deps lastCompile =
447+ checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
402448
403449
404450type Dep = (ModuleName.Raw, I.Interface)
405451type CDep = (ModuleName.Raw, MVar CachedInterface)
406452
407453
408−checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
409−checkDepsHelp root results deps new same cached importProblems isBlocked =
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 =
410456 case deps of
411457 dep:otherDeps ->
412458 do result <- readMVar (results ! dep)
413459 case result of
414− RNew _ iface _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
415− RSame _ iface _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
416− RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
417− RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
418− RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
419− RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
420− RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
421− RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
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+
422484
423485 [] ->
424− case importProblems of
486+ case reverse importProblems of
425487 p:ps ->
426488 return $ DepsNotFound (NE.List p ps)
427489
@@ -429,54 +491,60 @@ checkDepsHelp root results deps new same cached importProblems isBlocked =
429491 if isBlocked then
430492 return $ DepsBlock
431493
432− else if null new then
494+ else if null new && lastDepChange <= lastCompile then
433495 return $ DepsSame same cached
434496
435497 else
436− do maybeLoaded <- checkCachedInterfaces root cached
498+ do maybeLoaded <- loadInterfaces root same cached
437499 case maybeLoaded of
438− Nothing ->
439− return DepsBlock
440−
441− Just loaded ->
442− return $ DepsChange $
443− Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
500+ Nothing -> return DepsBlock
501+ Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
444502
445503
446504
447505-- TO IMPORT ERROR
448506
449507
450−toImportErrors :: Dependencies -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
451−toImportErrors foreigns results imports problems =
508+toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
509+toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
452510 let
453511 knownModules =
454− Set.union
455− (Set.fromList (map ModuleName._module (Map.keys foreigns)))
456− (Map.keysSet results)
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))
457520
458521 regionDict =
459522 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
460523
461524 toError (name, problem) =
462− Import.Error (regionDict ! name) name knownModules problem
525+ Import.Error (regionDict ! name) name unimportedModules problem
463526 in
464527 fmap toError problems
465528
466529
467530
468−-- CACHED INTERFACE
531+-- LOAD CACHED INTERFACES
469532
470533
471−checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
472−checkCachedInterfaces root deps =
473− do loading <- traverse (fork . checkCache root) deps
474− loaded <- traverse readMVar loading
475− return $ Map.fromList <$> sequence loaded
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)
476544
477545
478−checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
479−checkCache root (name, ciMvar) =
546+loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
547+loadInterface root (name, ciMvar) =
480548 do cachedInterface <- takeMVar ciMvar
481549 case cachedInterface of
482550 Corrupted ->
@@ -503,8 +571,8 @@ checkCache root (name, ciMvar) =
503571-- CHECK PROJECT
504572
505573
506−checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
507−checkExposedMidpoint dmvar statuses =
574+checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575+checkMidpoint dmvar statuses =
508576 case checkForCycles statuses of
509577 Nothing ->
510578 do maybeForeigns <- readMVar dmvar
@@ -517,11 +585,11 @@ checkExposedMidpoint dmvar statuses =
517585 return (Left (Exit.BP_Cycle name names))
518586
519587
520−checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
521−checkMainsMidpoint dmvar statuses smains =
588+checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
589+checkMidpointAndRoots dmvar statuses sroots =
522590 case checkForCycles statuses of
523591 Nothing ->
524− case checkUniqueMains statuses smains of
592+ case checkUniqueRoots statuses sroots of
525593 Nothing ->
526594 do maybeForeigns <- readMVar dmvar
527595 case maybeForeigns of
@@ -572,25 +640,25 @@ addToGraph name status graph =
572640 let
573641 dependencies =
574642 case status of
575− SCached (Details.Local _ _ deps _) -> deps
576− SChanged (Details.Local _ _ deps _) _ _ -> deps
577− SBadImport _ -> []
578− SBadSyntax _ _ _ _ -> []
579− SForeign _ -> []
580− SKernel -> []
643+ SCached (Details.Local _ _ deps _ _ _) -> deps
644+ SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
645+ SBadImport _ -> []
646+ SBadSyntax _ _ _ _ -> []
647+ SForeign _ -> []
648+ SKernel -> []
581649 in
582650 (name, name, dependencies) : graph
583651
584652
585653
586−-- CHECK UNIQUE MAINS
654+-- CHECK UNIQUE ROOTS
587655
588656
589−checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
590−checkUniqueMains insides smains =
657+checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
658+checkUniqueRoots insides sroots =
591659 let
592660 outsidesDict =
593− Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
661+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
594662 in
595663 case Map.traverseWithKey checkOutside outsidesDict of
596664 Left problem ->
@@ -602,61 +670,78 @@ checkUniqueMains insides smains =
602670 Left problem -> Just problem
603671
604672
605−mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
606−mainStatusToNamePathPair smain =
607− case smain of
608− SInside _ -> Nothing
609− SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
610− SOutsideErr _ -> Nothing
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
611679
612680
613681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
614682checkOutside name paths =
615683 case OneOrMore.destruct NE.List paths of
616684 NE.List p [] -> Right p
617− NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
685+ NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
618686
619687
620688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
621689checkInside name p1 status =
622690 case status of
623− SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
624− SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
625− SBadImport _ -> Right ()
626− SBadSyntax _ _ _ _ -> Right ()
627− SForeign _ -> Right ()
628− SKernel -> Right ()
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 ()
629697
630698
631699
632700-- COMPILE MODULE
633701
634702
635−compile :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
636−compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifaces modul =
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
637708 case Compile.compile pkg ifaces modul of
638709 Right (Compile.Artifacts canonical annotations objects) ->
639− do let name = Src.getName modul
640− let iface = I.fromModule pkg canonical annotations
641− File.writeBinary (Stuff.elmo root name) objects
642− maybeOldi <- File.readBinary (Stuff.elmi root name)
643− case maybeOldi of
644− Just oldi | oldi == iface ->
645− do -- iface should be fully forced by equality check
646− Reporting.report key Reporting.BDone
647− return (RSame local iface objects)
648−
649− _ ->
650− do -- iface may be lazy still
651− -- TODO try adding forkIO here
652− File.writeBinary (Stuff.elmi root name) iface
653− Reporting.report key Reporting.BDone
654− return (RNew local iface 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)
655734
656735 Left err ->
657− do Reporting.report key Reporting.BDone
658− return $ RProblem $
659− Error.Module (Src.getName modul) path time source 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
660745
661746
662747
@@ -664,46 +749,210 @@ compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifac
664749
665750
666751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
667−writeDetails root (Details.Details time outline locals foreigns extras) results =
752+writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
668753 File.writeBinary (Stuff.details root) $
669− Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
754+ Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
670755
671756
672757addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
673758addNewLocal name result locals =
674759 case result of
675− RNew local _ _ -> Map.insert name local locals
676− RSame local _ _ -> Map.insert name local locals
677− RCached _ _ -> locals
678− RNotFound _ -> locals
679− RProblem _ -> locals
680− RBlocked -> locals
681− RForeign _ -> locals
682− RKernel -> locals
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+
683769
684770
771+-- FINALIZE EXPOSED
685772
686−-- DETECT PROBLEMS
687773
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))
688779
689−detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
690−detectProblems results =
691− case Map.foldr addErrors [] results of
692− [] -> Right ()
693− e:es -> Left (Exit.BuildModuleProblems e es)
780+ [] ->
781+ case Map.foldr addErrors [] results of
782+ [] -> Right <$> finalizeDocs docsGoal results
783+ e:es -> return $ Left $ Exit.BuildBadModules root e es
694784
695785
696786addErrors :: Result -> [Error.Module] -> [Error.Module]
697787addErrors result errors =
698788 case result of
699− RNew _ _ _ -> errors
700− RSame _ _ _ -> errors
701− RCached _ _ -> errors
702− RNotFound _ -> errors
703− RProblem e -> e:errors
704− RBlocked -> errors
705− RForeign _ -> errors
706− RKernel -> errors
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
707956
708957
709958
@@ -715,25 +964,25 @@ addErrors result errors =
715964
716965
717966
718−-- FIND MAIN
967+-- FIND ROOT
719968
720969
721−data MainLocation
970+data RootLocation
722971 = LInside ModuleName.Raw
723972 | LOutside FilePath
724973
725974
726−findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
727−findMains env paths =
728− do mvars <- traverse (fork . findLocation env) paths
729− elocs <- traverse readMVar mvars
730− return $ checkLocations =<< sequence elocs
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
731980
732981
733−checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
734−checkLocations locations =
982+checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
983+checkRoots infos =
735984 let
736− toOneOrMore loc@(Location absolute _ _) =
985+ toOneOrMore loc@(RootInfo absolute _ _) =
737986 (absolute, OneOrMore.one loc)
738987
739988 fromOneOrMore loc locs =
@@ -741,70 +990,83 @@ checkLocations locations =
741990 [] -> Right ()
742991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
743992 in
744− fmap (\_ -> fmap _location locations) $
993+ fmap (\_ -> fmap _location infos) $
745994 traverse (OneOrMore.destruct fromOneOrMore) $
746− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
995+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
747996
748997
749998
750−-- LOCATIONS
999+-- ROOT INFO
7511000
7521001
753−data Location =
754− Location
1002+data RootInfo =
1003+ RootInfo
7551004 { _absolute :: FilePath
7561005 , _relative :: FilePath
757− , _location :: MainLocation
1006+ , _location :: RootLocation
7581007 }
7591008
7601009
761−findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
762−findLocation env path =
1010+getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1011+getRootInfo env path =
7631012 do exists <- File.exists path
7641013 if exists
765− then isInsideSrcDirs env path <$> Dir.canonicalizePath path
1014+ then getRootInfoHelp env path =<< Dir.canonicalizePath path
7661015 else return (Left (Exit.BP_PathUnknown path))
7671016
7681017
769−isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
770−isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
1018+getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1019+getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
7711020 let
7721021 (dirs, file) = FP.splitFileName absolutePath
773− (final, ext) = break (=='.') file
1022+ (final, ext) = FP.splitExtension file
7741023 in
7751024 if ext /= ".elm"
776− then Left (Exit.BP_WithBadExtension path)
1025+ then
1026+ return $ Left $ Exit.BP_WithBadExtension path
7771027 else
7781028 let
779− roots = FP.splitDirectories root
780− segments = FP.splitDirectories dirs ++ [final]
1029+ absoluteSegments = FP.splitDirectories dirs ++ [final]
7811030 in
782− case dropPrefix roots segments of
783− Nothing ->
784− Right (Location absolutePath path (LOutside path))
785−
786− Just relativeSegments ->
787− let
788− (exits, maybes) =
789− Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
790− in
791− case (exits, Maybe.catMaybes maybes) of
792− (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
793− ([], []) -> Right (Location absolutePath path (LOutside path))
794− (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
795− (exit:_, _) -> Left exit
796−
797−
798−isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
799−isInsideSrcDirsHelp segments srcDir =
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) =
8001062 case dropPrefix (FP.splitDirectories srcDir) segments of
8011063 Nothing ->
802− Right Nothing
1064+ Nothing
8031065
8041066 Just names ->
8051067 if all isGoodName names
806− then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
807− else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
1068+ then Just (srcDir, Right names)
1069+ else Just (srcDir, Left names)
8081070
8091071
8101072isGoodName :: [Char] -> Bool
@@ -817,6 +1079,8 @@ isGoodName name =
8171079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
8181080
8191081
1082+-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083+--
8201084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
8211085dropPrefix roots paths =
8221086 case roots of
@@ -825,37 +1089,37 @@ dropPrefix roots paths =
8251089
8261090 r:rs ->
8271091 case paths of
828− [] -> Nothing
1092+ [] -> Nothing
8291093 p:ps -> if r == p then dropPrefix rs ps else Nothing
8301094
8311095
8321096
833−-- CRAWL MAINS
1097+-- CRAWL ROOTS
8341098
8351099
836−data MainStatus
1100+data RootStatus
8371101 = SInside ModuleName.Raw
8381102 | SOutsideOk Details.Local B.ByteString Src.Module
8391103 | SOutsideErr Error.Module
8401104
8411105
842−crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
843−crawlMain env@(Env _ _ pkg _ _ _) mvar given =
844− case given of
1106+crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
1107+crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1108+ case root of
8451109 LInside name ->
8461110 do statusMVar <- newEmptyMVar
8471111 statusDict <- takeMVar mvar
8481112 putMVar mvar (Map.insert name statusMVar statusDict)
849− putMVar statusMVar =<< crawlModule env mvar name
1113+ putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
8501114 return (SInside name)
8511115
8521116 LOutside path ->
8531117 do time <- File.getTime path
8541118 source <- File.readUtf8 path
855− case Parse.fromByteString pkg source of
856− Right modul@(Src.Module _ _ imports values _ _ _ _) ->
1119+ case Parse.fromByteString projectType source of
1120+ Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
8571121 do let deps = map Src.getImportName imports
858− let local = Details.Local path time deps (any isMain values)
1122+ let local = Details.Local path time deps (any isMain values) buildID buildID
8591123 crawlDeps env mvar deps (SOutsideOk local source modul)
8601124
8611125 Left syntaxError ->
@@ -864,96 +1128,93 @@ crawlMain env@(Env _ _ pkg _ _ _) mvar given =
8641128
8651129
8661130
867−-- CHECK MAINS
1131+-- CHECK ROOTS
8681132
8691133
870−data MainResult
1134+data RootResult
8711135 = RInside ModuleName.Raw
8721136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
8731137 | ROutsideErr Error.Module
8741138 | ROutsideBlocked
8751139
8761140
877−checkMain :: Env -> Dependencies -> ResultDict -> MainStatus -> IO MainResult
878−checkMain env@(Env _ root _ _ _ _) foreigns results pendingMain =
879− case pendingMain of
1141+checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
1142+checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
1143+ case rootStatus of
8801144 SInside name ->
8811145 return (RInside name)
8821146
8831147 SOutsideErr err ->
8841148 return (ROutsideErr err)
8851149
886− SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ imports _ _ _ _ _) ->
887− do depsStatus <- checkDeps root results deps
1150+ SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1151+ do depsStatus <- checkDeps root results deps lastCompile
8881152 case depsStatus of
8891153 DepsChange ifaces ->
890− return $ compileOutside env local source ifaces modul
1154+ compileOutside env local source ifaces modul
8911155
8921156 DepsSame same cached ->
893− do maybeLoaded <- checkCachedInterfaces root cached
1157+ do maybeLoaded <- loadInterfaces root same cached
8941158 case maybeLoaded of
895− Nothing ->
896− return ROutsideBlocked
897−
898− Just loaded ->
899− do let ifaces = Map.union loaded (Map.fromList same)
900− return $ compileOutside env local source ifaces modul
1159+ Nothing -> return ROutsideBlocked
1160+ Just ifaces -> compileOutside env local source ifaces modul
9011161
9021162 DepsBlock ->
9031163 return ROutsideBlocked
9041164
9051165 DepsNotFound problems ->
9061166 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
907− Error.BadImports (toImportErrors foreigns results imports problems)
1167+ Error.BadImports (toImportErrors env results imports problems)
9081168
9091169
910−compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
911−compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
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 =
9121172 let
1173+ pkg = projectTypeToPkg projectType
9131174 name = Src.getName modul
9141175 in
9151176 case Compile.compile pkg ifaces modul of
9161177 Right (Compile.Artifacts canonical annotations objects) ->
917− ROutsideOk name (I.fromModule pkg canonical annotations) objects
1178+ do Reporting.report key Reporting.BDone
1179+ return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
9181180
9191181 Left errors ->
920− ROutsideErr $
921− Error.Module name path time source errors
1182+ return $ ROutsideErr $ Error.Module name path time source errors
9221183
9231184
9241185
9251186-- TO ARTIFACTS
9261187
9271188
928−data Main
1189+data Root
9291190 = Inside ModuleName.Raw
9301191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
9311192
9321193
933−toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
934−toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
935− case gatherProblemsOrMains results mainResults of
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
9361197 Left (NE.List e es) ->
937− Left (Exit.BuildModuleProblems e es)
1198+ Left (Exit.BuildBadModules root e es)
9381199
939− Right mains ->
940− Right $ Artifacts pkg foreigns mains $
941− Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1200+ Right roots ->
1201+ Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
1202+ Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
9421203
9431204
944−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
945−gatherProblemsOrMains results (NE.List mainResult mainResults) =
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) =
9461207 let
947− sortMain result (es, mains) =
1208+ addResult result (es, roots) =
9481209 case result of
949− RInside n -> ( es, Inside n : mains)
950− ROutsideOk n i o -> ( es, Outside n i o : mains)
951− ROutsideErr e -> (e:es, mains)
952− ROutsideBlocked -> ( es, mains)
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)
9531214
9541215 errors = Map.foldr addErrors [] results
9551216 in
956− case (mainResult, foldr sortMain (errors, []) mainResults) of
1217+ case (rootResult, foldr addResult (errors, []) rootResults) of
9571218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
9581219 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
9591220 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
@@ -966,14 +1227,14 @@ gatherProblemsOrMains results (NE.List mainResult mainResults) =
9661227addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
9671228addInside name result modules =
9681229 case result of
969− RNew _ iface objs -> Fresh name iface objs : modules
970− RSame _ iface objs -> Fresh name iface objs : modules
971− RCached main mvar -> Cached name main mvar : modules
972− RNotFound _ -> error (badInside name)
973− RProblem _ -> error (badInside name)
974− RBlocked -> error (badInside name)
975− RForeign _ -> modules
976− RKernel -> modules
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
9771238
9781239
9791240badInside :: ModuleName.Raw -> [Char]
@@ -981,9 +1242,9 @@ badInside name =
9811242 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
9821243
9831244
984−addOutside :: MainResult -> [Module] -> [Module]
985−addOutside main modules =
986− case main of
1245+addOutside :: RootResult -> [Module] -> [Module]
1246+addOutside root modules =
1247+ case root of
9871248 RInside _ -> modules
9881249 ROutsideOk name iface objs -> Fresh name iface objs : modules
9891250 ROutsideErr _ -> 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.hs+7−5
@@ -18,7 +18,7 @@ import qualified Data.List as List
1818import qualified Data.Map as Map
1919import qualified Data.Name as Name
2020import qualified Data.Set as Set
21−import qualified Data.Utf8 as Utf8
21+import qualified System.Directory as Dir
2222import System.FilePath ((</>))
2323
2424import qualified Deps.Website as Website
@@ -204,7 +204,7 @@ isSameName :: Name.Name -> Name.Name -> Bool
204204isSameName oldFullName newFullName =
205205 let
206206 dedot name =
207− reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))
207+ reverse (Name.splitDots name)
208208 in
209209 case ( dedot oldFullName, dedot newFullName ) of
210210 (oldName:[], newName:_) ->
@@ -357,7 +357,8 @@ changeMagnitude (Changes added changed removed) =
357357
358358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359359getDocs cache manager name version =
360− do let path = Stuff.package cache name version </> "docs.json"
360+ do let home = Stuff.package cache name version
361+ let path = home </> "docs.json"
361362 exists <- File.exists path
362363 if exists
363364 then
@@ -374,8 +375,9 @@ getDocs cache manager name version =
374375 Http.get manager url [] Exit.DP_Http $ \body ->
375376 case D.fromByteString Docs.decoder body of
376377 Right docs ->
377− do File.writeUtf8 path body
378+ do Dir.createDirectoryIfMissing True home
379+ File.writeUtf8 path body
378380 return $ Right docs
379381
380382 Left _ ->
381− return $ Left Exit.DP_Data
383+ return $ Left $ Exit.DP_Data url body
builder/src/Deps/Registry.hs+35−68
@@ -16,11 +16,8 @@ module Deps.Registry
1616import Prelude hiding (read)
1717import Control.Monad (liftM2)
1818import Data.Binary (Binary, get, put)
19−import Data.Function (on)
2019import qualified Data.List as List
2120import qualified Data.Map.Strict as Map
22−import qualified Data.Name as Name
23−import qualified Data.Utf8 as Utf8
2421
2522import qualified Deps.Website as Website
2623import qualified Elm.Package as Pkg
@@ -28,8 +25,8 @@ import qualified Elm.Version as V
2825import qualified File
2926import qualified Http
3027import qualified Json.Decode as D
28+import qualified Parse.Primitives as P
3129import qualified Reporting.Exit as Exit
32−import qualified Reporting.Suggest as Suggest
3330import qualified Stuff
3431
3532
@@ -57,11 +54,7 @@ data KnownVersions =
5754
5855read :: Stuff.PackageCache -> IO (Maybe Registry)
5956read cache =
60− do let path = Stuff.registry cache
61− exists <- File.exists path
62− if exists
63− then File.readBinary path
64− else return Nothing
57+ File.readBinary (Stuff.registry cache)
6558
6659
6760
@@ -86,26 +79,19 @@ addEntry (KnownVersions _ vs) count =
8679
8780allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
8881allPkgsDecoder =
89− do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))
90− checkKeys pairs Map.empty
91− where
92− checkKeys pairs pkgs =
93− case pairs of
94− [] ->
95− return pkgs
96−
97− (key, versions) : rest ->
98− case Pkg.fromString key of
99− Right pkg ->
100− case List.sortBy (flip compare) versions of
101− [] ->
102− D.failure ()
82+ let
83+ keyDecoder =
84+ Pkg.keyDecoder bail
10385
104− v:vs ->
105− checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)
86+ versionsDecoder =
87+ D.list (D.mapError (\_ -> ()) V.decoder)
10688
107− Left _ ->
108− D.failure ()
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)
10995
11096
11197
@@ -144,22 +130,26 @@ addNew (name, version) versions =
144130 Map.alter (Just . add) name versions
145131
146132
133+
134+-- NEW PACKAGE DECODER
135+
136+
147137newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
148138newPkgDecoder =
149− do str <- D.string
150− case Utf8.split 0x40 {-@-} str of
151− [key, value] ->
152− case Pkg.fromString key of
153− Right pkg ->
154− case V.fromString value of
155− Just vsn -> return (pkg, vsn)
156− Nothing -> D.failure ()
139+ D.customString newPkgParser bail
140+
157141
158− Left _ ->
159− D.failure ()
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)
160148
161− _ ->
162− D.failure ()
149+
150+bail :: row -> col -> ()
151+bail _ _ =
152+ ()
163153
164154
165155
@@ -190,33 +180,7 @@ getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
190180getVersions' name (Registry _ versions) =
191181 case Map.lookup name versions of
192182 Just kvs -> Right kvs
193− Nothing -> Left $ nearbyNames name (Map.keys versions)
194−
195−
196−nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
197−nearbyNames (Pkg.Name author1 project1) possibleNames =
198− let
199− authorDist = authorDistance (Name.toChars author1)
200− projectDist = projectDistance (Name.toChars project1)
201−
202− addDistance name@(Pkg.Name author2 project2) =
203− ( authorDist author2 + projectDist project2, name )
204− in
205− map snd $ take 4 $
206− List.sortBy (compare `on` fst) $
207− map addDistance possibleNames
208−
209−
210−authorDistance :: String -> Name.Name -> Int
211−authorDistance bad possibility =
212− abs (Suggest.distance bad (Name.toChars possibility))
213−
214−
215−projectDistance :: String -> Name.Name -> Int
216−projectDistance bad possibility =
217− if possibility == "elm" || possibility == "elm-explorations"
218− then 0
219− else abs (Suggest.distance bad (Name.toChars possibility))
183+ Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
220184
221185
222186
@@ -225,11 +189,14 @@ projectDistance bad possibility =
225189
226190post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
227191post manager path decoder callback =
228− Http.post manager (Website.route path []) [] Exit.RP_Http $
192+ let
193+ url = Website.route path []
194+ in
195+ Http.post manager url [] Exit.RP_Http $
229196 \body ->
230197 case D.fromByteString decoder body of
231198 Right a -> Right <$> callback a
232− Left _ -> return $ Left Exit.RP_Data
199+ Left _ -> return $ Left $ Exit.RP_Data url body
233200
234201
235202
builder/src/Deps/Solver.hs+31−29
@@ -94,6 +94,7 @@ data Details =
9494
9595verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
9696verify cache connection registry constraints =
97+ Stuff.withRegistryLock cache $
9798 case try constraints of
9899 Solver solver ->
99100 solver (State cache connection registry Map.empty)
@@ -130,6 +131,7 @@ data AppSolution =
130131
131132addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
132133addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134+ Stuff.withRegistryLock cache $
133135 let
134136 allIndirects = Map.union indirect testIndirect
135137 allDirects = Map.union direct testDirect
@@ -311,10 +313,11 @@ getConstraints pkg vsn =
311313 back state
312314
313315 Online manager ->
314− do result <- Http.get manager (Website.metadata pkg vsn "elm.json") [] id (return . Right)
316+ do let url = Website.metadata pkg vsn "elm.json"
317+ result <- Http.get manager url [] id (return . Right)
315318 case result of
316319 Left httpProblem ->
317− err (Exit.SolverBadHttp httpProblem)
320+ err (Exit.SolverBadHttp pkg vsn httpProblem)
318321
319322 Right body ->
320323 case D.fromByteString constraintsDecoder body of
@@ -324,11 +327,9 @@ getConstraints pkg vsn =
324327 ok (toNewState cs) cs back
325328
326329 Left _ ->
327− err (Exit.SolverBadHttpData pkg vsn)
330+ err (Exit.SolverBadHttpData pkg vsn url)
328331
329332
330−-- TODO write constraintsDecoder to be a bit faster
331−--
332333constraintsDecoder :: D.Decoder () Constraints
333334constraintsDecoder =
334335 do outline <- D.mapError (const ()) Outline.decoder
@@ -350,30 +351,31 @@ data Env =
350351
351352initEnv :: IO (Either Exit.RegistryProblem Env)
352353initEnv =
353− do mvar <- newEmptyMVar
354− _ <- forkIO $ putMVar mvar =<< Http.getManager
355− cache <- Stuff.getPackageCache
356− maybeRegistry <- Registry.read cache
357− manager <- readMVar mvar
358−
359− case maybeRegistry of
360− Nothing ->
361− do eitherRegistry <- Registry.fetch manager cache
362− case eitherRegistry of
363− Right latestRegistry ->
364− return $ Right $ Env cache manager (Online manager) latestRegistry
365−
366− Left problem ->
367− return $ Left $ problem
368−
369− Just cachedRegistry ->
370− do eitherRegistry <- Registry.update manager cache cachedRegistry
371− case eitherRegistry of
372− Right latestRegistry ->
373− return $ Right $ Env cache manager (Online manager) latestRegistry
374−
375− Left _ ->
376− return $ Right $ Env cache manager Offline cachedRegistry
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
377379
378380
379381
builder/src/Elm/Bump.hsdeleted−137
@@ -1,137 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Bump
3− ( bump
4− , toPossibleBumps
5− )
6− where
7−
8−
9−import Control.Monad.Trans (liftIO)
10−import qualified Data.List as List
11−
12−import qualified Deps.Cache as Cache
13−import qualified Deps.Diff as Diff
14−import qualified Elm.Project.Json as Project
15−import qualified Elm.Project.Summary as Summary
16−import qualified Elm.Version as V
17−import Reporting.Doc ((<>), (<+>))
18−import qualified Reporting.Doc as D
19−import qualified Reporting.Exit as Exit
20−import qualified Reporting.Exit.Bump as E
21−import qualified Reporting.Exit.Help as Help
22−import qualified Reporting.Progress.Terminal as Terminal
23−import qualified Reporting.Task as Task
24−
25−
26−
27−-- BUMP
28−
29−
30−bump :: Summary.Summary -> Task.Task ()
31−bump summary@(Summary.Summary root project _ _ _) =
32− case project of
33− Project.App _ ->
34− Task.throw (Exit.Bump E.Application)
35−
36− Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->
37− do registry <- Cache.mandatoryUpdate
38− case Cache.getVersions name registry of
39− Left _suggestions ->
40− checkNewPackage root info
41−
42− Right publishedVersions ->
43− let
44− bumpableVersions =
45− map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)
46− in
47− if elem version bumpableVersions then
48− suggestVersion summary info
49− else
50− Task.throw $ Exit.Bump $ E.Unbumpable version $
51− map head (List.group (List.sort bumpableVersions))
52−
53−
54−
55−-- VALID BUMPS
56−
57−
58−toPossibleBumps :: [V.Version] -> [(V.Version, V.Version, Diff.Magnitude)]
59−toPossibleBumps publishedVersions =
60− case publishedVersions of
61− [] ->
62− []
63−
64− _ ->
65− let
66− patchPoints =
67− V.filterLatest V.majorAndMinor publishedVersions
68−
69− minorPoints =
70− V.filterLatest V._major publishedVersions
71−
72− majorPoint =
73− maximum publishedVersions
74− in
75− (majorPoint, V.bumpMajor majorPoint, Diff.MAJOR)
76− : map (\v -> (v, V.bumpMinor v, Diff.MINOR)) minorPoints
77− ++ map (\v -> (v, V.bumpPatch v, Diff.PATCH)) patchPoints
78−
79−
80−
81−-- CHECK NEW PACKAGE
82−
83−
84−checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()
85−checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =
86− do liftIO $ putStrLn Terminal.newPackageOverview
87− if version == V.one
88− then
89− liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"
90− else
91− changeVersion root info V.one $
92− "It looks like the version in elm.json has been changed though!\n\
93− \Would you like me to change it back to "
94− <> D.fromUtf8 (V.toString V.one) <> "? [Y/n] "
95−
96−
97−
98−-- SUGGEST VERSION
99−
100−
101−suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()
102−suggestVersion (Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =
103− do oldDocs <- Cache.getDocs name version
104− newDocs <- Task.silently (error "TODO Project.generateDocs summary")
105− let changes = Diff.diff oldDocs newDocs
106− let newVersion = Diff.bump changes version
107− changeVersion root info newVersion $
108− let
109− old = D.fromUtf8 $ V.toString version
110− new = D.fromUtf8 $ V.toString newVersion
111− mag = D.fromChars $ Diff.magnitudeToString (Diff.toMagnitude changes)
112− in
113− "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
114− <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
115− <> "\n"
116− <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
117−
118−
119−
120−-- CHANGE VERSION
121−
122−
123−changeVersion :: FilePath -> Project.PkgInfo -> V.Version -> D.Doc -> Task.Task ()
124−changeVersion root info targetVersion explanation =
125− do approved <- Task.getApproval explanation
126− if not approved
127− then
128− liftIO $ putStrLn "Okay, I did not change anything!"
129−
130− else
131− do liftIO $ Project.write root $ Project.Pkg $
132− info { Project._pkg_version = targetVersion }
133−
134− liftIO $ Help.toStdout $
135− "Version changed to "
136− <> D.green (D.fromUtf8 (V.toString targetVersion))
137− <> "!\n"
builder/src/Elm/Details.hs+194−97
@@ -2,6 +2,7 @@
22{-# LANGUAGE BangPatterns, OverloadedStrings #-}
33module Elm.Details
44 ( Details(..)
5+ , BuildID
56 , ValidOutline(..)
67 , Local(..)
78 , Foreign(..)
@@ -15,25 +16,32 @@ module Elm.Details
1516
1617import Control.Concurrent (forkIO)
1718import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
18−import Control.Monad (liftM, liftM2, liftM4)
19+import Control.Monad (liftM, liftM2, liftM3)
1920import Data.Binary (Binary, get, put, getWord8, putWord8)
21+import qualified Data.Either as Either
2022import qualified Data.Map as Map
2123import qualified Data.Map.Utils as Map
2224import qualified Data.Map.Merge.Strict as Map
25+import qualified Data.Maybe as Maybe
2326import qualified Data.Name as Name
27+import qualified Data.NonEmptyList as NE
2428import qualified Data.OneOrMore as OneOrMore
2529import qualified Data.Set as Set
2630import qualified Data.Utf8 as Utf8
31+import Data.Word (Word64)
2732import qualified System.Directory as Dir
2833import System.FilePath ((</>), (<.>))
2934
35+import qualified AST.Canonical as Can
3036import qualified AST.Source as Src
3137import qualified AST.Optimized as Opt
38+import qualified BackgroundWriter as BW
3239import qualified Compile
3340import qualified Deps.Registry as Registry
3441import qualified Deps.Solver as Solver
3542import qualified Deps.Website as Website
3643import qualified Elm.Constraint as Con
44+import qualified Elm.Docs as Docs
3745import qualified Elm.Interface as I
3846import qualified Elm.Kernel as Kernel
3947import qualified Elm.ModuleName as ModuleName
@@ -43,6 +51,7 @@ import qualified Elm.Version as V
4351import qualified File
4452import qualified Http
4553import qualified Json.Decode as D
54+import qualified Json.Encode as E
4655import qualified Parse.Module as Parse
4756import qualified Reporting
4857import qualified Reporting.Annotation as A
@@ -59,23 +68,42 @@ data Details =
5968 Details
6069 { _outlineTime :: File.Time
6170 , _outline :: ValidOutline
71+ , _buildID :: BuildID
6272 , _locals :: Map.Map ModuleName.Raw Local
6373 , _foreigns :: Map.Map ModuleName.Raw Foreign
6474 , _extras :: Extras
6575 }
6676
6777
68−data ValidOutline
69− = ValidApp Outline.AppOutline
70− | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)
78+type BuildID = Word64
7179
7280
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+--
7399data Local =
74100 Local
75101 { _path :: FilePath
76102 , _time :: File.Time
77103 , _deps :: [ModuleName.Raw]
78104 , _main :: Bool
105+ , _lastChange :: BuildID
106+ , _lastCompile :: BuildID
79107 }
80108
81109
@@ -97,14 +125,14 @@ type Interfaces =
97125
98126
99127loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
100−loadObjects root (Details _ _ _ _ extras) =
128+loadObjects root (Details _ _ _ _ _ extras) =
101129 case extras of
102130 ArtifactsFresh _ o -> newMVar (Just o)
103131 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
104132
105133
106134loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
107−loadInterfaces root (Details _ _ _ _ extras) =
135+loadInterfaces root (Details _ _ _ _ _ extras) =
108136 case extras of
109137 ArtifactsFresh i _ -> newMVar (Just i)
110138 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
@@ -114,11 +142,11 @@ loadInterfaces root (Details _ _ _ _ extras) =
114142-- VERIFY INSTALL -- used by Install
115143
116144
117−verifyInstall :: FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
118−verifyInstall root (Solver.Env cache manager connection registry) outline =
145+verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
146+verifyInstall scope root (Solver.Env cache manager connection registry) outline =
119147 do time <- File.getTime (root </> "elm.json")
120148 let key = Reporting.ignorer
121− let env = Env key root cache manager connection registry
149+ let env = Env key scope root cache manager connection registry
122150 case outline of
123151 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
124152 Outline.App app -> Task.run (verifyApp env time app >> return ())
@@ -128,28 +156,28 @@ verifyInstall root (Solver.Env cache manager connection registry) outline =
128156-- LOAD -- used by Make, Repl, Reactor
129157
130158
131−load :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)
132−load style root =
159+load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
160+load style scope root =
133161 do newTime <- File.getTime (root </> "elm.json")
134162 maybeDetails <- File.readBinary (Stuff.details root)
135163 case maybeDetails of
136164 Nothing ->
137− generate style root newTime
165+ generate style scope root newTime
138166
139− Just details@(Details oldTime _ _ _ _) ->
167+ Just details@(Details oldTime _ buildID _ _ _) ->
140168 if oldTime == newTime
141− then return (Right details)
142− else generate style root newTime
169+ then return (Right details { _buildID = buildID + 1 })
170+ else generate style scope root newTime
143171
144172
145173
146174-- GENERATE
147175
148176
149−generate :: Reporting.Style -> FilePath -> File.Time -> IO (Either Exit.Details Details)
150−generate style root time =
177+generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
178+generate style scope root time =
151179 Reporting.trackDetails style $ \key ->
152− do result <- initEnv key root
180+ do result <- initEnv key scope root
153181 case result of
154182 Left exit ->
155183 return (Left exit)
@@ -167,6 +195,7 @@ generate style root time =
167195data Env =
168196 Env
169197 { _key :: Reporting.DKey
198+ , _scope :: BW.Scope
170199 , _root :: FilePath
171200 , _cache :: Stuff.PackageCache
172201 , _manager :: Http.Manager
@@ -175,8 +204,8 @@ data Env =
175204 }
176205
177206
178−initEnv :: Reporting.DKey -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
179−initEnv key root =
207+initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
208+initEnv key scope root =
180209 do mvar <- fork Solver.initEnv
181210 eitherOutline <- Outline.read root
182211 case eitherOutline of
@@ -190,7 +219,7 @@ initEnv key root =
190219 return $ Left $ Exit.DetailsCannotGetRegistry problem
191220
192221 Right (Solver.Env cache manager connection registry) ->
193− return $ Right (Env key root cache manager connection registry, outline)
222+ return $ Right (Env key scope root cache manager connection registry, outline)
194223
195224
196225
@@ -201,24 +230,25 @@ type Task a = Task.Task Exit.Details a
201230
202231
203232verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
204−verifyPkg env time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
233+verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
205234 if Con.goodElm elm
206235 then
207236 do solution <- verifyConstraints env =<< union noDups direct testDirect
208− let vsns = Map.map (\(Solver.Details v _) -> v) solution
209− verifyDependencies env time (ValidPkg outline vsns) solution direct
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
210240 else
211241 Task.throw $ Exit.DetailsBadElmInPkg elm
212242
213243
214244verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
215−verifyApp env time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
245+verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
216246 if elmVersion == V.compiler
217247 then
218248 do stated <- checkAppDeps outline
219249 actual <- verifyConstraints env (Map.map Con.exactly stated)
220250 if Map.size stated == Map.size actual
221− then verifyDependencies env time (ValidApp outline) actual direct
251+ then verifyDependencies env time (ValidApp srcDirs) actual direct
222252 else Task.throw $ Exit.DetailsHandEditedDependencies
223253 else
224254 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
@@ -236,7 +266,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
236266
237267
238268verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
239−verifyConstraints (Env _ _ cache _ connection registry) constraints =
269+verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
240270 do result <- Task.io $ Solver.verify cache connection registry constraints
241271 case result of
242272 Solver.Ok details -> return details
@@ -282,27 +312,30 @@ fork work =
282312
283313
284314verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
285−verifyDependencies env@(Env key root _ _ _ _) time outline solution directDeps =
315+verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
286316 Task.eio id $
287317 do Reporting.report key (Reporting.DStart (Map.size solution))
288318 mvar <- newEmptyMVar
289− mvars <- Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
319+ mvars <- Stuff.withRegistryLock cache $
320+ Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
290321 putMVar mvar mvars
291322 deps <- traverse readMVar mvars
292323 case sequence deps of
293− Left problem ->
294− error "TODO verifyDependencies" problem
324+ Left _ ->
325+ do home <- Stuff.getElmHome
326+ return $ Left $ Exit.DetailsBadDeps home $
327+ Maybe.catMaybes $ Either.lefts $ Map.elems deps
295328
296329 Right artifacts ->
297330 let
298331 objs = Map.foldr addObjects Opt.empty artifacts
299332 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
300− foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
301− details = Details time outline Map.empty foreigns (ArtifactsFresh ifaces objs)
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)
302335 in
303− do File.writeBinary (Stuff.objects root) objs
304− File.writeBinary (Stuff.interfaces root) ifaces
305− File.writeBinary (Stuff.details root) details
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
306339 return (Right details)
307340
308341
@@ -342,44 +375,36 @@ data Artifacts =
342375
343376
344377type Dep =
345− Either Problem Artifacts
346−
347−
348−data Problem
349− = BadDownload Exit.PackageProblem
350− | BadBuild
351− | BadDependency
378+ Either (Maybe Exit.DetailsBadDep) Artifacts
352379
353380
354381verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
355−verifyDep (Env key _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
356− let
357− fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
358− in
359− do exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
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")
360385 if exists
361386 then
362387 do Reporting.report key Reporting.DCached
363388 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
364389 case maybeCache of
365390 Nothing ->
366− build key cache depsMVar pkg details (Set.singleton fingerprint)
391+ build key cache depsMVar pkg details fingerprint Set.empty
367392
368393 Just (ArtifactCache fingerprints artifacts) ->
369394 if Set.member fingerprint fingerprints
370395 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
371− else build key cache depsMVar pkg details (Set.insert fingerprint fingerprints)
396+ else build key cache depsMVar pkg details fingerprint fingerprints
372397 else
373398 do Reporting.report key Reporting.DRequested
374399 result <- downloadPackage cache manager pkg vsn
375400 case result of
376− Left p ->
401+ Left problem ->
377402 do Reporting.report key (Reporting.DFailed pkg vsn)
378− return (Left (BadDownload p))
403+ return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
379404
380405 Right () ->
381406 do Reporting.report key (Reporting.DReceived pkg vsn)
382− build key cache depsMVar pkg details (Set.singleton fingerprint)
407+ build key cache depsMVar pkg details fingerprint Set.empty
383408
384409
385410
@@ -401,17 +426,17 @@ type Fingerprint =
401426-- BUILD
402427
403428
404−build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Dep
405−build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
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 =
406431 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
407432 case eitherOutline of
408433 Left _ ->
409434 do Reporting.report key Reporting.DBroken
410− return (Left BadBuild)
435+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
411436
412437 Right (Outline.App _) ->
413438 do Reporting.report key Reporting.DBroken
414− return (Left BadBuild)
439+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
415440
416441 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
417442 do allDeps <- readMVar depsMVar
@@ -419,21 +444,22 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
419444 case sequence directDeps of
420445 Left _ ->
421446 do Reporting.report key Reporting.DBroken
422− return (Left BadDependency)
447+ return $ Left $ Nothing
423448
424449 Right directArtifacts ->
425450 do let src = Stuff.package cache pkg vsn </> "src"
426451 let foreignDeps = gatherForeignInterfaces directArtifacts
427452 let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
453+ docsStatus <- getDocsStatus cache pkg vsn
428454 mvar <- newEmptyMVar
429− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) exposedDict
455+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
430456 putMVar mvar mvars
431457 mapM_ readMVar mvars
432458 maybeStatuses <- traverse readMVar =<< readMVar mvar
433459 case sequence maybeStatuses of
434460 Nothing ->
435461 do Reporting.report key Reporting.DBroken
436− return (Left BadBuild)
462+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
437463
438464 Just statuses ->
439465 do rmvar <- newEmptyMVar
@@ -443,7 +469,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
443469 case sequence maybeResults of
444470 Nothing ->
445471 do Reporting.report key Reporting.DBroken
446− return (Left BadBuild)
472+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
447473
448474 Just results ->
449475 let
@@ -451,8 +477,10 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
451477 ifaces = gatherInterfaces exposedDict results
452478 objects = gatherObjects results
453479 artifacts = Artifacts ifaces objects
480+ fingerprints = Set.insert f fs
454481 in
455− do File.writeBinary path (ArtifactCache fingerprints artifacts)
482+ do writeDocs cache pkg vsn docsStatus results
483+ File.writeBinary path (ArtifactCache fingerprints artifacts)
456484 Reporting.report key Reporting.DBuilt
457485 return (Right artifacts)
458486
@@ -469,7 +497,7 @@ gatherObjects results =
469497addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
470498addLocalGraph name status graph =
471499 case status of
472− RLocal _ objs -> Opt.addLocalGraph objs graph
500+ RLocal _ objs _ -> Opt.addLocalGraph objs graph
473501 RForeign _ -> graph
474502 RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
475503 RKernelForeign -> graph
@@ -488,10 +516,10 @@ gatherInterfaces exposed artifacts =
488516toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
489517toLocalInterface func result =
490518 case result of
491− RLocal iface _ -> Just (func iface)
492− RForeign _ -> Nothing
493− RKernelLocal _ -> Nothing
494− RKernelForeign -> Nothing
519+ RLocal iface _ _ -> Just (func iface)
520+ RForeign _ -> Nothing
521+ RKernelLocal _ -> Nothing
522+ RKernelForeign -> Nothing
495523
496524
497525
@@ -534,14 +562,14 @@ type StatusDict =
534562
535563
536564data Status
537− = SLocal (Map.Map ModuleName.Raw ()) Src.Module
565+ = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
538566 | SForeign I.Interface
539567 | SKernelLocal [Kernel.Chunk]
540568 | SKernelForeign
541569
542570
543−crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)
544−crawlModule foreignDeps mvar pkg src name =
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 =
545573 do let path = src </> ModuleName.toFilePath name <.> "elm"
546574 exists <- File.exists path
547575 case Map.lookup name foreignDeps of
@@ -555,7 +583,7 @@ crawlModule foreignDeps mvar pkg src name =
555583
556584 Nothing ->
557585 if exists then
558− crawlFile foreignDeps mvar pkg src name path
586+ crawlFile foreignDeps mvar pkg src docsStatus name path
559587
560588 else if Pkg.isKernel pkg && Name.isKernel name then
561589 crawlKernel foreignDeps mvar pkg src name
@@ -564,13 +592,13 @@ crawlModule foreignDeps mvar pkg src name =
564592 return Nothing
565593
566594
567−crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
568−crawlFile foreignDeps mvar pkg src expectedName path =
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 =
569597 do bytes <- File.readUtf8 path
570− case Parse.fromByteString pkg bytes of
571− Right modul@(Src.Module (Just (A.At _ actualName)) _ imports _ _ _ _ _) | expectedName == actualName ->
598+ case Parse.fromByteString (Parse.Package pkg) bytes of
599+ Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
572600 do deps <- crawlImports foreignDeps mvar pkg src imports
573− return (Just (SLocal deps modul))
601+ return (Just (SLocal docsStatus deps modul))
574602
575603 _ ->
576604 return Nothing
@@ -581,7 +609,7 @@ crawlImports foreignDeps mvar pkg src imports =
581609 do statusDict <- takeMVar mvar
582610 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
583611 let news = Map.difference deps statusDict
584− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) news
612+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news
585613 putMVar mvar (Map.union mvars statusDict)
586614 mapM_ readMVar mvars
587615 return deps
@@ -617,7 +645,7 @@ getDepHome fi =
617645
618646
619647data Result
620− = RLocal !I.Interface !Opt.LocalGraph
648+ = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)
621649 | RForeign I.Interface
622650 | RKernelLocal [Kernel.Chunk]
623651 | RKernelForeign
@@ -626,7 +654,7 @@ data Result
626654compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
627655compile pkg mvar status =
628656 case status of
629− SLocal deps modul ->
657+ SLocal docsStatus deps modul ->
630658 do resultsDict <- readMVar mvar
631659 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
632660 case sequence maybeResults of
@@ -639,7 +667,11 @@ compile pkg mvar status =
639667 return Nothing
640668
641669 Right (Compile.Artifacts canonical annotations objects) ->
642− return (Just (RLocal (I.fromModule pkg 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))
643675
644676 SForeign iface ->
645677 return (Just (RForeign iface))
@@ -654,10 +686,59 @@ compile pkg mvar status =
654686getInterface :: Result -> Maybe I.Interface
655687getInterface result =
656688 case result of
657− RLocal iface _ -> Just iface
658− RForeign iface -> Just iface
659− RKernelLocal _ -> Nothing
660− RKernelForeign -> Nothing
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
661742
662743
663744
@@ -666,24 +747,27 @@ getInterface result =
666747
667748downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
668749downloadPackage cache manager pkg vsn =
750+ let
751+ url = Website.metadata pkg vsn "endpoint.json"
752+ in
669753 do eitherByteString <-
670− Http.get manager (Website.metadata pkg vsn "endpoint.json") [] id (return . Right)
754+ Http.get manager url [] id (return . Right)
671755
672756 case eitherByteString of
673757 Left err ->
674− return (Left (Exit.PP_BadEndpointRequest err))
758+ return $ Left $ Exit.PP_BadEndpointRequest err
675759
676760 Right byteString ->
677761 case D.fromByteString endpointDecoder byteString of
678762 Left _ ->
679− return (Left Exit.PP_BadEndpointContent)
763+ return $ Left $ Exit.PP_BadEndpointContent url
680764
681765 Right (endpoint, expectedHash) ->
682− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
766+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
683767 \(sha, archive) ->
684768 if expectedHash == Http.shaToChars sha
685769 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
686− else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
770+ else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
687771
688772
689773endpointDecoder :: D.Decoder e (String, String)
@@ -698,27 +782,40 @@ endpointDecoder =
698782
699783
700784instance Binary Details where
701− get = do { a <- get; b <- get; c <- get; d <- get; return (Details a b c d ArtifactsCached) }
702− put (Details a b c d _) = put a >> put b >> put c >> put d
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)
703793
704794
705795instance Binary ValidOutline where
706796 put outline =
707797 case outline of
708− ValidApp a -> putWord8 0 >> put a
709− ValidPkg a b -> putWord8 1 >> put a >> put b
798+ ValidApp a -> putWord8 0 >> put a
799+ ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
710800
711801 get =
712802 do n <- getWord8
713803 case n of
714804 0 -> liftM ValidApp get
715− 1 -> liftM2 ValidPkg get get
716− _ -> error "binary encoding of ValidOutline was corrupted"
805+ 1 -> liftM3 ValidPkg get get get
806+ _ -> fail "binary encoding of ValidOutline was corrupted"
717807
718808
719809instance Binary Local where
720− get = liftM4 Local get get get get
721− put (Local a b c d) = put a >> put b >> put c >> put d
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)
722819
723820
724821instance Binary Foreign where
builder/src/Elm/Diff.hsdeleted−284
@@ -1,284 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Diff
4− ( Args(..)
5− , diff
6− )
7− where
8−
9−
10−import Control.Monad.Except (liftIO)
11−import qualified Data.List as List
12−import qualified Data.Map as Map
13−import qualified Data.Maybe as Maybe
14−import qualified Data.Name as Name
15−
16−import qualified Deps.Cache as Cache
17−import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
18−import qualified Deps.Diff as Diff
19−import qualified Elm.Compiler.Type as Type
20−import qualified Elm.Docs as Docs
21−import qualified Elm.ModuleName as ModuleName
22−import qualified Elm.Package as Pkg
23−import qualified Elm.Project as Project
24−import qualified Elm.Project.Json as Project
25−import qualified Elm.Project.Summary as Summary
26−import qualified Elm.Version as V
27−import Reporting.Doc ((<>), (<+>))
28−import qualified Reporting.Doc as D
29−import qualified Reporting.Exit as Exit
30−import qualified Reporting.Exit.Diff as E
31−import qualified Reporting.Exit.Help as Help
32−import qualified Reporting.Render.Type.Localizer as L
33−import qualified Reporting.Task as Task
34−
35−
36−
37−-- DIFF
38−
39−
40−data Args
41− = CodeVsLatest
42− | CodeVsExactly V.Version
43− | LocalInquiry V.Version V.Version
44− | GlobalInquiry Pkg.Name V.Version V.Version
45−
46−
47−diff :: Args -> Task.Task ()
48−diff args =
49− case args of
50− GlobalInquiry name v1 v2 ->
51− do registry <- Cache.mandatoryUpdate
52− case Cache.getVersions name registry of
53− Left suggestions ->
54− throw $ E.UnknownPackage name suggestions
55−
56− Right vsns ->
57− do oldDocs <- getDocs name vsns (min v1 v2)
58− newDocs <- getDocs name vsns (max v1 v2)
59− writeDiff oldDocs newDocs
60−
61− LocalInquiry v1 v2 ->
62− do (_, name, vsns) <- getPackageInfo
63− oldDocs <- getDocs name vsns (min v1 v2)
64− newDocs <- getDocs name vsns (max v1 v2)
65− writeDiff oldDocs newDocs
66−
67− CodeVsLatest ->
68− do (summary, name, vsns) <- getPackageInfo
69− oldDocs <- getDocs name vsns (maximum vsns)
70− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
71− writeDiff oldDocs newDocs
72−
73− CodeVsExactly version ->
74− do (summary, name, vsns) <- getPackageInfo
75− oldDocs <- getDocs name vsns version
76− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
77− writeDiff oldDocs newDocs
78−
79−
80−throw :: E.Exit -> Task.Task a
81−throw exit =
82− Task.throw $ Exit.Diff exit
83−
84−
85−
86−-- DIFF HELPERS
87−
88−
89−getDocs :: Pkg.Name -> [V.Version] -> V.Version -> Task.Task Docs.Documentation
90−getDocs name allVersions version =
91− if elem version allVersions then
92− Cache.getDocs name version
93− else
94− throw $ E.UnknownVersion name version allVersions
95−
96−
97−getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [V.Version])
98−getPackageInfo =
99− do summary <- Project.getRoot
100− case Summary._project summary of
101− Project.App _ ->
102− throw $ E.Application
103−
104− Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
105− do registry <- Cache.mandatoryUpdate
106− case Cache.getVersions name registry of
107− Right vsns ->
108− return ( summary, name, vsns )
109−
110− Left _ ->
111− throw E.Unpublished
112−
113−
114−
115−-- WRITE DOC
116−
117−
118−writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()
119−writeDiff oldDocs newDocs =
120− let
121− changes = Diff.diff oldDocs newDocs
122− localizer = L.fromNames (Map.union oldDocs newDocs)
123− in
124− liftIO $ Help.toStdout (toDoc localizer changes <> "\n")
125−
126−
127−
128−-- TO DOC
129−
130−
131−toDoc :: L.Localizer -> PackageChanges -> D.Doc
132−toDoc localizer changes@(PackageChanges added changed removed) =
133− if null added && Map.null changed && null removed then
134− "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
135− else
136− let
137− magDoc =
138− D.fromChars (Diff.magnitudeToString (Diff.toMagnitude changes))
139−
140− header =
141− "This is a" <+> D.green magDoc <+> "change."
142−
143− addedChunk =
144− if null added then [] else
145− [ Chunk "ADDED MODULES" MINOR $
146− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) added
147− ]
148−
149− removedChunk =
150− if null removed then [] else
151− [ Chunk "REMOVED MODULES" MAJOR $
152− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) removed
153− ]
154−
155− chunks =
156− addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
157− in
158− D.vcat (header : "" : map chunkToDoc chunks)
159−
160−
161−data Chunk =
162− Chunk
163− { _title :: String
164− , _magnitude :: Magnitude
165− , _details :: D.Doc
166− }
167−
168−
169−chunkToDoc :: Chunk -> D.Doc
170−chunkToDoc (Chunk title magnitude details) =
171− let
172− magDoc =
173− Diff.magnitudeToString magnitude
174−
175− header =
176− "----" <+> D.fromChars title <+> "-" <+> D.fromChars magDoc <+> "----"
177− in
178− D.vcat
179− [ D.dullcyan header
180− , ""
181− , D.indent 4 details
182− , ""
183− , ""
184− ]
185−
186−
187−changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
188−changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
189− let
190− magnitude =
191− Diff.moduleChangeMagnitude changes
192−
193− (unionAdd, unionChange, unionRemove) =
194− changesToDocTriple (unionToDoc localizer) unions
195−
196− (aliasAdd, aliasChange, aliasRemove) =
197− changesToDocTriple (aliasToDoc localizer) aliases
198−
199− (valueAdd, valueChange, valueRemove) =
200− changesToDocTriple (valueToDoc localizer) values
201−
202− (binopAdd, binopChange, binopRemove) =
203− changesToDocTriple (binopToDoc localizer) binops
204− in
205− Chunk (Name.toChars name) magnitude $
206− D.vcat $ List.intersperse "" $ Maybe.catMaybes $
207− [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
208− , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
209− , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
210− ]
211−
212−
213−changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
214−changesToDocTriple entryToDoc (Changes added changed removed) =
215− let
216− indented (name, value) =
217− D.indent 4 (entryToDoc name value)
218−
219− diffed (name, (oldValue, newValue)) =
220− D.vcat
221− [ " - " <> entryToDoc name oldValue
222− , " + " <> entryToDoc name newValue
223− , ""
224− ]
225− in
226− ( map indented (Map.toList added)
227− , map diffed (Map.toList changed)
228− , map indented (Map.toList removed)
229− )
230−
231−
232−changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
233−changesToDoc categoryName unions aliases values binops =
234− if null unions && null aliases && null values && null binops then
235− Nothing
236−
237− else
238− Just $ D.vcat $
239− D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
240−
241−
242−unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
243−unionToDoc localizer name (Docs.Union _ tvars ctors) =
244− let
245− setup =
246− "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
247−
248− ctorDoc (ctor, tipes) =
249− typeDoc localizer (Type.Type ctor tipes)
250− in
251− D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
252−
253−
254−aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
255−aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
256− let
257− declaration =
258− "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
259− in
260− D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
261−
262−
263−valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
264−valueToDoc localizer name (Docs.Value _ tipe) =
265− D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
266−
267−
268−binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
269−binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
270− "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
271− where
272− details =
273− " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
274−
275− assoc =
276− case associativity of
277− Docs.Left -> "left"
278− Docs.Non -> "non"
279− Docs.Right -> "right"
280−
281−
282−typeDoc :: L.Localizer -> Type.Type -> D.Doc
283−typeDoc localizer tipe =
284− Type.toDoc localizer Type.None tipe
builder/src/Elm/Outline.hs+148−115
@@ -1,10 +1,11 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
33module Elm.Outline
44 ( Outline(..)
55 , AppOutline(..)
66 , PkgOutline(..)
77 , Exposed(..)
8+ , SrcDir(..)
89 , read
910 , write
1011 , encode
@@ -18,10 +19,12 @@ module Elm.Outline
1819import Prelude hiding (read)
1920import Control.Monad (filterM, liftM)
2021import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import Data.Foldable (traverse_)
2222import qualified Data.Map as Map
23−import qualified Data.Utf8 as Utf8
23+import qualified Data.NonEmptyList as NE
24+import qualified Data.OneOrMore as OneOrMore
25+import Foreign.Ptr (minusPtr)
2426import qualified System.Directory as Dir
27+import qualified System.FilePath as FP
2528import System.FilePath ((</>))
2629
2730import qualified Elm.Constraint as Con
@@ -32,6 +35,9 @@ import qualified Elm.Version as V
3235import qualified File
3336import qualified Json.Decode as D
3437import qualified Json.Encode as E
38+import Json.Encode ((==>))
39+import qualified Json.String as Json
40+import qualified Parse.Primitives as P
3541import qualified Reporting.Exit as Exit
3642
3743
@@ -47,7 +53,7 @@ data Outline
4753data AppOutline =
4854 AppOutline
4955 { _app_elm_version :: V.Version
50− , _app_source_dirs :: [FilePath]
56+ , _app_source_dirs :: NE.List SrcDir
5157 , _app_deps_direct :: Map.Map Pkg.Name V.Version
5258 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
5359 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -58,7 +64,7 @@ data AppOutline =
5864data PkgOutline =
5965 PkgOutline
6066 { _pkg_name :: Pkg.Name
61− , _pkg_summary :: Utf8.String
67+ , _pkg_summary :: Json.String
6268 , _pkg_license :: Licenses.License
6369 , _pkg_version :: V.Version
6470 , _pkg_exposed :: Exposed
@@ -70,16 +76,21 @@ data PkgOutline =
7076
7177data Exposed
7278 = ExposedList [ModuleName.Raw]
73− | ExposedDict [(Utf8.String, [ModuleName.Raw])]
79+ | ExposedDict [(Json.String, [ModuleName.Raw])]
80+
81+
82+data SrcDir
83+ = AbsoluteSrcDir FilePath
84+ | RelativeSrcDir FilePath
7485
7586
7687
7788-- DEFAULTS
7889
7990
80−defaultSummary :: Utf8.String
91+defaultSummary :: Json.String
8192defaultSummary =
82− "helpful summary of your project, less than 80 characters"
93+ Json.fromChars "helpful summary of your project, less than 80 characters"
8394
8495
8596
@@ -114,8 +125,8 @@ encode outline =
114125 case outline of
115126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
116127 E.object
117− [ "type" ==> E.string "application"
118− , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs
128+ [ "type" ==> E.chars "application"
129+ , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
119130 , "elm-version" ==> V.encode elm
120131 , "dependencies" ==>
121132 E.object
@@ -131,7 +142,7 @@ encode outline =
131142
132143 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
133144 E.object
134− [ "type" ==> E.string "package"
145+ [ "type" ==> E.string (Json.fromChars "package")
135146 , "name" ==> Pkg.encode name
136147 , "summary" ==> E.string summary
137148 , "license" ==> Licenses.encode license
@@ -143,11 +154,6 @@ encode outline =
143154 ]
144155
145156
146−(==>) :: a -> b -> (a, b)
147−(==>) a b =
148− (a, b)
149−
150−
151157encodeExposed :: Exposed -> E.Value
152158encodeExposed exposed =
153159 case exposed of
@@ -165,7 +171,14 @@ encodeModule name =
165171
166172encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
167173encodeDeps encodeValue deps =
168− E.dict Pkg.toString 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
169182
170183
171184
@@ -181,19 +194,72 @@ read root =
181194
182195 Right outline ->
183196 case outline of
184− Pkg _ ->
185− return $ Right outline
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+
186251
187− App (AppOutline _ srcDirs _ _ _ _) ->
188− do badDirs <- filterM (isBadSrcDir root) srcDirs
189− case badDirs of
190− [] -> return $ Right outline
191− d:ds -> return $ Left (Exit.OutlineHasBadSrcDirs d ds)
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))
192256
193257
194−isBadSrcDir :: FilePath -> FilePath -> IO Bool
195−isBadSrcDir root dir =
196− not <$> Dir.doesDirectoryExist (root </> dir)
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)
197263
198264
199265
@@ -206,23 +272,21 @@ type Decoder a =
206272
207273decoder :: Decoder Outline
208274decoder =
275+ let
276+ application = Json.fromChars "application"
277+ package = Json.fromChars "package"
278+ in
209279 do tipe <- D.field "type" D.string
210− case tipe of
211− "application" ->
212− App <$> appDecoder
213−
214− "package" ->
215− Pkg <$> pkgDecoder
216−
217− other ->
218− D.failure (Exit.OP_BadType other)
280+ if | tipe == application -> App <$> appDecoder
281+ | tipe == package -> Pkg <$> pkgDecoder
282+ | otherwise -> D.failure Exit.OP_BadType
219283
220284
221285appDecoder :: Decoder AppOutline
222286appDecoder =
223287 AppOutline
224288 <$> D.field "elm-version" versionDecoder
225− <*> D.field "source-directories" (D.list dirDecoder)
289+ <*> D.field "source-directories" dirsDecoder
226290 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
227291 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
228292 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
@@ -232,7 +296,7 @@ appDecoder =
232296pkgDecoder :: Decoder PkgOutline
233297pkgDecoder =
234298 PkgOutline
235− <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)
299+ <$> D.field "name" nameDecoder
236300 <*> D.field "summary" summaryDecoder
237301 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
238302 <*> D.field "version" versionDecoder
@@ -246,17 +310,21 @@ pkgDecoder =
246310-- JSON DECODE HELPERS
247311
248312
249−summaryDecoder :: Decoder Utf8.String
313+nameDecoder :: Decoder Pkg.Name
314+nameDecoder =
315+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316+
317+
318+summaryDecoder :: Decoder Json.String
250319summaryDecoder =
251− do summary <- D.string
252− if Utf8.size summary < 80
253− then return summary
254− else D.failure Exit.OP_BadSummaryTooLong
320+ D.customString
321+ (boundParser 80 Exit.OP_BadSummaryTooLong)
322+ (\_ _ -> Exit.OP_BadSummaryTooLong)
255323
256324
257325versionDecoder :: Decoder V.Version
258326versionDecoder =
259− D.mapError Exit.OP_BadVersion V.decoder
327+ D.mapError (uncurry Exit.OP_BadVersion) V.decoder
260328
261329
262330constraintDecoder :: Decoder Con.Constraint
@@ -266,24 +334,19 @@ constraintDecoder =
266334
267335depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
268336depsDecoder valueDecoder =
269− Map.fromList <$> (
270− traverse validateKey =<< D.pairs valueDecoder
271− )
337+ D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
272338
273339
274−validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
275−validateKey (key, value) =
276− case Pkg.fromString key of
277− Right name ->
278− return (name, value)
340+dirsDecoder :: Decoder (NE.List SrcDir)
341+dirsDecoder =
342+ fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
279343
280− Left _ ->
281− D.failure (Exit.OP_BadDependencyName key)
282344
283−
284−dirDecoder :: Decoder FilePath
285−dirDecoder =
286− Utf8.toChars <$> D.string
345+toSrcDir :: FilePath -> SrcDir
346+toSrcDir path =
347+ if FP.isRelative path
348+ then RelativeSrcDir path
349+ else AbsoluteSrcDir path
287350
288351
289352
@@ -294,81 +357,51 @@ exposedDecoder :: Decoder Exposed
294357exposedDecoder =
295358 D.oneOf
296359 [ ExposedList <$> D.list moduleDecoder
297− , do pairs <- D.pairs (D.list moduleDecoder)
298− traverse_ (checkHeader . fst) pairs
299− return (ExposedDict pairs)
360+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
300361 ]
301362
302363
303364moduleDecoder :: Decoder ModuleName.Raw
304365moduleDecoder =
305− D.mapError Exit.OP_BadModuleName ModuleName.decoder
366+ D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
306367
307368
308−checkHeader :: Utf8.String -> Decoder ()
309−checkHeader header =
310− if Utf8.size header < 20
311− then return ()
312− else D.failure (Exit.OP_BadModuleHeaderTooLong header)
369+headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
370+headerKeyDecoder =
371+ D.KeyDecoder
372+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
373+ (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
313374
314375
315376
316−-- BINARY
377+-- BOUND PARSER
317378
318379
319−instance Binary Outline where
320− put outline =
321− case outline of
322− App a -> putWord8 0 >> put a
323− Pkg a -> putWord8 1 >> put a
324−
325− get =
326− do n <- getWord8
327− case n of
328− 0 -> liftM App get
329− 1 -> liftM Pkg get
330− _ -> error "binary encoding of Outline was corrupted"
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)
331390
332391
333−instance Binary AppOutline where
334− put (AppOutline a b c d e f) =
335− put a >> put b >> put c >> put d >> put e >> put f
336−
337− get =
338− do a <- get
339− b <- get
340− c <- get
341− d <- get
342− e <- get
343− f <- get
344− return (AppOutline a b c d e f)
345392
393+-- BINARY
346394
347−instance Binary PkgOutline where
348− put (PkgOutline a b c d e f g h) =
349− put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
350395
351− get =
352− do a <- get
353− b <- get
354− c <- get
355− d <- get
356− e <- get
357− f <- get
358− g <- get
359− h <- get
360− return (PkgOutline a b c d e f g h)
361−
362−
363−instance Binary Exposed where
364− put exposed =
365− case exposed of
366− ExposedList a -> putWord8 0 >> put a
367− ExposedDict a -> putWord8 1 >> put a
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
368401
369402 get =
370403 do n <- getWord8
371404 case n of
372− 0 -> liftM ExposedList get
373− 1 -> liftM ExposedDict get
374− _ -> error "binary encoding of ProjectDeps was corrupted"
405+ 0 -> liftM AbsoluteSrcDir get
406+ 1 -> liftM RelativeSrcDir get
407+ _ -> fail "binary encoding of SrcDir was corrupted"
builder/src/Elm/Publish.hsdeleted−255
@@ -1,255 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Elm.Publish (publish) where
3−
4−
5−import Control.Monad (when)
6−import Control.Monad.Except (catchError, runExceptT)
7−import Control.Monad.Trans (liftIO, lift)
8−import qualified Data.List as List
9−import qualified Data.Utf8 as Utf8
10−import qualified System.Directory as Dir
11−import qualified System.Exit as Exit
12−import System.FilePath ((</>))
13−import qualified System.IO as IO
14−import qualified System.Process as Process
15−
16−import qualified Deps.Cache as Cache
17−import qualified Deps.Diff as Diff
18−import qualified Deps.Website as Website
19−import qualified Elm.Bump as Bump
20−import qualified Elm.Docs as Docs
21−import qualified Elm.Package as Pkg
22−import qualified Elm.Project.Json as Project
23−import qualified Elm.Project.Summary as Summary
24−import qualified Elm.Version as V
25−import qualified Reporting.Exit as Exit
26−import qualified Reporting.Exit.Publish as E
27−import qualified Reporting.Progress as Progress
28−import qualified Reporting.Task as Task
29−import qualified Stuff.Paths as Path
30−
31−
32−
33−-- PUBLISH
34−
35−
36−publish :: Summary.Summary -> Task.Task ()
37−publish summary@(Summary.Summary root project _ _ _) =
38− case project of
39− Project.App _ ->
40− throw E.Application
41−
42− Project.Pkg (Project.PkgInfo name smry _ version exposed _ _ _) ->
43− do
44− registry <- Cache.mandatoryUpdate
45− let maybePublishedVersions = either (const Nothing) Just (Cache.getVersions name registry)
46−
47− Task.report (Progress.PublishStart name version maybePublishedVersions)
48−
49− when (noExposed exposed) $ throw E.NoExposed
50− when (badSummary smry) $ throw E.NoSummary
51−
52− verifyReadme root
53− verifyLicense root
54− docs <- Task.silently (error "TODO Project.generateDocs summary" summary)
55− verifyVersion name version docs maybePublishedVersions
56− commitHash <- verifyTag name version
57− verifyNoChanges commitHash version
58− zipHash <- verifyZip name version
59−
60− Website.register name version commitHash zipHash
61−
62− Task.report Progress.PublishEnd
63−
64−
65−throw :: E.Exit -> Task.Task a
66−throw exit =
67− Task.throw (Exit.Publish exit)
68−
69−
70−
71−-- VERIFY SUMMARY
72−
73−
74−badSummary :: Utf8.String -> Bool
75−badSummary summary =
76− Utf8.isEmpty summary || Project.defaultSummary == summary
77−
78−
79−noExposed :: Project.Exposed -> Bool
80−noExposed exposed =
81− case exposed of
82− Project.ExposedList modules ->
83− null modules
84−
85− Project.ExposedDict chunks ->
86− all (null . snd) chunks
87−
88−
89−
90−-- VERIFY README
91−
92−
93−verifyReadme :: FilePath -> Task.Task ()
94−verifyReadme root =
95− phase Progress.CheckReadme $
96− do let readmePath = root </> "README.md"
97− exists <- liftIO $ Dir.doesFileExist readmePath
98− case exists of
99− False ->
100− throw E.NoReadme
101−
102− True ->
103− do size <- liftIO $ IO.withFile readmePath IO.ReadMode IO.hFileSize
104− if size < 300
105− then throw E.ShortReadme
106− else return ()
107−
108−
109−
110−-- VERIFY LICENSE
111−
112−
113−verifyLicense :: FilePath -> Task.Task ()
114−verifyLicense root =
115− phase Progress.CheckLicense $
116− do let licensePath = root </> "LICENSE"
117− exists <- liftIO $ Dir.doesFileExist licensePath
118− if exists
119− then return ()
120− else throw E.NoLicense
121−
122−
123−
124−-- VERIFY GITHUB TAG
125−
126−
127−verifyTag :: Pkg.Name -> V.Version -> Task.Task String
128−verifyTag name version =
129− phase (Progress.CheckTag version) $
130− Website.githubCommit name version `catchError` \_ ->
131− throw (E.MissingTag version)
132−
133−
134−
135−-- VERIFY NO LOCAL CHANGES SINCE TAG
136−
137−
138−verifyNoChanges :: String -> V.Version -> Task.Task ()
139−verifyNoChanges commitHash version =
140− phase Progress.CheckChanges $
141− do maybeGit <- liftIO $ Dir.findExecutable "git"
142− case maybeGit of
143− Nothing ->
144− throw E.NoGit
145−
146− Just git ->
147− do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
148− exitCode <- liftIO $
149− Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]
150−
151− case exitCode of
152− Exit.ExitSuccess ->
153− return ()
154−
155− Exit.ExitFailure _ ->
156− throw (E.LocalChanges version)
157−
158−
159−
160−-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
161−
162−
163−verifyZip :: Pkg.Name -> V.Version -> Task.Task Website.Sha
164−verifyZip name version =
165− withTempDir $ \dir ->
166− do hash <- phase Progress.CheckDownload $
167− Website.githubDownload name version dir
168−
169− phase Progress.CheckBuild $
170− do runner <- Task.getSilentRunner
171− result <- liftIO $ Dir.withCurrentDirectory dir $ runner $
172− Task.silently $ error "TODO Project.generateDocs =<< Project.getRoot"
173− either Task.throw (\_ -> return ()) result
174−
175− return hash
176−
177−
178−withTempDir :: (FilePath -> Task.Task a) -> Task.Task a
179−withTempDir callback =
180− do liftIO $ Dir.createDirectoryIfMissing True Path.prepublishDir
181− result <- lift $ runExceptT $ callback Path.prepublishDir
182− liftIO $ Dir.removeDirectoryRecursive Path.prepublishDir
183− either Task.throw return result
184−
185−
186−
187−-- PHASE REPORTING
188−
189−
190−phase :: Progress.PublishPhase -> Task.Task a -> Task.Task a
191−phase publishPhase task =
192− do Task.report $ Progress.PublishProgress publishPhase Nothing
193−
194− result <- task `catchError` \exit ->
195− do Task.report $ Progress.PublishProgress publishPhase (Just Progress.Bad)
196− Task.throw exit
197−
198− Task.report $ Progress.PublishProgress publishPhase (Just Progress.Good)
199−
200− return result
201−
202−
203−
204−-- VERIFY VERSION
205−
206−
207−verifyVersion :: Pkg.Name -> V.Version -> Docs.Documentation -> Maybe [V.Version] -> Task.Task ()
208−verifyVersion name version docs maybePublishedVersions =
209− let
210− reportBumpPhase bumpPhase =
211− Task.report $ Progress.PublishCheckBump version bumpPhase
212− in
213− do reportBumpPhase Progress.StatedVersion
214− case maybePublishedVersions of
215− Nothing ->
216− if version == V.one then
217− reportBumpPhase Progress.GoodStart
218− else
219− throw (E.NotInitialVersion version)
220−
221− Just publishedVersions ->
222− if elem version publishedVersions then
223− throw $ E.AlreadyPublished version
224− else
225− do (old, magnitude) <- verifyBump name version docs publishedVersions
226− reportBumpPhase (Progress.GoodBump old magnitude)
227−
228− `catchError` \exit ->
229− do reportBumpPhase Progress.BadBump
230− Task.throw exit
231−
232−
233−verifyBump :: Pkg.Name -> V.Version -> Docs.Documentation -> [V.Version] -> Task.Task (V.Version, Diff.Magnitude)
234−verifyBump name statedVersion newDocs publishedVersions =
235− let
236− possibleBumps =
237− Bump.toPossibleBumps publishedVersions
238−
239− isTheBump (_ ,new, _) =
240− statedVersion == new
241− in
242− case List.find isTheBump possibleBumps of
243− Nothing ->
244− throw $ E.InvalidBump statedVersion (last publishedVersions)
245−
246− Just (old, new, magnitude) ->
247− do oldDocs <- Cache.getDocs name old
248− let changes = Diff.diff oldDocs newDocs
249− let realNew = Diff.bump changes old
250− if new == realNew
251− then
252− return (old, magnitude)
253− else
254− throw $ E.BadBump old new magnitude realNew $
255− Diff.toMagnitude changes
builder/src/File.hs+28−5
@@ -1,6 +1,7 @@
11module File
22 ( Time
33 , getTime
4+ , zeroTime
45 , writeBinary
56 , readBinary
67 , writeUtf8
@@ -23,6 +24,7 @@ import qualified Data.ByteString.Builder as B
2324import qualified Data.ByteString.Lazy as LBS
2425import qualified Data.Fixed as Fixed
2526import qualified Data.List as List
27+import qualified Data.Time.Clock as Time
2628import qualified Data.Time.Clock.POSIX as Time
2729import qualified Foreign.ForeignPtr as FPtr
2830import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
@@ -44,11 +46,15 @@ newtype Time = Time Fixed.Pico
4446getTime :: FilePath -> IO Time
4547getTime path =
4648 fmap
47− (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
48−-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
49+ (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
4950 (Dir.getModificationTime path)
5051
5152
53+zeroTime :: Time
54+zeroTime =
55+ Time 0
56+
57+
5258instance Binary.Binary Time where
5359 put (Time time) = Binary.put time
5460 get = Time <$> Binary.get
@@ -72,8 +78,21 @@ readBinary path =
7278 then
7379 do result <- Binary.decodeFileOrFail path
7480 case result of
75− Right a -> return (Just a)
76− Left e -> return Nothing
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
7796 else
7897 return Nothing
7998
@@ -171,7 +190,11 @@ writeEntry destination root entry =
171190 let
172191 path = drop root (Zip.eRelativePath entry)
173192 in
174− if List.isPrefixOf "src/" path then
193+ if List.isPrefixOf "src/" path
194+ || path == "LICENSE"
195+ || path == "README.md"
196+ || path == "elm.json"
197+ then
175198 if not (null path) && last path == '/'
176199 then Dir.createDirectoryIfMissing True (destination </> path)
177200 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
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.hs+14−1
@@ -16,6 +16,7 @@ module Http
1616 -- upload
1717 , upload
1818 , filePart
19+ , jsonPart
1920 , stringPart
2021 )
2122 where
@@ -26,6 +27,7 @@ import qualified Codec.Archive.Zip as Zip
2627import Control.Exception (SomeException, handle)
2728import qualified Data.Binary as Binary
2829import qualified Data.Binary.Get as Binary
30+import qualified Data.ByteString.Builder as B
2931import qualified Data.ByteString.Char8 as BS
3032import qualified Data.Digest.Pure.SHA as SHA
3133import qualified Data.String as String
@@ -34,8 +36,10 @@ import Network.HTTP.Client
3436import Network.HTTP.Client.TLS (tlsManagerSettings)
3537import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
3638import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39+import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
3740import qualified Network.HTTP.Client.MultipartFormData as Multi
3841
42+import qualified Json.Encode as Encode
3943import qualified Elm.Version as V
4044
4145
@@ -226,6 +230,15 @@ filePart name filePath =
226230 Multi.partFileSource (String.fromString name) filePath
227231
228232
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+
229242stringPart :: String -> String -> Multi.Part
230243stringPart name string =
231− Multi.partBS (String.fromString name) (BS.pack string)
244+ Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hs+43−22
@@ -1,6 +1,7 @@
11{-# LANGUAGE BangPatterns, OverloadedStrings #-}
22module Reporting
33 ( Style
4+ , silent
45 , json
56 , terminal
67 --
@@ -32,7 +33,7 @@ import qualified Data.ByteString.Builder as B
3233import qualified Data.NonEmptyList as NE
3334import qualified System.Exit as Exit
3435import qualified System.Info as Info
35−import System.IO (hFlush, hPutStr, stderr, stdout)
36+import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
3637
3738import qualified Elm.ModuleName as ModuleName
3839import qualified Elm.Package as Pkg
@@ -49,10 +50,16 @@ import qualified Reporting.Exit.Help as Help
4950
5051
5152data Style
52− = Json
53+ = Silent
54+ | Json
5355 | Terminal (MVar ())
5456
5557
58+silent :: Style
59+silent =
60+ Silent
61+
62+
5663json :: Style
5764json =
5865 Json
@@ -71,7 +78,9 @@ attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
7178attempt toReport work =
7279 do result <- work `catch` reportExceptionsNicely
7380 case result of
74− Right a -> return a
81+ Right a ->
82+ return a
83+
7584 Left x ->
7685 do Exit.toStderr (toReport x)
7786 Exit.exitFailure
@@ -81,9 +90,14 @@ attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
8190attemptWithStyle style toReport work =
8291 do result <- work `catch` reportExceptionsNicely
8392 case result of
84− Right a -> return a
93+ Right a ->
94+ return a
95+
8596 Left x ->
8697 case style of
98+ Silent ->
99+ do Exit.exitFailure
100+
87101 Json ->
88102 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
89103 Exit.exitFailure
@@ -108,11 +122,6 @@ badMark =
108122 D.red $ if isWindows then "X" else "✗"
109123
110124
111−_waitingMark :: D.Doc
112−_waitingMark =
113− D.dullyellow $ if isWindows then "-" else "→"
114−
115−
116125isWindows :: Bool
117126isWindows =
118127 Info.os == "mingw32"
@@ -168,6 +177,9 @@ type DKey = Key DMsg
168177trackDetails :: Style -> (DKey -> IO a) -> IO a
169178trackDetails style callback =
170179 case style of
180+ Silent ->
181+ callback (Key (\_ -> return ()))
182+
171183 Json ->
172184 callback (Key (\_ -> return ()))
173185
@@ -252,8 +264,8 @@ putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
252264putDownload mark pkg vsn =
253265 Help.toStdout $ D.indent 2 $
254266 mark
255− <+> D.fromUtf8 (Pkg.toString pkg)
256− <+> D.fromUtf8 (V.toString vsn)
267+ <+> D.fromPackage pkg
268+ <+> D.fromVersion vsn
257269 <> "\n"
258270
259271
@@ -297,6 +309,9 @@ type BResult a = Either Exit.BuildProblem a
297309trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
298310trackBuild style callback =
299311 case style of
312+ Silent ->
313+ callback (Key (\_ -> return ()))
314+
300315 Json ->
301316 callback (Key (\_ -> return ()))
302317
@@ -349,10 +364,10 @@ toFinalMessage done result =
349364
350365 Left problem ->
351366 case problem of
352− Exit.BuildModuleProblems _ [] ->
367+ Exit.BuildBadModules _ _ [] ->
353368 "Detected problems in 1 module."
354369
355− Exit.BuildModuleProblems _ (_:ps) ->
370+ Exit.BuildBadModules _ _ (_:ps) ->
356371 "Detected problems in " ++ show (2 + length ps) ++ " modules."
357372
358373 Exit.BuildProjectProblem _ ->
@@ -366,6 +381,9 @@ toFinalMessage done result =
366381reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
367382reportGenerate style names output =
368383 case style of
384+ Silent ->
385+ return ()
386+
369387 Json ->
370388 return ()
371389
@@ -428,20 +446,23 @@ reportExceptionsNicely e =
428446
429447
430448putException :: SomeException -> IO ()
431−putException e =
449+putException e = do
450+ hPutStrLn stderr ""
432451 Help.toStderr $ D.stack $
433− [ D.reflow $
434− "Oh no! I ran into something that bypassed the normal error reporting process!\
452+ [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
453+ , D.reflow $
454+ "I ran into something that bypassed the normal error reporting process!\
435455 \ I extracted whatever information I could from the internal error:"
436456 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
437457 , D.reflow $
438− "These errors are usually pretty confusing, so start by asking around on Slack\
439− \ or Discourse to see if anyone can get you unstuck quickly."
440− , "------------------------------------------------------------"
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 ---------------------------------------------------------------------"
441462 , D.reflow $
442− "From there, if you are feeling up to it, please try to get your code down to the\
443− \ smallest version that still triggers this message. Ideally in a single Main.elm\
444− \ and elm.json file."
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."
445466 , D.reflow $
446467 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
447468 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
builder/src/Reporting/Exit.hs+1624−365
@@ -1,31 +1,27 @@
11{-# LANGUAGE OverloadedStrings #-}
22module Reporting.Exit
3− ( Exit(..)
4− --
5− , Init(..)
6− , initToReport
7− --
8− , Diff(..)
9− , diffToReport
10− --
11− , Install(..)
12− , installToReport
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
1312 --
1413 , Solver(..)
15− --
1614 , Outline(..)
1715 , OutlineProblem(..)
18− --
1916 , Details(..)
20− , RegistryProblem(..)
17+ , DetailsBadDep(..)
2118 , PackageProblem(..)
22− --
23− , Make(..)
19+ , RegistryProblem(..)
2420 , BuildProblem(..)
2521 , BuildProjectProblem(..)
26− , makeToReport
27− --
2822 , DocsProblem(..)
23+ , Generate(..)
24+ --
2925 , toString
3026 , toStderr
3127 , toJson
@@ -33,59 +29,56 @@ module Reporting.Exit
3329 where
3430
3531
32+import qualified Data.ByteString as BS
33+import qualified Data.ByteString.UTF8 as BS_UTF8
3634import qualified Data.List as List
37−import qualified Data.Utf8 as Utf8
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 ((</>), (<.>))
3843
3944import qualified Elm.Constraint as C
4045import qualified Elm.Magnitude as M
4146import qualified Elm.ModuleName as ModuleName
4247import qualified Elm.Package as Pkg
4348import qualified Elm.Version as V
49+import qualified File
4450import qualified Http
51+import qualified Json.Decode as Decode
4552import 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
4656import Reporting.Doc ((<>))
4757import qualified Reporting.Doc as D
58+import qualified Reporting.Error.Import as Import
4859import qualified Reporting.Error.Json as Json
4960import qualified Reporting.Exit.Help as Help
5061import qualified Reporting.Error as Error
62+import qualified Reporting.Render.Code as Code
5163
5264
5365
54−-- ALL POSSIBLE ERRORS
66+-- RENDERERS
5567
5668
57−data Exit
58− -- bump
59− = BumpApplication
60− | BumpUnexpectedVersion V.Version [V.Version]
61− | BumpMustHaveLatestRegistry RegistryProblem
62− | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
63− -- publish
64− | PublishMustHaveLatestRegistry RegistryProblem
65− | PublishApplication
66− | PublishNotInitialVersion V.Version
67− | PublishAlreadyPublished V.Version
68− | PublishInvalidBump V.Version V.Version
69− | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
70− | PublishNoSummary
71− | PublishNoExposed
72− | PublishNoReadme
73− | PublishShortReadme
74− | PublishNoLicense
75− | PublishCannotGetTag Http.Error
76− | PublishCannotGetZip Http.Error
77− | PublishCannotDecodeZip
78− | PublishCannotGetDocs DocsProblem
79− | PublishCannotRegister Http.Error
80− | PublishMissingTag V.Version
81− | PublishNoGit
82− | PublishLocalChanges V.Version
69+toString :: Help.Report -> String
70+toString report =
71+ Help.toString (Help.reportToDoc report)
8372
8473
85−data DocsProblem
86− = DP_Http Http.Error
87− | DP_Data
88− | DP_Cache
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
8982
9083
9184
@@ -116,13 +109,18 @@ initToReport exit =
116109
117110 InitNoOfflineSolution pkgs ->
118111 Help.report "NO OFFLINE SOLUTION" Nothing
119− (error "TODO InitNoOfflineSolution" pkgs)
120− (error "TODO InitNoOfflineSolution" pkgs)
121− -- note about Russia IP addresses?
122− -- ask if they are on a plane or train
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+ ]
123121
124122 InitSolverProblem solver ->
125− error "TODO InitSolverProblem" solver
123+ toSolverReport solver
126124
127125 InitAlreadyExists ->
128126 Help.report "EXISTING PROJECT" Nothing
@@ -133,8 +131,9 @@ initToReport exit =
133131 ]
134132 ]
135133
136− InitRegistryProblem _ ->
137− error "TODO InitRegistryProblem"
134+ InitRegistryProblem problem ->
135+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
136+ "I need the list of published packages before I can start initializing projects"
138137
139138
140139
@@ -142,22 +141,48 @@ initToReport exit =
142141
143142
144143data Diff
145− = DiffApplication
144+ = DiffNoOutline
145+ | DiffBadOutline Outline
146+ | DiffApplication
147+ | DiffNoExposed
146148 | DiffUnpublished
147149 | DiffUnknownPackage Pkg.Name [Pkg.Name]
148150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
149− | DiffCannotFindDocs DocsProblem
151+ | DiffDocsProblem V.Version DocsProblem
150152 | DiffMustHaveLatestRegistry RegistryProblem
153+ | DiffBadDetails Details
154+ | DiffBadBuild BuildProblem
151155
152156
153157diffToReport :: Diff -> Help.Report
154158diffToReport diff =
155159 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+
156171 DiffApplication ->
157− Help.report "CANNOT DIFF APPLICATIONS" Nothing
158− "I cannot perform diffs on applications, only packages! If you are\
159− \ just curious to see a diff, try running this command:"
160− [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"
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."
161186 ]
162187
163188 DiffUnpublished ->
@@ -169,16 +194,16 @@ diffToReport diff =
169194 Help.report "UNKNOWN PACKAGE" Nothing
170195 ( "I cannot find a package called:"
171196 )
172− [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg
197+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
173198 , "Maybe you want one of these instead?"
174− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
199+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
175200 , "But check <https://package.elm-lang.org> to see all possibilities!"
176201 ]
177202
178203 DiffUnknownVersion _pkg vsn realVersions ->
179204 Help.docReport "UNKNOWN VERSION" Nothing
180205 ( D.fillSep $
181− [ "Version", D.red (D.fromUtf8 (V.toString vsn))
206+ [ "Version", D.red (D.fromVersion vsn)
182207 , "has", "never", "been", "published,", "so", "I"
183208 , "cannot", "diff", "against", "it."
184209 ]
@@ -187,230 +212,57 @@ diffToReport diff =
187212 , D.indent 4 $ D.dullyellow $ D.vcat $
188213 let
189214 sameMajor v1 v2 = V._major v1 == V._major v2
190− mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns
215+ mkRow vsns = D.hsep $ map D.fromVersion vsns
191216 in
192217 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
193218 , "Want one of those instead?"
194219 ]
195220
196− DiffCannotFindDocs problem ->
197− error "TODO DiffCannotFindDocs" problem
221+ DiffDocsProblem version problem ->
222+ toDocsProblemReport problem $
223+ "I need the docs for " ++ V.toChars version ++ " to compute this diff"
198224
199225 DiffMustHaveLatestRegistry problem ->
200− error "TODO DiffMustHaveLatestRegistry" problem
226+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
227+ "I need the latest list of published packages before I do this diff"
201228
229+ DiffBadDetails details ->
230+ toDetailsReport details
202231
232+ DiffBadBuild buildProblem ->
233+ toBuildProblemReport buildProblem
203234
204−-- INSTALL
205235
206236
207−data Install
208− = InstallNoProject
209− | InstallNoArgs FilePath
210− | InstallNoOnlineSolution
211− | InstallNoOfflineSolution
212− | InstallHadSolverTrouble Solver
213− | InstallUnknownPackageOnline [Pkg.Name]
214− | InstallUnknownPackageOffline [Pkg.Name]
215− | InstallHasBadDetails Details
237+-- BUMP
216238
217239
218−installToReport :: Install -> Help.Report
219−installToReport exit =
220− case exit of
221− InstallNoProject ->
222− Help.report "NEW PROJECT?" Nothing
223− "Are you trying to start a new project? Try this command instead:"
224− [ D.indent 4 $ D.green "elm init"
225− , D.reflow "It will help you get started!"
226− ]
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
227250
228− InstallNoArgs elmHome ->
229− Help.report "INSTALL WHAT?" Nothing
230− "I am expecting commands like:"
231− [ D.green $ D.indent 4 $ D.vcat $
232− [ "elm install elm/http"
233− , "elm install elm/json"
234− , "elm install elm/random"
235− ]
236− , D.toFancyHint
237− ["In","JavaScript","folks","run","`npm install`","to","start","projects."
238− ,"\"Gotta","download","everything!\"","But","why","download","packages"
239− ,"again","and","again?","Instead,","Elm","caches","packages","in"
240− ,D.dullyellow (D.fromChars elmHome)
241− ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
242− ,"Elm","projects","check","that","cache","before","trying","the","internet."
243− ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
244− ,"easier","to","work","offline.","As","a","result"
245− ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
246− ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
247− ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
248− ]
249− ]
250251
251− InstallNoOnlineSolution ->
252− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO recommend using solver in `elm reactor`
253− "This usually happens if you try to modify dependency constraints by\
254− \ hand. I recommend deleting any dependency you added recently (or all\
255− \ of them if things are bad) and then adding them again with:"
256− [ D.indent 4 $ D.green "elm install"
257− , D.reflow $
258− "And do not be afaid to ask for help on Slack if you get stuck!"
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."
259262 ]
260263
261− InstallNoOfflineSolution ->
262− error "TODO InstallNoOfflineSolution"
263−
264− InstallHadSolverTrouble solver ->
265− error "TODO InstallHadSolverTrouble" solver
266−
267− InstallUnknownPackageOnline suggestions ->
268− error "TODO InstallUnknownPackageOnline" suggestions
269−
270− InstallUnknownPackageOffline suggestions ->
271− error "TODO InstallUnknownPackageOffline" suggestions
272−
273− InstallHasBadDetails _ ->
274− error "TODO InstallHasBadDetails"
275−
276−
277−{- TODO detect if library has no 0.19.0 version. Maybe do this on website though?
278− Help.report "OLD DEPENDENCIES" (Just "elm.json")
279− ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
280− )
281− [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
282− , D.reflow $
283− "This may be because it is not upgraded yet. It may be because a\
284− \ better solution came along, so there was no need to upgrade it.\
285− \ Etc. Try asking around on Slack to learn more about the topic."
286− , D.toSimpleNote
287− "Whatever the case, please be kind to the relevant package authors! Having\
288− \ friendly interactions with users is great motivation, and conversely, getting\
289− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
290− \ authors are humans with families, friends, jobs, vacations, responsibilities,\
291− \ goals, etc. They face obstacles outside of their technical work you will never\
292− \ know about, so please assume the best and try to be patient and supportive!"
293− ]
294−-}
295−
296−
297−
298−-- SOLVER
299−
300−
301−data Solver
302− = SolverBadCacheData Pkg.Name V.Version
303− | SolverBadHttpData Pkg.Name V.Version
304− | SolverBadHttp Http.Error
305−
306−
307−
308−-- OUTLINE
309−
310−
311−data Outline
312− = OutlineHasBadStructure (Json.Error OutlineProblem)
313− | OutlineHasBadSrcDirs FilePath [FilePath]
314−
315−
316−data OutlineProblem
317− = OP_BadType Utf8.String
318− | OP_BadPkgName Pkg.BadName
319− | OP_BadVersion Utf8.String
320− | OP_BadConstraint C.Error
321− | OP_BadModuleName Utf8.String
322− | OP_BadModuleHeaderTooLong Utf8.String
323− | OP_BadDependencyName Utf8.String
324− | OP_BadLicense Utf8.String [Utf8.String]
325− | OP_BadSummaryTooLong
326−
327−
328−
329−-- DETAILS
330−
331−
332−data Details
333− = DetailsCorrupt
334− | DetailsNoSolution
335− | DetailsNoOfflineSolution
336− | DetailsSolverProblem Solver
337− | DetailsBadElmInPkg C.Constraint
338− | DetailsBadElmInAppOutline V.Version
339− | DetailsHandEditedDependencies
340− | DetailsBadOutline Outline
341− | DetailsCannotGetRegistry RegistryProblem
342− | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem
343−
344−
345−data RegistryProblem
346− = RP_Http Http.Error
347− | RP_Data
348−
349−
350−data PackageProblem
351− = PP_BadEndpointRequest Http.Error
352− | PP_BadEndpointContent
353− | PP_BadArchiveRequest Http.Error
354− | PP_BadArchiveContent
355− | PP_BadArchiveHash String String
356−
357−
358−
359−-- MAKE
360−
361−
362−data Make
363− = MakeNeedsOutline
364− | MakeCannotOptimizeAndDebug
365− | MakeBlockedByDetailsProblem Details
366− | MakeAppNeedsFileNames
367− | MakePkgNeedsExposing
368− | MakeMultipleFilesIntoHtml
369− | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
370− | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
371− | MakeCannotBuild BuildProblem
372− | MakeCannotLoadArtifacts
373−
374−
375−data BuildProblem
376− = BuildModuleProblems Error.Module [Error.Module]
377− | BuildProjectProblem BuildProjectProblem
378−
379−
380−data BuildProjectProblem
381− = BP_PathUnknown FilePath
382− | BP_WithBadExtension FilePath
383− | BP_WithAmbiguousSrcDir FilePath FilePath
384− | BP_MainPathDuplicate FilePath FilePath
385− | BP_MainNameDuplicate ModuleName.Raw FilePath FilePath
386− | BP_CannotLoadDependencies
387− | BP_Cycle ModuleName.Raw [ModuleName.Raw]
388−
389−
390−
391−-- RENDERERS
392−
393−
394−toString :: Help.Report -> String
395−toString report =
396− Help.toString (Help.reportToDoc report)
397−
398−
399−toStderr :: Help.Report -> IO ()
400−toStderr report =
401− Help.toStderr (Help.reportToDoc report)
402−
403−
404−toJson :: Help.Report -> Encode.Value
405−toJson report =
406− Help.reportToJson report
407−
408−
409−_toReport :: Exit -> Help.Report
410−_toReport exit =
411− case exit of
412−
413− -- bump
264+ BumpBadOutline outline ->
265+ toOutlineReport outline
414266
415267 BumpApplication ->
416268 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
@@ -422,7 +274,7 @@ _toReport exit =
422274 Help.docReport "CANNOT BUMP" (Just "elm.json")
423275 ( D.fillSep
424276 ["Your","elm.json","says","I","should","bump","relative","to","version"
425− ,D.red (D.fromUtf8 (V.toString vsn)) <> ","
277+ ,D.red (D.fromVersion vsn) <> ","
426278 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
427279 ,"That","means","there","is","no","API","for","me","to","diff","against","and"
428280 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
@@ -431,19 +283,116 @@ _toReport exit =
431283 [ D.fillSep $
432284 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
433285 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
434− , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions
286+ , D.vcat $ map (D.green . D.fromVersion) versions
435287 ]
436288
437289 BumpMustHaveLatestRegistry problem ->
438− error "TODO 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+ ]
439386
440− BumpCannotFindDocs name version problem ->
441− error "TODO BumpCannotFindDocs" name version problem
387+ PublishBadOutline outline ->
388+ toOutlineReport outline
442389
443− -- publish
390+ PublishBadDetails problem ->
391+ toDetailsReport problem
444392
445393 PublishMustHaveLatestRegistry problem ->
446− error "TODO 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"
447396
448397 PublishApplication ->
449398 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
@@ -452,7 +401,7 @@ _toReport exit =
452401 Help.docReport "INVALID VERSION" Nothing
453402 ( D.fillSep
454403 ["I","cannot","publish"
455− ,D.red (D.fromUtf8 (V.toString vsn))
404+ ,D.red (D.fromVersion vsn)
456405 ,"as","the","initial","version."
457406 ]
458407 )
@@ -466,7 +415,7 @@ _toReport exit =
466415 Help.docReport "ALREADY PUBLISHED" Nothing
467416 ( D.vcat
468417 [ D.fillSep
469− [ "Version", D.green (D.fromUtf8 (V.toString vsn))
418+ [ "Version", D.green (D.fromVersion vsn)
470419 , "has", "already", "been", "published.", "You", "cannot"
471420 , "publish", "it", "again!"
472421 ]
@@ -483,14 +432,14 @@ _toReport exit =
483432 Help.docReport "INVALID VERSION" (Just "elm.json")
484433 ( D.fillSep $
485434 ["Your","elm.json","says","the","next","version","should","be"
486− ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","
435+ ,D.red (D.fromVersion statedVersion) <> ","
487436 ,"but","that","is","not","valid","based","on","the","previously"
488437 ,"published","versions."
489438 ]
490439 )
491440 [ D.fillSep $
492441 ["Change","the","version","back","to"
493− ,D.green (D.fromUtf8 (V.toString latestVersion))
442+ ,D.green (D.fromVersion latestVersion)
494443 ,"which","is","the","most","recently","published","version."
495444 ,"From","there,","have","Elm","bump","the","version","by","running:"
496445 ]
@@ -505,7 +454,7 @@ _toReport exit =
505454 (
506455 D.fillSep $
507456 ["Your","elm.json","says","the","next","version","should","be"
508− ,D.red (D.fromUtf8 (V.toString new)) <> ","
457+ ,D.red (D.fromVersion new) <> ","
509458 ,"indicating","a",D.fromChars (M.toChars magnitude)
510459 ,"change","to","the","public","API."
511460 ,"This","does","not","match","the","API","diff","given","by:"
@@ -518,7 +467,7 @@ _toReport exit =
518467 ["This","command","says","this","is","a"
519468 ,D.fromChars (M.toChars realMagnitude)
520469 ,"change,","so","the","next","version","should","be"
521− ,D.green (D.fromUtf8 (V.toString realNew)) <> "."
470+ ,D.green (D.fromVersion realNew) <> "."
522471 ,"Double","check","everything","to","make","sure","you"
523472 ,"are","publishing","what","you","want!"
524473 ]
@@ -548,16 +497,17 @@ _toReport exit =
548497 ]
549498 )
550499 [ D.reflow $
551− "What is the point of a package that has no modules?!"
500+ "Which modules do you want users of the package to have access to? Add their\
501+ \ names to the \"exposed-modules\" list."
552502 ]
553503
554504 PublishNoReadme ->
555− badReadmeReport "NO README" $
505+ toBadReadmeReport "NO README" $
556506 "Every published package must have a helpful README.md\
557507 \ file, but I do not see one in your project."
558508
559509 PublishShortReadme ->
560− badReadmeReport "SHORT README" $
510+ toBadReadmeReport "SHORT README" $
561511 "This README.md is too short. Having more details will help\
562512 \ people assess your package quickly and fairly."
563513
@@ -574,20 +524,8 @@ _toReport exit =
574524 \ named LICENSE. Add that file and you will be all set!"
575525 ]
576526
577− PublishCannotGetTag httpError ->
578− error "TODO PublishCannotGetTag" httpError
579−
580− PublishCannotGetZip httpError ->
581− error "TODO PublishCannotGetZip" httpError
582−
583− PublishCannotDecodeZip ->
584− error "TODO PublishCannotDecodeZip"
585−
586− PublishCannotGetDocs docsProblem ->
587− error "TODO PublishCannotGetDocs" docsProblem
588−
589− PublishCannotRegister httpError ->
590− error "TODO PublishCannotRegister" httpError
527+ PublishBuildProblem buildProblem ->
528+ toBuildProblemReport buildProblem
591529
592530 PublishMissingTag version ->
593531 let vsn = V.toChars version in
@@ -608,6 +546,70 @@ _toReport exit =
608546 , "The -m flag is for a helpful message. Try to make it more informative!"
609547 ]
610548
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+
611613 PublishNoGit ->
612614 Help.report "NO GIT" Nothing
613615 "I searched your PATH environment variable for `git` and could not\
@@ -637,9 +639,21 @@ _toReport exit =
637639 ++ vsn ++ "` and publish your code from there."
638640 ]
639641
642+ PublishZipBadDetails _ ->
643+ badZipReport
640644
641−badReadmeReport :: String -> String -> Help.Report
642−badReadmeReport title summary =
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 =
643657 Help.report title (Just "README.md") summary
644658 [ D.reflow $
645659 "When people look at your README, they are wondering:"
@@ -652,32 +666,653 @@ badReadmeReport title summary =
652666 \ most common usage scenario. Show people what they can expect if\
653667 \ they learn more!"
654668 , D.toSimpleNote $
655− "By publishing your package, you are inviting people to invest time\
656− \ in understanding your work. Spending an hour to communicate your\
657− \ knowledge more clearly can save the community days or weeks of time\
658− \ in aggregate, and saving time in aggregate is the whole point of\
659− \ publishing packages! People really appreciate it, and it makes the\
660− \ whole ecosystem feel nicer!"
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?"
661687 ]
662688
663689
664690
665−-- DETAILS TO REPORT
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+ ]
666762
763+ InstallBadOutline outline ->
764+ toOutlineReport outline
667765
668−detailsToReport :: Details -> Help.Report
669−detailsToReport details =
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 =
6701279 case details of
671− DetailsCorrupt ->
672− error "TODO DetailsCorrupt"
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
6731308
6741309 DetailsBadElmInPkg constraint ->
6751310 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
6761311 "Your elm.json says this package needs a version of Elm in this range:"
677− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ C.toString constraint
1312+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
6781313 , D.fillSep
6791314 [ "But", "you", "are", "using", "Elm"
680− , D.red (D.fromUtf8 (V.toString V.compiler))
1315+ , D.red (D.fromVersion V.compiler)
6811316 , "right", "now."
6821317 ]
6831318 ]
@@ -687,40 +1322,286 @@ detailsToReport details =
6871322 "Your elm.json says this application needs a different version of Elm."
6881323 [ D.fillSep
6891324 [ "It", "requires"
690− , D.green (D.fromUtf8 (V.toString version)) <> ","
1325+ , D.green (D.fromVersion version) <> ","
6911326 , "but", "you", "are", "using"
692− , D.red (D.fromUtf8 (V.toString V.compiler))
1327+ , D.red (D.fromVersion V.compiler)
6931328 , "right", "now."
6941329 ]
6951330 ]
6961331
6971332 DetailsHandEditedDependencies ->
698− error "TODO 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+ ]
6991344
700− DetailsBadOutline problem ->
701− error "TODO DetailsBadOutline" problem
1345+ DetailsBadOutline outline ->
1346+ toOutlineReport outline
7021347
7031348 DetailsCannotGetRegistry problem ->
704− error "TODO 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+ ]
7051365
706− DetailsCannotBuildPackage name version problem ->
707− error "TODO DetailsCannotBuildPackage" name version problem
1366+ d:_ ->
1367+ case d of
1368+ BD_BadDownload pkg vsn packageProblem ->
1369+ toPackageProblemReport pkg vsn packageProblem
7081370
709− DetailsNoSolution ->
710− error "TODO DetailsNoSolution"
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+ ]
7111391
712− DetailsNoOfflineSolution ->
713− error "TODO DetailsNoOfflineSolution"
7141392
715− DetailsSolverProblem _ ->
716− error "TODO DetailsSolverProblem"
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
7171438
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
7181599
7191600
7201601makeToReport :: Make -> Help.Report
7211602makeToReport make =
7221603 case make of
723− MakeNeedsOutline ->
1604+ MakeNoOutline ->
7241605 Help.report "NO elm.json FILE" Nothing
7251606 "It looks like you are starting a new Elm project. Very exciting! Try running:"
7261607 [ D.indent 4 $ D.green $ "elm init"
@@ -741,27 +1622,344 @@ makeToReport make =
7411622 \ at once though! Pick just one of those flags and it should work!"
7421623 ]
7431624
744− MakeBlockedByDetailsProblem detailsProblem ->
745− detailsToReport detailsProblem
1625+ MakeBadDetails detailsProblem ->
1626+ toDetailsReport detailsProblem
7461627
7471628 MakeAppNeedsFileNames ->
7481629 Help.report "NO INPUT" Nothing
749− "What should I make though? I need a specific file like this:"
750− [ D.indent 4 $ D.green "elm make src/Main.elm"
751− , D.reflow
752− "However many files you give, I will create one JS file out of them."
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!"
7531638 ]
7541639
7551640 MakePkgNeedsExposing ->
756− error "TODO 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+ ]
7571651
7581652 MakeMultipleFilesIntoHtml ->
759− error "TODO 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+ ]
7601671
761− MakeNonMainFilesIntoJavaScript _ _ ->
762− error "TODO MakeNonMainFilesIntoJavaScript"
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+ ]
7631695
764− MakeCannotOptimizeDebugValues m ms ->
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 ->
7651963 Help.report "DEBUG REMNANTS" Nothing
7661964 "There are uses of the `Debug` module in the following modules:"
7671965 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
@@ -770,7 +1968,7 @@ makeToReport make =
7701968 "The issue is that --optimize strips out info needed by `Debug` functions.\
7711969 \ Here are two examples:"
7721970 , D.indent 4 $ D.reflow $
773− "(1) It shortens record field names. This makes the generated JavaScript is\
1971+ "(1) It shortens record field names. This makes the generated JavaScript\
7741972 \ smaller, but `Debug.toString` cannot know the real field names anymore."
7751973 , D.indent 4 $ D.reflow $
7761974 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
@@ -783,28 +1981,89 @@ makeToReport make =
7831981 \ exists!"
7841982 ]
7851983
786− MakeCannotBuild buildProblem ->
787− case buildProblem of
788− BuildProjectProblem bp ->
789− case bp of
790− BP_PathUnknown _ -> error "TODO BP_PathUnknown"
791− BP_WithBadExtension _ -> error "TODO BP_WithBadExtension"
792− BP_WithAmbiguousSrcDir _ _ -> error "TODO BP_WithAmbiguousSrcDir"
793− BP_MainPathDuplicate _ _ -> error "TODO BP_MainPathDuplicate"
794− BP_MainNameDuplicate _ _ _ -> error "TODO BP_MainNameDuplicate"
795− BP_CannotLoadDependencies -> error "TODO BP_CannotLoadDependencies"
796− BP_Cycle name names ->
797− Help.report "IMPORT CYCLE" Nothing
798− "Your module imports form a cycle:"
799− [ D.cycle 4 name names
800− , D.reflow $
801− "Learn more about why this is disallowed and how to break cycles here:"
802− ++ D.makeLink "import-cycles"
803− ]
8041984
8051985
806− BuildModuleProblems p ps ->
807− Help.compilerReport p ps
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
8082067
809− MakeCannotLoadArtifacts ->
810− error "TODO MakeCannotLoadArtifacts"
2068+ ReplBlocked ->
2069+ corruptCacheReport
builder/src/Reporting/Exit/Assets.hsdeleted−227
@@ -1,227 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Assets
3− ( Exit(..)
4− , ElmJsonProblem(..)
5− , toReport
6− , BadElmJsonContent(..)
7− , badContentToDocs
8− )
9− where
10−
11−
12−import qualified Data.Text as Text
13−
14−import qualified Elm.Package as Pkg
15−import Reporting.Doc ((<>))
16−import qualified Reporting.Doc as D
17−import qualified Reporting.Exit.Help as Help
18−
19−
20−
21−-- EXITS
22−
23−
24−data Exit
25− = BadElmJson ElmJsonProblem
26− | CorruptElmJson Pkg.Name Pkg.Version
27− | CorruptDocumentation Pkg.Name Pkg.Version
28− | CorruptBinary FilePath FilePath
29−
30−
31−
32−-- ELM JSON PROBLEM
33−
34−
35−data ElmJsonProblem
36− = BadJson D.Doc
37− | BadSrcDir FilePath
38− | NoPkgCore
39− | NoAppCore
40− | NoAppJson
41−
42−
43−
44−-- TO REPORT
45−
46−
47−toReport :: Exit -> Help.Report
48−toReport exit =
49− case exit of
50− CorruptElmJson pkg vsn ->
51− corruptJsonToReport "elm.json" pkg vsn
52−
53− CorruptDocumentation pkg vsn ->
54− corruptJsonToReport "docs.json" pkg vsn
55−
56− CorruptBinary elmHome path ->
57− Help.report "CORRUPT BINARY" (Just path)
58− ("The binary data at " ++ path ++ " is corrupt.")
59− [ D.reflow "Elm caches build artifacts in the following directories:"
60− , D.dullyellow $ D.indent 4 $ D.vcat $
61− [ D.fromString elmHome
62− , "elm-stuff/"
63− ]
64− , D.reflow
65− "Maybe you recently installed a command line tool or editor plugin that messes\
66− \ with them? They definitely should not be doing that, but you never know! So\
67− \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
68− \ help reveal the corrupting influence."
69− ]
70−
71− BadElmJson problem ->
72− elmJsonProblemToReport problem
73−
74−
75−
76−-- CORRUPT JSON
77−
78−
79−corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
80−corruptJsonToReport path pkg vsn =
81− Help.report "CORRUPT JSON" Nothing
82− ( "The " ++ path ++ " for " ++ Pkg.toString pkg
83− ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
84− )
85− [ D.reflow $
86− "I removed it from my file cache, so if it was some transient\
87− \ error it should be fixed if you try the same thing again.\
88− \ Please report this if it seems like an Elm problem though!"
89− ]
90−
91−
92−
93−-- BAD ELM JSON
94−
95−
96−elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
97−elmJsonProblemToReport problem =
98− case problem of
99− BadJson doc ->
100− Help.jsonReport "BAD JSON" (Just "elm.json") doc
101−
102− BadSrcDir dir ->
103− Help.report "BAD JSON" (Just "elm.json")
104− "The \"source-directories\" in your elm.json lists the following directory:"
105− [ D.indent 4 (D.dullyellow (D.fromString dir))
106− , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
107− ]
108−
109− NoPkgCore ->
110− Help.report "MISSING DEPENDENCY" (Just "elm.json")
111− "A package must have \"elm/core\" as a dependency. Try running:"
112− [ D.indent 4 $ D.green $ "elm install elm/core"
113− , D.reflow "I need it for the default imports that make `List` and `Maybe` available."
114− ]
115−
116− NoAppCore ->
117− Help.report "MISSING DEPENDENCY" (Just "elm.json")
118− "An application must have \"elm/core\" as a dependency. Try running:"
119− [ D.indent 4 $ D.green $ "elm install elm/core"
120− , D.reflow "It has some supporting code that is needed by every Elm application!"
121− ]
122−
123− NoAppJson ->
124− Help.report "MISSING DEPENDENCY" (Just "elm.json")
125− "An application must have \"elm/json\" as a dependency. Try running:"
126− [ D.indent 4 $ D.green $ "elm install elm/json"
127− , D.reflow "It helps me handle flags and ports."
128− ]
129−
130−
131−
132−-- PROBLEM TO DOCS
133−
134−
135−data BadElmJsonContent
136− = BadType Text.Text
137− | BadPkgName String
138− | BadVersion Text.Text
139− | BadConstraint String
140− | BadModuleName Text.Text
141− | BadModuleHeaderTooLong Text.Text
142− | BadDependencyName Text.Text
143− | BadLicense Text.Text [Text.Text]
144− | BadDirectoryNotString
145− | BadSummaryTooLong
146−
147−
148−badContentToDocs :: BadElmJsonContent -> [D.Doc]
149−badContentToDocs badContent =
150− case badContent of
151− BadType _ ->
152− ["The","only","valid","types","of","elm.json","are"
153− ,D.green "\"application\"","and",D.green "\"package\"" <> "."
154− ]
155−
156− BadPkgName problem ->
157− map D.fromString (words problem)
158−
159− BadVersion txt ->
160− ["You","provided",D.red (D.fromString (show txt))
161− ,"which","is","not","a","valid","version.","I","need","something","like"
162− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
163− ]
164−
165− BadConstraint problem ->
166− map D.fromString (words ("It is not a valid constraint. " ++ problem))
167−
168− BadModuleName name ->
169− ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
170− ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
171− ]
172−
173− BadModuleHeaderTooLong header ->
174− ["The",D.fromString (show header),"header","is","too","long."
175− ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
176− ,"to","ensure","that","formatting","is","nice","on","the","package","website."
177− ]
178−
179− BadDependencyName name ->
180− ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
181− ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
182− ,"the","package","website,","and","installing","it","with","the"
183− ,D.green "`elm install`","command","instead."
184− ]
185−
186− BadLicense _given suggestions ->
187− case suggestions of
188− [] ->
189− ["I","need","an","OSI","approved","SPDX","license,","like"
190− ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
191− ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
192− ]
193−
194− code:codes ->
195− ["I","need","an","OSI","approved","SPDX","license."]
196− ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
197− ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
198−
199− BadDirectoryNotString ->
200− ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
201− ]
202−
203− BadSummaryTooLong ->
204− ["Your","summary","is","too","long.","I","need","it","to"
205− ,"be",D.green "under",D.green "80",D.green "characters."
206− ]
207−
208−
209−oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
210−oneOf code codes =
211− let
212− toDoc spdx =
213− D.green (D.fromString (show spdx))
214− in
215− case codes of
216− [] ->
217− [toDoc code]
218−
219− [code2] ->
220− [toDoc code,"or",toDoc code2]
221−
222− _:_ ->
223− let
224− these = code : init codes
225− final = last codes
226− in
227− map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Exit/Crawl.hsdeleted−345
@@ -1,345 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Crawl
3− ( Exit(..)
4− , Problem(..)
5− , Origin(..)
6− , SrcDirs(..)
7− , toReport
8− )
9− where
10−
11−
12−import qualified Data.Char as Char
13−import qualified Data.Map as Map
14−import qualified Data.Time.Clock as Time
15−
16−import qualified Elm.Compiler as Compiler
17−import qualified Elm.ModuleName as ModuleName
18−import qualified Elm.Package as Pkg
19−import qualified Elm.Version as V
20−import Reporting.Doc ((<+>), (<>))
21−import qualified Reporting.Doc as D
22−import qualified Reporting.Exit.Compile as Compile
23−import qualified Reporting.Exit.Help as Help
24−
25−
26−
27−-- EXIT
28−
29−
30−data Exit
31− = RootFileNotFound FilePath
32− | RootModuleNameDuplicate ModuleName.Raw [FilePath]
33− | RootNameless FilePath
34− | DependencyProblems Problem [Problem]
35− | BadKernelHeader FilePath
36−
37−
38−data Problem
39− = ModuleNotFound Origin ModuleName.Raw SrcDirs
40− | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]
41− | BadHeader FilePath Time.UTCTime String Compiler.Error
42− | ModuleNameReservedForKernel Origin ModuleName.Raw
43− | ModuleNameMissing FilePath ModuleName.Raw
44− | ModuleNameMismatch
45− FilePath
46− ModuleName.Raw -- expected
47− ModuleName.Raw -- actual
48− | PortsInPackage FilePath ModuleName.Raw
49− | EffectsUnexpected FilePath ModuleName.Raw
50−
51−
52−data Origin
53− = ElmJson
54− | File FilePath
55− | Module FilePath ModuleName.Raw
56−
57−
58−data SrcDirs
59− = App [FilePath]
60− | Pkg
61−
62−
63−
64−-- TO REPORT
65−
66−
67−toReport :: Exit -> Help.Report
68−toReport exit =
69− case exit of
70− RootFileNotFound path ->
71− Help.report "FILE NOT FOUND" Nothing
72− "You want me to compile this file:"
73− [ D.indent 4 $ D.dullyellow $ D.fromChars path
74− , "I cannot find it though! Is there a typo?"
75− ]
76−
77− RootModuleNameDuplicate name paths ->
78− Help.report "DUPLICATE NAMES" Nothing
79− "I am trying to compile multiple modules with the same name:"
80− [ D.indent 4 $ D.dullyellow $ D.vcat $
81− map D.fromChars paths
82− , D.fillSep $
83− [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
84− , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."
85− , "Change", "them", "to", "have", "unique", "names", "and", "you"
86− , "should", "be", "all", "set!"
87− ]
88− ]
89−
90− RootNameless path ->
91− namelessToDoc path "Main"
92−
93− DependencyProblems problem otherProblems ->
94− case otherProblems of
95− [] ->
96− problemToReport problem
97−
98− _ ->
99− problemToReport problem
100− -- error "TODO handle multiple dependency errors"
101−
102− BadKernelHeader filePath ->
103− Help.report "BAD KERNEL HEADER" Nothing
104− "I ran into a bad header in this file:"
105− [ D.indent 4 $ D.dullyellow $ D.fromChars filePath
106− , D.reflow $
107− "NOTE: Kernel code is only available to core Elm libraries to ensure\
108− \ the portability and security of the Elm ecosystem. This restriction\
109− \ also makes it possible to improve code gen (i.e. performance) without\
110− \ disrupting the ecosystem."
111− ]
112−
113−
114−
115−-- PROBLEM TO REPORT
116−
117−
118−problemToReport :: Problem -> Help.Report
119−problemToReport problem =
120− case problem of
121− ModuleNotFound origin name srcDirs ->
122− notFoundToDoc origin name srcDirs
123−
124− ModuleAmbiguous origin child paths pkgs ->
125− ambiguousToDoc origin child paths pkgs
126−
127− BadHeader path time source compilerError ->
128− let
129− compilerExit =
130− Compile.Exit "???" path time source [compilerError]
131− in
132− Help.compilerReport compilerExit []
133−
134− ModuleNameMissing path name ->
135− namelessToDoc path name
136−
137− ModuleNameMismatch path expected actual ->
138− Help.report "MODULE NAME MISMATCH" (Just path)
139− ( "The file at " ++ path ++ " has a typo in the module name. It says:"
140− )
141− [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"
142− , "Looks like a typo or copy/paste error. Instead it needs to say:"
143− , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"
144− , "Make the change and you should be all set!"
145− ]
146−
147− ModuleNameReservedForKernel origin name ->
148− kernelNameToDoc origin name
149−
150− PortsInPackage path name ->
151− badTagToDoc path name "port" "port-modules" $
152− "Packages cannot have any `port` modules."
153−
154− EffectsUnexpected path name ->
155− badTagToDoc path name "effect" "effect-modules" $
156− "Creating `effect` modules is relatively experimental. There are a\
157− \ couple in @elm repos right now, but we have decided to be very\
158− \ cautious in expanding its usage."
159−
160−
161−badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report
162−badTagToDoc path name tag hintName summary =
163− Help.report
164− ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
165− (Just path)
166− summary
167− [ D.fillSep $
168− [ "Get", "rid", "of", "all", "the"
169− , D.red (D.fromChars tag)
170− , "stuff", "in"
171− , D.dullyellow (D.fromChars (ModuleName.nameToChars name))
172− , "to", "proceed."
173− ]
174− , D.toSimpleNote $
175− "You can learn the reasoning behind this design choice at "
176− ++ D.makeLink hintName
177− ]
178−
179−
180−
181−-- NAMELESS
182−
183−
184−namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report
185−namelessToDoc path name =
186− Help.report "UNNAMED MODULE" (Just path)
187− ( "The `" ++ ModuleName.nameToChars name
188− ++ "` module must start with a line like this:"
189− )
190− [ D.indent 4 $ D.dullyellow $ D.fromChars $
191− "module " ++ ModuleName.nameToChars name ++ " exposing (..)"
192− , D.reflow $
193− "Try adding that as the first line of your file!"
194− , D.toSimpleNote $
195− "It is best to replace (..) with an explicit list of types and\
196− \ functions you want to expose. If you know a value is only used\
197− \ WITHIN this module, it is extra easy to refactor. This kind of\
198− \ information is great, especially as your project grows!"
199− ]
200−
201−
202−
203−-- NOT FOUND
204−
205−
206−notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report
207−notFoundToDoc origin child srcDirs =
208− case origin of
209− ElmJson ->
210− Help.report "MODULE NOT FOUND" (Just "elm.json")
211− "Your elm.json says your project has the following module:"
212− [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child
213− , D.reflow $
214− "When creating packages, all modules must live in the src/ directory."
215− ]
216−
217− File path ->
218− Help.report "UNKNOWN IMPORT" (Just path)
219− ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")
220− (notFoundDetails child srcDirs)
221−
222− Module path parent ->
223− Help.report "UNKNOWN IMPORT" (Just path)
224− ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")
225− (notFoundDetails child srcDirs)
226−
227−
228−notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]
229−notFoundDetails child srcDirs =
230− let
231− simulatedCode =
232− D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child
233− in
234− case Map.lookup child Pkg.suggestions of
235− Just pkg ->
236− [ simulatedCode
237− , D.reflow $
238− "Do you want the one from the " ++ Pkg.toChars pkg
239− ++ " package? If so, run this command to add that dependency to your elm.json file:"
240− , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg
241− , case srcDirs of
242− Pkg ->
243− D.reflow $
244− "If you want a local file, make sure the `"
245− ++ ModuleName.nameToChars child
246− ++ "` module is in your src/ directory."
247−
248− App _ ->
249− D.reflow $
250− "If you want a local file, make sure the `"
251− ++ ModuleName.nameToChars child
252− ++ "` module is in one of the \"source-directories\" listed in your elm.json file."
253− ]
254−
255− Nothing ->
256− [ simulatedCode
257− , "I cannot find that module! Is there a typo in the module name?"
258− , D.reflow $
259− case srcDirs of
260− Pkg ->
261− "When creating a package, all modules must live in the src/ directory."
262−
263− App [] ->
264− "The \"source-directories\" field of your elm.json is empty, so I only\
265− \ searched in packages. Maybe you need to add a \"src\" directory there?"
266−
267− App [dir] ->
268− "The \"source-directories\" field of your elm.json tells me to only look in the "
269− ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
270−
271− App (dir:_:_) ->
272− "The \"source-directories\" field of your elm.json tells me to look in directories like "
273− ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
274− ]
275−
276−
277−ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report
278−ambiguousToDoc origin child paths pkgs =
279− let
280− pkgToString (Pkg.Canonical pkg vsn) =
281− "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
282−
283− makeReport maybePath summary yellowString =
284− Help.report "AMBIGUOUS IMPORT" maybePath summary
285− [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString
286− , D.reflow $
287− "I found multiple module with that name though:"
288− , D.indent 4 $ D.dullyellow $ D.vcat $
289− map D.fromChars $ paths ++ map pkgToString pkgs
290− , D.reflow $
291− if null paths then
292− "It looks like the name clash is in your dependencies, which is\
293− \ out of your control. Elm does not support this scenario right\
294− \ now, but it may be worthwhile. Please open an issue describing\
295− \ your scenario so we can gather more usage information!"
296− else
297− "Which is the right one? Try renaming your modules to have unique names."
298− ]
299− in
300− case origin of
301− ElmJson ->
302− makeReport
303− Nothing
304− "Your elm.json wants the following module:"
305− (ModuleName.nameToChars child)
306−
307− File path ->
308− makeReport
309− (Just path)
310− ("The file at " ++ path ++ " has an ambiguous import:")
311− ("import " ++ ModuleName.nameToChars child)
312−
313− Module path parent ->
314− makeReport
315− (Just path)
316− ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")
317− ("import " ++ ModuleName.nameToChars child)
318−
319−
320−kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report
321−kernelNameToDoc origin kernelName =
322− let
323− (maybePath, statement) =
324− case origin of
325− ElmJson ->
326− ( Nothing
327− , "Your elm.json says your project has the following module:"
328− )
329−
330− File path ->
331− ( Just path
332− , "This file is trying to import the following module:"
333− )
334−
335− Module path parent ->
336− ( Just path
337− , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"
338− )
339− in
340− Help.report "BAD MODULE NAME" maybePath statement
341− [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName
342− , D.reflow $
343− "But names like that are reserved for internal use.\
344− \ Switch to a name outside of the Elm/Kernel/ namespace."
345− ]
builder/src/Reporting/Exit/Deps.hsdeleted−123
@@ -1,123 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Deps
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Elm.Constraint as Con
10−import qualified Elm.Package as Pkg
11−import qualified Elm.Version as V
12−import Reporting.Doc ((<>))
13−import qualified Reporting.Doc as D
14−import qualified Reporting.Exit.Help as Help
15−
16−
17−
18−-- EXITS
19−
20−
21−data Exit
22− = CorruptVersionCache FilePath Pkg.Name
23− | PackageNotFound Pkg.Name [Pkg.Name]
24− -- verify
25− | PkgBadElm Con.Constraint
26− | AppBadElm V.Version
27− | AppMissingTrans [(Pkg.Name, V.Version)]
28− | BadDeps
29− | BuildFailure FilePath Pkg.Name V.Version
30−
31−
32−
33−-- TO DOC
34−
35−
36−toReport :: Exit -> Help.Report
37−toReport exit =
38− case exit of
39− CorruptVersionCache elmHome pkg ->
40− Help.report "CORRUPT CACHE" Nothing
41− ( "I ran into an unknown package while exploring dependencies:"
42− )
43− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg
44− , D.reflow $
45− "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
46− \ Maybe some program is messing with it? It is just cached files,\
47− \ so you can delete it and see if that fixes the issue."
48− ]
49−
50− PackageNotFound package suggestions ->
51− Help.docReport "PACKAGE NOT FOUND" Nothing
52− ( D.fillSep
53− ["I","cannot","find","a"
54− ,D.red (D.fromUtf8 (Pkg.toString package))
55− ,"package","on","the","package","website."
56− ]
57− )
58− [ "Maybe you want one of these instead?"
59− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
60− , "But check <https://package.elm-lang.org> to see all possibilities!"
61− ]
62−
63− PkgBadElm constraint ->
64− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
65− "Your elm.json says this package needs a version of Elm in this range:"
66− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint
67− , D.fillSep
68− [ "But", "you", "are", "using", "Elm"
69− , D.red (D.fromUtf8 (V.toString V.compiler))
70− , "right", "now."
71− ]
72− ]
73−
74− AppBadElm version ->
75− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
76− "Your elm.json says this application needs a different version of Elm."
77− [ D.fillSep
78− [ "It", "requires"
79− , D.green (D.fromUtf8 (V.toString version)) <> ","
80− , "but", "you", "are", "using"
81− , D.red (D.fromUtf8 (V.toString V.compiler))
82− , "right", "now."
83− ]
84− ]
85−
86− AppMissingTrans missingDeps ->
87− let
88− toEntry (pkg, vsn) =
89− "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""
90− in
91− Help.report "MISSING DEPENDENCIES" (Just "elm.json")
92− "Your elm.json is missing some \"indirect\" dependencies:"
93− [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps
94− , D.fillSep
95− ["This","usually","means","you","are","editing","elm.json","by","hand."
96− ,"It","is","much","more","reliable","to","use","the"
97− ,D.green "elm install","command","instead."
98− ]
99− ]
100−
101− BadDeps ->
102− Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")
103− "The dependencies in your elm.json are not compatible."
104− [ D.fillSep
105− ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
106− ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"
107− ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."
108− ]
109− , D.reflow $
110− "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
111− \ you try those paths and still cannot figure it out!"
112− ]
113−
114− BuildFailure elmHome pkg vsn ->
115− Help.report "CORRUPT DEPENDENCY" Nothing
116− "I ran into a problem while building the following package:"
117− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
118− , D.fillSep
119− ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
120− ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"
121− ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
122− ]
123− ]
builder/src/Reporting/Exit/Help.hs+11−12
@@ -14,7 +14,6 @@ module Reporting.Exit.Help
1414 where
1515
1616
17−import qualified Data.Utf8 as Utf8
1817import GHC.IO.Handle (hIsTerminalDevice)
1918import System.IO (Handle, hPutStr, stderr, stdout)
2019
@@ -22,7 +21,7 @@ import qualified Json.Encode as E
2221import Json.Encode ((==>))
2322import Reporting.Doc ((<+>))
2423import qualified Reporting.Doc as D
25−import qualified Reporting.Exit.Compile as Compile
24+import qualified Reporting.Error as Error
2625
2726
2827
@@ -30,7 +29,7 @@ import qualified Reporting.Exit.Compile as Compile
3029
3130
3231data Report
33− = CompilerReport Compile.Exit [Compile.Exit]
32+ = CompilerReport FilePath Error.Module [Error.Module]
3433 | Report
3534 { _title :: String
3635 , _path :: Maybe FilePath
@@ -53,7 +52,7 @@ jsonReport =
5352 Report
5453
5554
56−compilerReport :: Compile.Exit -> [Compile.Exit] -> Report
55+compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
5756compilerReport =
5857 CompilerReport
5958
@@ -65,8 +64,8 @@ compilerReport =
6564reportToDoc :: Report -> D.Doc
6665reportToDoc report_ =
6766 case report_ of
68− CompilerReport e es ->
69− Compile.toDoc e es
67+ CompilerReport root e es ->
68+ Error.toDoc root e es
7069
7170 Report title maybePath message ->
7271 let
@@ -95,17 +94,17 @@ reportToDoc report_ =
9594reportToJson :: Report -> E.Value
9695reportToJson report_ =
9796 case report_ of
98− CompilerReport e es ->
97+ CompilerReport _ e es ->
9998 E.object
100− [ "type" ==> E.string "compile-errors"
101− , "errors" ==> E.list Compile.toJson (e:es)
99+ [ "type" ==> E.chars "compile-errors"
100+ , "errors" ==> E.list Error.toJson (e:es)
102101 ]
103102
104103 Report title maybePath message ->
105104 E.object
106− [ "type" ==> E.string "error"
107− , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath
108− , "title" ==> E.string (Utf8.fromChars title)
105+ [ "type" ==> E.chars "error"
106+ , "path" ==> maybe E.null E.chars maybePath
107+ , "title" ==> E.chars title
109108 , "message" ==> D.encode message
110109 ]
111110
builder/src/Reporting/Exit/Http.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Http
3− ( Exit(..)
4− , toReport
5− , BadJson(..)
6− , badJsonToDocs
7− )
8− where
9−
10−
11−import qualified Data.Text as Text
12−
13−import Reporting.Doc ((<>))
14−import qualified Reporting.Doc as D
15−import qualified Reporting.Exit.Help as Help
16−
17−
18−
19−-- EXITS
20−
21−
22−data Exit
23− = Unknown String
24− | BadJson String D.Doc
25− | BadZipData
26− | BadZipSha String String
27−
28−
29−
30−-- TO REPORT
31−
32−
33−toReport :: String -> Exit -> Help.Report
34−toReport url exit =
35− let
36− urlDoc =
37− D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"
38− in
39− case exit of
40− Unknown message ->
41− Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
42− [ urlDoc
43− , D.stack
44− [ "Here is the error message I was able to extract:"
45− , D.indent 4 $ D.reflow message
46− ]
47− ]
48−
49− BadJson path doc ->
50− Help.jsonReport "UNEXPECTED JSON" (Just path) doc
51−
52− BadZipData ->
53− Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
54− [ urlDoc
55− , D.reflow $
56− "If it is a transient issue, it should be fixed if you try this\
57− \ again. If it seems like an Elm problem, please report it though!"
58− ]
59−
60− BadZipSha expectedHash actualHash ->
61− Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
62− [ urlDoc
63− , D.reflow "I check the hash the zip, and it seems off:"
64− , D.vcat $ map D.fromString $
65− [ " Expected: " ++ expectedHash
66− , " Actual: " ++ actualHash
67− ]
68− , D.reflow $
69− "This usually means that the package author moved the version\
70− \ tag, so report it to them and see if that is the issue. Folks\
71− \ on Elm slack can probably help as well."
72− ]
73−
74−
75−
76−-- BAD JSON
77−
78−
79−data BadJson
80− = BadNewPkg Text.Text
81− | BadAllPkg Text.Text String
82− | BadAllVsn Text.Text
83−
84−
85−badJsonToDocs :: BadJson -> [D.Doc]
86−badJsonToDocs badJson =
87− case badJson of
88− BadNewPkg txt ->
89− ["I","ran","into",D.red (D.fromString (show txt)) <> ","
90− ,"but","I","need","entries","like"
91− ,D.green "\"elm/core@6.0.0\"" <> "."
92− ]
93−
94− BadAllPkg txt suggestion ->
95− ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
96− ]
97− ++ map D.fromString (words suggestion)
98−
99− BadAllVsn txt ->
100− ["You","provided",D.red (D.fromString (show txt))
101− ,"which","is","not","a","valid","version.","I","need","something","like"
102− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
103− ]
104−
builder/src/Reporting/Task.hs+17
@@ -3,8 +3,10 @@ module Reporting.Task
33 ( Task
44 , run
55 , throw
6+ , mapError
67 --
78 , io
9+ , mio
810 , eio
911 )
1012 where
@@ -31,6 +33,12 @@ throw x =
3133 Task $ \_ err -> err x
3234
3335
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+
3442
3543-- IO
3644
@@ -41,6 +49,15 @@ io work =
4149 Task $ \ok _ -> work >>= ok
4250
4351
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+
4461eio :: (x -> y) -> IO (Either x a) -> Task y a
4562eio func work =
4663 Task $ \ok err ->
builder/src/Stuff.hs+8−9
@@ -8,8 +8,8 @@ module Stuff
88 , elmo
99 , temp
1010 , findRoot
11− , withProjectLock
12− , withCacheLock
11+ , withRootLock
12+ , withRegistryLock
1313 , PackageCache
1414 , getPackageCache
1515 , registry
@@ -120,17 +120,16 @@ findRootHelp dirs =
120120-- LOCKS
121121
122122
123−withProjectLock :: FilePath -> IO a -> IO a
124−withProjectLock root work =
123+withRootLock :: FilePath -> IO a -> IO a
124+withRootLock root work =
125125 do let dir = stuff root
126126 Dir.createDirectoryIfMissing True dir
127− Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)
127+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
128128
129129
130−withCacheLock :: PackageCache -> IO a -> IO a
131−withCacheLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)
133−
130+withRegistryLock :: PackageCache -> IO a -> IO a
131+withRegistryLock (PackageCache dir) work =
132+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
134133
135134
136135
cabal.confignew file+2
@@ -0,0 +1,2 @@
1+profiling: False
2+library-profiling: True
compiler/src/AST/Canonical.hs+11−8
@@ -56,12 +56,14 @@ import Data.Binary
5656import qualified Data.List as List
5757import qualified Data.Map as Map
5858import Data.Name (Name)
59−import qualified Data.Utf8 as Utf8
6059
60+import qualified AST.Source as Src
6161import qualified AST.Utils.Binop as Binop
6262import qualified AST.Utils.Shader as Shader
6363import qualified Data.Index as Index
64+import qualified Elm.Float as EF
6465import qualified Elm.ModuleName as ModuleName
66+import qualified Elm.String as ES
6567import qualified Reporting.Annotation as A
6668
6769
@@ -82,10 +84,10 @@ data Expr_
8284 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
8385 | VarDebug ModuleName.Canonical Name Annotation
8486 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
85− | Chr Utf8.String
86− | Str Utf8.String
87+ | Chr ES.String
88+ | Str ES.String
8789 | Int Int
88− | Float (Utf8.Under256 Float)
90+ | Float EF.Float
8991 | List [Expr]
9092 | Negate Expr
9193 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
@@ -150,8 +152,8 @@ data Pattern_
150152 | PList [Pattern]
151153 | PCons Pattern Pattern
152154 | PBool Union Bool
153− | PChr Utf8.String
154− | PStr Utf8.String
155+ | PChr ES.String
156+ | PStr ES.String
155157 | PInt Int
156158 | PCtor
157159 { _p_home :: ModuleName.Canonical
@@ -231,6 +233,7 @@ data Module =
231233 Module
232234 { _name :: ModuleName.Canonical
233235 , _exports :: Exports
236+ , _docs :: Src.Docs
234237 , _decls :: Decls
235238 , _unions :: Map.Map Name Union
236239 , _aliases :: Map.Map Name Alias
@@ -339,7 +342,7 @@ instance Binary CtorOpts where
339342 0 -> return Normal
340343 1 -> return Enum
341344 2 -> return Unbox
342− _ -> error "binary encoding of CtorOpts was corrupted"
345+ _ -> fail "binary encoding of CtorOpts was corrupted"
343346
344347
345348instance Binary Annotation where
@@ -390,7 +393,7 @@ instance Binary AliasType where
390393 case n of
391394 0 -> liftM Holey get
392395 1 -> liftM Filled get
393− _ -> error "binary encoding of AliasType was corrupted"
396+ _ -> fail "binary encoding of AliasType was corrupted"
394397
395398
396399instance Binary FieldType where
compiler/src/AST/Optimized.hs+14−13
@@ -27,14 +27,15 @@ import qualified Data.Map as Map
2727import qualified Data.Name as Name
2828import Data.Name (Name)
2929import qualified Data.Set as Set
30−import qualified Data.Utf8 as Utf8
3130
3231import qualified AST.Canonical as Can
3332import qualified AST.Utils.Shader as Shader
3433import qualified Data.Index as Index
34+import qualified Elm.Float as EF
3535import qualified Elm.Kernel as K
3636import qualified Elm.ModuleName as ModuleName
3737import qualified Elm.Package as Pkg
38+import qualified Elm.String as ES
3839import qualified Optimize.DecisionTree as DT
3940import qualified Reporting.Annotation as A
4041
@@ -45,10 +46,10 @@ import qualified Reporting.Annotation as A
4546
4647data Expr
4748 = Bool Bool
48− | Chr Utf8.String
49− | Str Utf8.String
49+ | Chr ES.String
50+ | Str ES.String
5051 | Int Int
51− | Float (Utf8.Under256 Float)
52+ | Float EF.Float
5253 | VarLocal Name
5354 | VarGlobal Global
5455 | VarEnum Global Index.ZeroBased
@@ -134,7 +135,7 @@ data GlobalGraph =
134135data LocalGraph =
135136 LocalGraph
136137 { _l_main :: Maybe Main
137− , _l_nodes :: Map.Map Global Node -- TODO profile switching Global to Name
138+ , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
138139 , _l_fields :: Map.Map Name Int
139140 }
140141
@@ -307,7 +308,7 @@ instance Binary Expr where
307308 24 -> pure Unit
308309 25 -> liftM3 Tuple get get get
309310 26 -> liftM3 Shader get get get
310− _ -> error "problem getting Opt.Expr binary"
311+ _ -> fail "problem getting Opt.Expr binary"
311312
312313
313314instance Binary Def where
@@ -321,7 +322,7 @@ instance Binary Def where
321322 case word of
322323 0 -> liftM2 Def get get
323324 1 -> liftM3 TailDef get get get
324− _ -> error "problem getting Opt.Def binary"
325+ _ -> fail "problem getting Opt.Def binary"
325326
326327
327328instance Binary Destructor where
@@ -344,7 +345,7 @@ instance Binary Path where
344345 1 -> liftM2 Field get get
345346 2 -> liftM Unbox get
346347 3 -> liftM Root get
347− _ -> error "problem getting Opt.Path binary"
348+ _ -> fail "problem getting Opt.Path binary"
348349
349350
350351instance (Binary a) => Binary (Decider a) where
@@ -360,7 +361,7 @@ instance (Binary a) => Binary (Decider a) where
360361 0 -> liftM Leaf get
361362 1 -> liftM3 Chain get get get
362363 2 -> liftM3 FanOut get get get
363− _ -> error "problem getting Opt.Decider binary"
364+ _ -> fail "problem getting Opt.Decider binary"
364365
365366
366367instance Binary Choice where
@@ -374,7 +375,7 @@ instance Binary Choice where
374375 case word of
375376 0 -> liftM Inline get
376377 1 -> liftM Jump get
377− _ -> error "problem getting Opt.Choice binary"
378+ _ -> fail "problem getting Opt.Choice binary"
378379
379380
380381
@@ -399,7 +400,7 @@ instance Binary Main where
399400 case word of
400401 0 -> return Static
401402 1 -> liftM2 Dynamic get get
402− _ -> error "problem getting Opt.Main binary"
403+ _ -> fail "problem getting Opt.Main binary"
403404
404405
405406instance Binary Node where
@@ -431,7 +432,7 @@ instance Binary Node where
431432 8 -> liftM2 Kernel get get
432433 9 -> liftM2 PortIncoming get get
433434 10 -> liftM2 PortOutgoing get get
434− _ -> error "problem getting Opt.Node binary"
435+ _ -> fail "problem getting Opt.Node binary"
435436
436437
437438instance Binary EffectsType where
@@ -447,4 +448,4 @@ instance Binary EffectsType where
447448 0 -> return Cmd
448449 1 -> return Sub
449450 2 -> return Fx
450− _ -> error "problem getting Opt.EffectsType binary"
451+ _ -> fail "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hs+31−23
@@ -1,5 +1,4 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
32module AST.Source
43 ( Expr, Expr_(..), VarType(..)
54 , Def(..)
@@ -12,10 +11,12 @@ module AST.Source
1211 , Value(..)
1312 , Union(..)
1413 , Alias(..)
15− , Binop(..)
14+ , Infix(..)
1615 , Port(..)
1716 , Effects(..)
1817 , Manager(..)
18+ , Docs(..)
19+ , Comment(..)
1920 , Exposing(..)
2021 , Exposed(..)
2122 , Privacy(..)
@@ -24,10 +25,13 @@ module AST.Source
2425
2526
2627import Data.Name (Name)
27−import qualified Data.Utf8 as Utf8
28+import qualified Data.Name as Name
2829
2930import qualified AST.Utils.Binop as Binop
3031import 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
3135import qualified Reporting.Annotation as A
3236
3337
@@ -39,10 +43,10 @@ type Expr = A.Located Expr_
3943
4044
4145data Expr_
42− = Chr Utf8.String
43− | Str Utf8.String
46+ = Chr ES.String
47+ | Str ES.String
4448 | Int Int
45− | Float (Utf8.Under256 Float)
49+ | Float EF.Float
4650 | Var VarType Name
4751 | VarQual VarType Name Name
4852 | List [Expr]
@@ -93,8 +97,8 @@ data Pattern_
9397 | PCtorQual A.Region Name Name [Pattern]
9498 | PList [Pattern]
9599 | PCons Pattern Pattern
96− | PChr Utf8.String
97− | PStr Utf8.String
100+ | PChr ES.String
101+ | PStr ES.String
98102 | PInt Int
99103
100104
@@ -124,29 +128,24 @@ data Module =
124128 Module
125129 { _name :: Maybe (A.Located Name)
126130 , _exports :: A.Located Exposing
131+ , _docs :: Docs
127132 , _imports :: [Import]
128133 , _values :: [A.Located Value]
129134 , _unions :: [A.Located Union]
130135 , _aliases :: [A.Located Alias]
131− , _binops :: [A.Located Binop]
136+ , _binops :: [A.Located Infix]
132137 , _effects :: Effects
133138 }
134139
135140
136141getName :: Module -> Name
137−getName (Module maybeName _ _ _ _ _ _ _) =
142+getName (Module maybeName _ _ _ _ _ _ _ _) =
138143 case maybeName of
139144 Just (A.At _ name) ->
140145 name
141146
142147 Nothing ->
143− defaultModuleName
144−
145−
146−{-# NOINLINE defaultModuleName #-}
147−defaultModuleName :: Name
148−defaultModuleName =
149− "Main"
148+ Name._Main
150149
151150
152151getImportName :: Import -> Name
@@ -165,7 +164,7 @@ data Import =
165164data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
166165data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
167166data Alias = Alias (A.Located Name) [A.Located Name] Type
168−data Binop = Binop Name Binop.Associativity Binop.Precedence Name
167+data Infix = Infix Name Binop.Associativity Binop.Precedence Name
169168data Port = Port (A.Located Name) Type
170169
171170
@@ -181,21 +180,30 @@ data Manager
181180 | Fx (A.Located Name) (A.Located Name)
182181
183182
183+data Docs
184+ = NoDocs A.Region
185+ | YesDocs Comment [(Name, Comment)]
186+
187+
188+newtype Comment =
189+ Comment P.Snippet
190+
191+
184192
185193-- EXPOSING
186194
187195
188196data Exposing
189197 = Open
190− | Explicit [A.Located Exposed]
198+ | Explicit [Exposed]
191199
192200
193201data Exposed
194− = Lower Name
195− | Upper Name Privacy
196− | Operator Name
202+ = Lower (A.Located Name)
203+ | Upper (A.Located Name) Privacy
204+ | Operator A.Region Name
197205
198206
199207data Privacy
200− = Public
208+ = Public A.Region
201209 | Private
compiler/src/AST/Utils/Binop.hs+5−6
@@ -41,12 +41,11 @@ instance Binary Precedence where
4141instance Binary Associativity where
4242 get =
4343 do n <- getWord8
44− return $
45− case n of
46− 0 -> Left
47− 1 -> Non
48− 2 -> Right
49− _ -> error "Error reading valid associativity from serialized string"
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"
5049
5150 put assoc =
5251 putWord8 $
compiler/src/AST/Utils/Shader.hs+51−4
@@ -4,22 +4,27 @@ module AST.Utils.Shader
44 ( Source
55 , Types(..)
66 , Type(..)
7+ , fromChars
8+ , toJsStringBuilder
79 )
810 where
911
1012
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
1118import qualified Data.Map as Map
1219import qualified Data.Name as Name
13−import qualified Data.Utf8 as Utf8
1420
1521
1622
1723-- SOURCE
1824
1925
20−type Source = Utf8.VeryLong SOURCE
21−
22−data SOURCE
26+newtype Source =
27+ Source BS.ByteString
2328
2429
2530
@@ -42,3 +47,45 @@ data Type
4247 | V4
4348 | M4
4449 | Texture
50+
51+
52+
53+-- TO BUILDER
54+
55+
56+toJsStringBuilder :: Source -> B.Builder
57+toJsStringBuilder (Source src) =
58+ B.byteString src
59+
60+
61+
62+-- FROM CHARS
63+
64+
65+fromChars :: [Char] -> Source
66+fromChars chars =
67+ Source (BS_UTF8.fromString (escape chars))
68+
69+
70+escape :: [Char] -> [Char]
71+escape chars =
72+ case chars of
73+ [] ->
74+ []
75+
76+ c:cs
77+ | c == '\r' -> escape cs
78+ | c == '\n' -> '\\' : 'n' : escape cs
79+ | c == '\"' -> '\\' : '"' : escape cs
80+ | c == '\'' -> '\\' : '\'' : escape cs
81+ | c == '\\' -> '\\' : '\\' : escape cs
82+ | otherwise -> c : escape cs
83+
84+
85+
86+-- BINARY
87+
88+
89+instance Binary Source where
90+ get = liftM Source get
91+ put (Source a) = put a
compiler/src/AST/Utils/Type.hs−1
@@ -1,5 +1,4 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
32module AST.Utils.Type
43 ( delambda
54 , dealias
compiler/src/Canonicalize/Environment.hs+50−20
@@ -4,6 +4,8 @@ module Canonicalize.Environment
44 ( Env(..)
55 , Exposed
66 , Qualified
7+ , Info(..)
8+ , mergeInfo
79 , Var(..)
810 , Type(..)
911 , Ctor(..)
@@ -20,8 +22,8 @@ module Canonicalize.Environment
2022
2123import qualified Data.Map.Merge.Strict as Map
2224import qualified Data.Map.Strict as Map
23−import qualified Data.Map.Strict.Internal as I
2425import qualified Data.Name as Name
26+import qualified Data.OneOrMore as OneOrMore
2527
2628import qualified AST.Utils.Binop as Binop
2729import qualified AST.Canonical as Can
@@ -58,11 +60,34 @@ data Env =
5860
5961
6062type Exposed a =
61− Map.Map Name.Name (Map.Map ModuleName.Canonical a)
63+ Map.Map Name.Name (Info a)
6264
6365
6466type Qualified a =
65− Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical 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))
6691
6792
6893
@@ -72,7 +97,8 @@ type Qualified a =
7297data Var
7398 = Local A.Region
7499 | TopLevel A.Region
75− | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
100+ | Foreign ModuleName.Canonical Can.Annotation
101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
76102
77103
78104
@@ -139,7 +165,10 @@ addLocalLeft _ region =
139165addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
140166addLocalBoth name region var =
141167 case var of
142− Foreign _ ->
168+ Foreign _ _ ->
169+ Result.ok (Local region)
170+
171+ Foreigns _ _ ->
143172 Result.ok (Local region)
144173
145174 Local parentRegion ->
@@ -150,17 +179,18 @@ addLocalBoth name region var =
150179
151180
152181
182+
153183-- FIND TYPE
154184
155185
156186findType :: A.Region -> Env -> Name.Name -> Result i w Type
157187findType region (Env _ _ ts _ _ _ qts _) name =
158188 case Map.lookup name ts of
159− Just (I.Bin 1 _ tipe _ _) ->
189+ Just (Specific _ tipe) ->
160190 Result.ok tipe
161191
162− Just homes ->
163− Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
192+ Just (Ambiguous h hs) ->
193+ Result.throw (Error.AmbiguousType region Nothing name h hs)
164194
165195 Nothing ->
166196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -171,11 +201,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
171201 case Map.lookup prefix qts of
172202 Just qualified ->
173203 case Map.lookup name qualified of
174− Just (I.Bin 1 _ tipe _ _) ->
204+ Just (Specific _ tipe) ->
175205 Result.ok tipe
176206
177− Just homes ->
178− Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
207+ Just (Ambiguous h hs) ->
208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
179209
180210 Nothing ->
181211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -191,11 +221,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
191221findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
192222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
193223 case Map.lookup name cs of
194− Just (I.Bin 1 _ ctor _ _) ->
224+ Just (Specific _ ctor) ->
195225 Result.ok ctor
196226
197− Just homes ->
198− Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
227+ Just (Ambiguous h hs) ->
228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)
199229
200230 Nothing ->
201231 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -206,11 +236,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
206236 case Map.lookup prefix qcs of
207237 Just qualified ->
208238 case Map.lookup name qualified of
209− Just (I.Bin 1 _ pattern _ _) ->
239+ Just (Specific _ pattern) ->
210240 Result.ok pattern
211241
212− Just homes ->
213− Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
242+ Just (Ambiguous h hs) ->
243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
214244
215245 Nothing ->
216246 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -226,11 +256,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
226256findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
227257findBinop region (Env _ _ _ _ binops _ _ _) name =
228258 case Map.lookup name binops of
229− Just (I.Bin 1 _ binop _ _) ->
259+ Just (Specific _ binop) ->
230260 Result.ok binop
231261
232− Just homes ->
233− Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
262+ Just (Ambiguous h hs) ->
263+ Result.throw (Error.AmbiguousBinop region name h hs)
234264
235265 Nothing ->
236266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
compiler/src/Canonicalize/Environment/Dups.hs+1−1
@@ -105,7 +105,7 @@ one name region value =
105105
106106insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
107107insert name region value dict =
108− Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
108+ Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
109109
110110
111111union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+49−37
@@ -35,7 +35,14 @@ type Result i w a =
3535createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
3636createInitialEnv home ifaces imports =
3737 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
38− Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
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
3946
4047
4148
@@ -61,7 +68,7 @@ emptyState =
6168
6269emptyTypes :: Env.Exposed Env.Type
6370emptyTypes =
64− Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
71+ Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
6572
6673
6774
@@ -102,8 +109,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
102109 (Map.mapMaybeWithKey (unionToType home) unions)
103110 (Map.mapMaybeWithKey (aliasToType home) aliases)
104111
105− !vars = Map.map (Map.singleton home) defs
106− !types = Map.map (Map.singleton home . fst) rawTypeInfo
112+ !vars = Map.map (Env.Specific home) defs
113+ !types = Map.map (Env.Specific home . fst) rawTypeInfo
107114 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
108115
109116 !qvs2 = addQualified prefix vars qvs
@@ -129,7 +136,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
129136
130137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
131138addExposed =
132− Map.unionWith Map.union
139+ Map.unionWith Env.mergeInfo
133140
134141
135142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -150,7 +157,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
150157unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
151158 let
152159 addCtor dict (Can.Ctor ctor index _ args) =
153− Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
160+ Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
154161 in
155162 ( Env.Union (length vars) home
156163 , List.foldl' addCtor Map.empty ctors
@@ -181,7 +188,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
181188 (Can.TAlias home name avars (Can.Filled tipe))
182189 (Can.fieldsToList fields)
183190 in
184− Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
191+ Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
185192
186193 _ ->
187194 Map.empty
@@ -192,9 +199,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
192199-- BINOP
193200
194201
195−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
202+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
196203binopToBinop home op (I.Binop name annotation associativity precedence) =
197− Map.singleton home (Env.Binop op home name annotation associativity precedence)
204+ Env.Specific home (Env.Binop op home name annotation associativity precedence)
198205
199206
200207
@@ -207,19 +214,19 @@ addExposedValue
207214 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
208215 -> Map.Map Name.Name I.Binop
209216 -> State
210− -> A.Located Src.Exposed
217+ -> Src.Exposed
211218 -> Result i w State
212−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
219+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
213220 case exposed of
214− Src.Lower name ->
221+ Src.Lower (A.At region name) ->
215222 case Map.lookup name vars of
216223 Just info ->
217− Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
224+ Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
218225
219226 Nothing ->
220227 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
221228
222− Src.Upper name privacy ->
229+ Src.Upper (A.At region name) privacy ->
223230 case privacy of
224231 Src.Private ->
225232 case Map.lookup name types of
@@ -227,43 +234,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg
227234 case tipe of
228235 Env.Union _ _ ->
229236 let
230− !ts2 = Map.insert name (Map.singleton home tipe) ts
237+ !ts2 = Map.insert name (Env.Specific home tipe) ts
231238 in
232239 Result.ok (State vs ts2 cs bs qvs qts qcs)
233240
234241 Env.Alias _ _ _ _ ->
235242 let
236− !ts2 = Map.insert name (Map.singleton home tipe) ts
243+ !ts2 = Map.insert name (Env.Specific home tipe) ts
237244 !cs2 = addExposed cs ctors
238245 in
239246 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
240247
241248 Nothing ->
242− case Map.lookup name (toCtors types) of
243− Just tipe ->
249+ case checkForCtorMistake name types of
250+ tipe:_ ->
244251 Result.throw $ Error.ImportCtorByName region name tipe
245252
246− Nothing ->
253+ [] ->
247254 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
248255
249− Src.Public ->
256+ Src.Public dotDotRegion ->
250257 case Map.lookup name types of
251258 Just (tipe, ctors) ->
252259 case tipe of
253260 Env.Union _ _ ->
254261 let
255− !ts2 = Map.insert name (Map.singleton home tipe) ts
262+ !ts2 = Map.insert name (Env.Specific home tipe) ts
256263 !cs2 = addExposed cs ctors
257264 in
258265 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
259266
260267 Env.Alias _ _ _ _ ->
261− Result.throw (Error.ImportOpenAlias region name)
268+ Result.throw (Error.ImportOpenAlias dotDotRegion name)
262269
263270 Nothing ->
264271 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
265272
266− Src.Operator op ->
273+ Src.Operator region op ->
267274 case Map.lookup op binops of
268275 Just binop ->
269276 let
@@ -275,18 +282,23 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg
275282 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
276283
277284
278−
279−toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
280−toCtors types =
281− Map.foldr addCtors Map.empty types
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
282288 where
283− addCtors (_, exposedCtors) dict =
284− Map.foldrWithKey addCtor dict exposedCtors
285−
286− addCtor ctorName homes dict =
287− case Map.elems homes of
288− [Env.Ctor _ tipeName _ _ _] ->
289− Map.insert ctorName tipeName dict
290−
291− _ ->
292− dict
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.hs+8−8
@@ -54,7 +54,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
5454
5555
5656collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57−collectVars (Src.Module _ _ _ values _ _ _ effects) =
57+collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
5858 let
5959 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
6060 Dups.insert name region (Env.TopLevel region) dict
@@ -95,7 +95,7 @@ toEffectDups effects =
9595
9696
9797addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
98−addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
98+addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
9999 let
100100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs q
110110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112112 do arity <- checkUnionFreeVars union
113− let one = Map.singleton home (Env.Union arity home)
113+ let one = Env.Specific home (Env.Union arity home)
114114 Result.ok $ Map.insert name one types
115115
116116
@@ -133,7 +133,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
133133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134134 do args <- checkAliasFreeVars alias
135135 ctype <- Type.canonicalize env tipe
136− let one = Map.singleton home (Env.Alias (length args) home args ctype)
136+ let one = Env.Specific home (Env.Alias (length args) home args ctype)
137137 let ts1 = Map.insert name one ts
138138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139139
@@ -262,7 +262,7 @@ addFreeVars freeVars (A.At region tipe) =
262262
263263
264264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
265−addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
265+addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266266 do unionInfo <- traverse (canonicalizeUnion env) unions
267267 aliasInfo <- traverse (canonicalizeAlias env) aliases
268268
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs q
281281 )
282282
283283
284−type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)
285285
286286
287287
@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297297 ,
298298 case ctipe of
299299 Can.TRecord fields Nothing ->
300− Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
300+ Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
301301
302302 _ ->
303303 Dups.none
@@ -351,5 +351,5 @@ toOpts ctors =
351351
352352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Map.singleton home $
354+ Dups.one name region $ Env.Specific home $
355355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+6−7
@@ -14,7 +14,6 @@ import Control.Monad (foldM)
1414import qualified Data.Graph as Graph
1515import qualified Data.List as List
1616import qualified Data.Map.Strict as Map
17−import qualified Data.Map.Strict.Internal as I
1817import qualified Data.Name as Name
1918
2019import qualified AST.Canonical as Can
@@ -696,15 +695,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
696695 Env.TopLevel _ ->
697696 logVar name (Can.VarTopLevel localHome name)
698697
699− Env.Foreign (I.Bin 1 home annotation _ _) ->
698+ Env.Foreign home annotation ->
700699 Result.ok $
701700 if home == ModuleName.debug then
702701 Can.VarDebug localHome name annotation
703702 else
704703 Can.VarForeign home name annotation
705704
706− Env.Foreign homes ->
707− Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
705+ Env.Foreigns h hs ->
706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)
708707
709708 Nothing ->
710709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -715,15 +714,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
715714 case Map.lookup prefix qvs of
716715 Just qualified ->
717716 case Map.lookup name qualified of
718− Just (I.Bin 1 home annotation _ _) ->
717+ Just (Env.Specific home annotation) ->
719718 Result.ok $
720719 if home == ModuleName.debug then
721720 Can.VarDebug localHome name annotation
722721 else
723722 Can.VarForeign home name annotation
724723
725− Just homes ->
726− Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
724+ Just (Env.Ambiguous h hs) ->
725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
727726
728727 Nothing ->
729728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
compiler/src/Canonicalize/Module.hs+11−11
@@ -42,7 +42,7 @@ type Result i w a =
4242
4343
4444canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
45−canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops effects) =
45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
4646 do let home = ModuleName.Canonical pkg (Src.getName modul)
4747 let cbinops = Map.fromList (map canonicalizeBinop binops)
4848
@@ -54,15 +54,15 @@ canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops ef
5454 ceffects <- Effects.canonicalize env values cunions effects
5555 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
5656
57− return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects
57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
5858
5959
6060
6161-- CANONICALIZE BINOP
6262
6363
64−canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )
65−canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =
64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
6666 ( op, Can.Binop_ associativity precedence func )
6767
6868
@@ -236,11 +236,11 @@ checkExposed
236236 -> Map.Map Name.Name alias
237237 -> Map.Map Name.Name binop
238238 -> Can.Effects
239− -> A.Located Src.Exposed
239+ -> Src.Exposed
240240 -> Result i w (Dups.Dict (A.Located Can.Export))
241−checkExposed values unions aliases binops effects (A.At region exposed) =
241+checkExposed values unions aliases binops effects exposed =
242242 case exposed of
243− Src.Lower name ->
243+ Src.Lower (A.At region name) ->
244244 if Map.member name values then
245245 ok name region Can.ExportValue
246246 else
@@ -252,23 +252,23 @@ checkExposed values unions aliases binops effects (A.At region exposed) =
252252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
253253 ports ++ Map.keys values
254254
255− Src.Operator name ->
255+ Src.Operator region name ->
256256 if Map.member name binops then
257257 ok name region Can.ExportBinop
258258 else
259259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
260260 Map.keys binops
261261
262− Src.Upper name Src.Public ->
262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
263263 if Map.member name unions then
264264 ok name region Can.ExportUnionOpen
265265 else if Map.member name aliases then
266− Result.throw $ Error.ExportOpenAlias region name
266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name
267267 else
268268 Result.throw $ Error.ExportNotFound region Error.BadType name $
269269 Map.keys unions ++ Map.keys aliases
270270
271− Src.Upper name Src.Private ->
271+ Src.Upper (A.At region name) Src.Private ->
272272 if Map.member name unions then
273273 ok name region Can.ExportUnionClosed
274274 else if Map.member name aliases then
compiler/src/Canonicalize/Pattern.hs+3−2
@@ -8,6 +8,7 @@ module Canonicalize.Pattern
88 where
99
1010
11+import qualified Data.List as List
1112import qualified Data.Map.Strict as Map
1213import qualified Data.Name as Name
1314
@@ -173,8 +174,8 @@ logVar name region value =
173174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
174175logFields fields value =
175176 let
176− addField (A.At region name) dict =
177+ addField dict (A.At region name) =
177178 Dups.insert name region region dict
178179 in
179180 Result.Result $ \bindings warnings _ ok ->
180− ok (foldr addField bindings fields) warnings value
181+ ok (List.foldl' addField bindings fields) warnings value
compiler/src/Data/Map/Utils.hs+6
@@ -1,6 +1,7 @@
11module Data.Map.Utils
22 ( fromKeys
33 , fromKeysA
4+ , fromValues
45 , any
56 )
67 where
@@ -25,6 +26,11 @@ fromKeysA toValue keys =
2526 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
2627
2728
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+
2834
2935-- ANY
3036
compiler/src/Data/Name.hs+166−177
@@ -1,130 +1,119 @@
11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
33module Data.Name
44 ( Name
5− , toUtf8
6− , fromUtf8
7− , toEscapedBuilder
8− , Utf8.toBuilder
9− , Utf8.fromPtr
10− , Utf8.fromChars
11− , Utf8.toChars
12− -- misc
5+ --
6+ , toChars
7+ , toElmString
8+ , toBuilder
9+ --
10+ , fromPtr
11+ , fromChars
12+ --
1313 , getKernel
1414 , hasDot
15+ , splitDots
1516 , isKernel
1617 , isNumberType
1718 , isComparableType
1819 , isAppendableType
1920 , isCompappendType
2021 , fromVarIndex
21− , fromReplCount
2222 , fromWords
2323 , fromManyNames
2424 , fromTypeVariable
2525 , fromTypeVariableScheme
2626 , sepBy
27− -- interned
27+ --
2828 , int, float, bool, char, string
2929 , maybe, result, list, array, dict, tuple, jsArray
3030 , task, router, cmd, sub, platform, virtualDom
3131 , shader, debug, debugger, bitwise, basics
3232 , utils, negate, true, false, value
33− , node, program, main, dollar, identity
34− , replModule
33+ , node, program, _main, _Main, dollar, identity
34+ , replModule, replValueToPrint
3535 )
3636 where
3737
3838
3939import Prelude hiding (length, maybe, negate)
4040import Control.Exception (assert)
41+import qualified Data.Binary as Binary
4142import qualified Data.ByteString.Builder.Internal as B
42−import Data.Coerce (coerce)
43+import qualified Data.Coerce as Coerce
4344import qualified Data.List as List
45+import qualified Data.String as Chars
4446import qualified Data.Utf8 as Utf8
45−import Foreign.Ptr (plusPtr, minusPtr)
4647import GHC.Exts
47− ( Int(I#), Ptr(Ptr)
48− , RealWorld
48+ ( Int(I#), Ptr
4949 , MutableByteArray#
5050 , isTrue#
5151 , newByteArray#
5252 , sizeofByteArray#
53− , writeWord8OffAddr#
54− , copyByteArrayToAddr#
5553 , unsafeFreezeByteArray#
5654 )
57−import GHC.IO
5855import GHC.ST (ST(ST), runST)
5956import GHC.Prim
6057import GHC.Word (Word8(W8#))
6158
59+import qualified Elm.String as ES
60+
6261
6362
6463-- NAME
6564
6665
67−type Name = Utf8.Under256 NAME
66+type Name =
67+ Utf8.Utf8 ELM_NAME
6868
6969
70−data NAME
70+data ELM_NAME
7171
7272
73−toUtf8 :: Name -> Utf8.String
74−toUtf8 =
75− coerce
7673
74+-- INSTANCES
7775
78−fromUtf8 :: Utf8.String -> Name
79−fromUtf8 =
80− coerce
8176
77+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78+ fromString = Utf8.fromChars
8279
80+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81+ get = Utf8.getUnder256
82+ put = Utf8.putUnder256
8383
84−-- TO ESCAPED BUILDER
8584
8685
87−{-# INLINE toEscapedBuilder #-}
88−toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
89−toEscapedBuilder before after =
90− \name -> B.builder (toEscapedBuilderHelp before after name)
86+-- TO
9187
9288
93−{-# INLINE toEscapedBuilderHelp #-}
94−toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
95−toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
96− go 0 (I# (sizeofByteArray# ba#))
97− where
98− go !offset !len !(B.BufferRange bOffset bEnd) =
99− let
100− !bLen = minusPtr bEnd bOffset
101− in
102− if len <= bLen then
103− do -- TODO test if writing word-by-word is faster
104− stToIO (copyToPtr name offset bOffset len)
105− stToIO (escape before after bOffset name offset len 0)
106− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
107− k newBufferRange
108− else
109− do stToIO (copyToPtr name offset bOffset bLen)
110− stToIO (escape before after bOffset name offset bLen 0)
111− let !newOffset = offset + bLen
112− let !newLength = len - bLen
113− return $ B.bufferFull 1 bEnd (go newOffset newLength)
114−
115−
116−escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
117−escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
118− if isTrue# (i# <# len#) then
119− if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
120− then
121− do writeWordToPtr ptr i after
122− escape before after ptr name offset len (i + 1)
123− else
124− do escape before after ptr name offset len (i + 1)
89+toChars :: Name -> [Char]
90+toChars =
91+ Utf8.toChars
12592
126− else
127− return ()
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
128117
129118
130119
@@ -133,7 +122,12 @@ escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) l
133122
134123hasDot :: Name -> Bool
135124hasDot name =
136− Utf8.contains 0x2E {- . -} (coerce name)
125+ Utf8.contains 0x2E {- . -} name
126+
127+
128+splitDots :: Name -> [Name]
129+splitDots name =
130+ Utf8.split 0x2E {- . -} name
137131
138132
139133
@@ -181,23 +175,23 @@ isCompappendType = Utf8.startsWith prefix_compappend
181175
182176{-# NOINLINE prefix_kernel #-}
183177prefix_kernel :: Name
184−prefix_kernel = "Elm.Kernel."
178+prefix_kernel = fromChars "Elm.Kernel."
185179
186180{-# NOINLINE prefix_number #-}
187181prefix_number :: Name
188−prefix_number = "number"
182+prefix_number = fromChars "number"
189183
190184{-# NOINLINE prefix_comparable #-}
191185prefix_comparable :: Name
192−prefix_comparable = "comparable"
186+prefix_comparable = fromChars "comparable"
193187
194188{-# NOINLINE prefix_appendable #-}
195189prefix_appendable :: Name
196−prefix_appendable = "appendable"
190+prefix_appendable = fromChars "appendable"
197191
198192{-# NOINLINE prefix_compappend #-}
199193prefix_compappend :: Name
200−prefix_compappend = "compappend"
194+prefix_compappend = fromChars "compappend"
201195
202196
203197
@@ -208,11 +202,11 @@ fromVarIndex :: Int -> Name
208202fromVarIndex n =
209203 runST
210204 (
211− do let !size = getIndexSize n
205+ do let !size = 2 + getIndexSize n
212206 mba <- newByteArray size
213207 writeWord8 mba 0 0x5F {- _ -}
214208 writeWord8 mba 1 0x76 {- v -}
215− writeDigits mba (size - 1) n
209+ writeDigitsAtEnd mba size n
216210 freeze mba
217211 )
218212
@@ -220,19 +214,20 @@ fromVarIndex n =
220214{-# INLINE getIndexSize #-}
221215getIndexSize :: Int -> Int
222216getIndexSize n
223− | n < 10 = 3
224− | n < 100 = 4
225− | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
217+ | n < 10 = 1
218+ | n < 100 = 2
219+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
226220
227221
228222
229−writeDigits :: MBA s -> Int -> Int -> ST s ()
230−writeDigits !mba !offset !n =
223+writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
224+writeDigitsAtEnd !mba !oldOffset !n =
231225 do let (q,r) = quotRem n 10
232− writeWord8 mba offset (0x30 + fromIntegral r)
226+ let !newOffset = oldOffset - 1
227+ writeWord8 mba newOffset (0x30 + fromIntegral r)
233228 if q <= 0
234229 then return ()
235− else writeDigits mba (offset-1) q
230+ else writeDigitsAtEnd mba newOffset q
236231
237232
238233
@@ -255,7 +250,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
255250 mba <- newByteArray size
256251 copyToMBA name mba
257252 writeWord8 mba (I# len#) 0x5F {- _ -}
258− writeDigits mba (size - 1) index
253+ writeDigitsAtEnd mba size index
259254 freeze mba
260255 )
261256 else
@@ -264,7 +259,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
264259 do let !size = I# len# + getIndexSize index
265260 mba <- newByteArray size
266261 copyToMBA name mba
267− writeDigits mba (size - 1) index
262+ writeDigitsAtEnd mba size index
268263 freeze mba
269264 )
270265
@@ -283,61 +278,61 @@ fromTypeVariableScheme scheme =
283278 freeze mba
284279 else
285280 do let (extra, letter) = quotRem scheme 26
286− let !size = getIndexSize extra
281+ let !size = 1 + getIndexSize extra
287282 mba <- newByteArray size
288283 writeWord8 mba 0 (0x61 + fromIntegral letter)
289− writeDigits mba (size - 1) extra
284+ writeDigitsAtEnd mba size extra
290285 freeze mba
291286 )
292287
293288
294289
295−-- FROM REPL COUNT
296−
297−
298−fromReplCount :: Int -> Name
299−fromReplCount n =
300− Utf8.fromChars ("repl_value_" ++ show n)
301−
302−
303−
304290-- 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)
305300
306301
307302fromManyNames :: [Name] -> Name
308303fromManyNames names =
309− let
310− !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
311− in
312− runST
313− (
314− ST $ \s ->
315− case newByteArray# size# s of
316− (# s, mba# #) ->
317− case writeNames mba# 0# names s of
318− s ->
319− case unsafeFreezeByteArray# mba# s of
320− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
321− )
322−
323−
324−writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
325−writeNames mba# !offset# names s =
326304 case names of
327305 [] ->
328− s
329−
330− (Utf8.Utf8 ba#) : names ->
331− case writeWord8Array# mba# offset# 0x24## {- $ -} s of
332− s ->
333− let
334− !offset1# = offset# +# 1#
335− !len# = sizeofByteArray# ba#
336− !newOffset# = offset1# +# len#
337− in
338− case copyByteArray# ba# 0# mba# offset1# len# s of
339− s ->
340− writeNames mba# newOffset# names s
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$-}
341336
342337
343338
@@ -423,22 +418,6 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
423418 s -> (# s, () #)
424419
425420
426−{-# INLINE writeWordToPtr #-}
427−writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()
428−writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
429− ST $ \s ->
430− case writeWord8OffAddr# addr# offset# word# s of
431− s -> (# s, () #)
432−
433−
434−{-# INLINE copyToPtr #-}
435−copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
436−copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =
437− ST $ \s ->
438− case copyByteArrayToAddr# ba# offset# addr# len# s of
439− s -> (# s, () #)
440−
441−
442421{-# INLINE copyToMBA #-}
443422copyToMBA :: Name -> MBA s -> ST s ()
444423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
@@ -453,169 +432,179 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
453432
454433{-# NOINLINE int #-}
455434int :: Name
456−int = "Int"
435+int = fromChars "Int"
457436
458437
459438{-# NOINLINE float #-}
460439float :: Name
461−float = "Float"
440+float = fromChars "Float"
462441
463442
464443{-# NOINLINE bool #-}
465444bool :: Name
466−bool = "Bool"
445+bool = fromChars "Bool"
467446
468447
469448{-# NOINLINE char #-}
470449char :: Name
471−char = "Char"
450+char = fromChars "Char"
472451
473452
474453{-# NOINLINE string #-}
475454string :: Name
476−string = "String"
455+string = fromChars "String"
477456
478457
479458{-# NOINLINE maybe #-}
480459maybe :: Name
481−maybe = "Maybe"
460+maybe = fromChars "Maybe"
482461
483462
484463{-# NOINLINE result #-}
485464result :: Name
486−result = "Result"
465+result = fromChars "Result"
487466
488467
489468{-# NOINLINE list #-}
490469list :: Name
491−list = "List"
470+list = fromChars "List"
492471
493472
494473{-# NOINLINE array #-}
495474array :: Name
496−array = "Array"
475+array = fromChars "Array"
497476
498477
499478{-# NOINLINE dict #-}
500479dict :: Name
501−dict = "Dict"
480+dict = fromChars "Dict"
502481
503482
504483{-# NOINLINE tuple #-}
505484tuple :: Name
506−tuple = "Tuple"
485+tuple = fromChars "Tuple"
507486
508487
509488{-# NOINLINE jsArray #-}
510489jsArray :: Name
511−jsArray = "JsArray"
490+jsArray = fromChars "JsArray"
512491
513492
514493{-# NOINLINE task #-}
515494task :: Name
516−task = "Task"
495+task = fromChars "Task"
517496
518497
519498{-# NOINLINE router #-}
520499router :: Name
521−router = "Router"
500+router = fromChars "Router"
522501
523502
524503{-# NOINLINE cmd #-}
525504cmd :: Name
526−cmd = "Cmd"
505+cmd = fromChars "Cmd"
527506
528507
529508{-# NOINLINE sub #-}
530509sub :: Name
531−sub = "Sub"
510+sub = fromChars "Sub"
532511
533512
534513{-# NOINLINE platform #-}
535514platform :: Name
536−platform = "Platform"
515+platform = fromChars "Platform"
537516
538517
539518{-# NOINLINE virtualDom #-}
540519virtualDom :: Name
541−virtualDom = "VirtualDom"
520+virtualDom = fromChars "VirtualDom"
542521
543522
544523{-# NOINLINE shader #-}
545524shader :: Name
546−shader = "Shader"
525+shader = fromChars "Shader"
547526
548527
549528{-# NOINLINE debug #-}
550529debug :: Name
551−debug = "Debug"
530+debug = fromChars "Debug"
552531
553532
554533{-# NOINLINE debugger #-}
555534debugger :: Name
556−debugger = "Debugger"
535+debugger = fromChars "Debugger"
557536
558537
559538{-# NOINLINE bitwise #-}
560539bitwise :: Name
561−bitwise = "Bitwise"
540+bitwise = fromChars "Bitwise"
562541
563542
564543{-# NOINLINE basics #-}
565544basics :: Name
566−basics = "Basics"
545+basics = fromChars "Basics"
567546
568547
569548{-# NOINLINE utils #-}
570549utils :: Name
571−utils = "Utils"
550+utils = fromChars "Utils"
572551
573552
574553{-# NOINLINE negate #-}
575554negate :: Name
576−negate = "negate"
555+negate = fromChars "negate"
577556
578557
579558{-# NOINLINE true #-}
580559true :: Name
581−true = "True"
560+true = fromChars "True"
582561
583562
584563{-# NOINLINE false #-}
585564false :: Name
586−false = "False"
565+false = fromChars "False"
587566
588567
589568{-# NOINLINE value #-}
590569value :: Name
591−value = "Value"
570+value = fromChars "Value"
592571
593572
594573{-# NOINLINE node #-}
595574node :: Name
596−node = "Node"
575+node = fromChars "Node"
597576
598577
599578{-# NOINLINE program #-}
600579program :: Name
601−program = "Program"
580+program = fromChars "Program"
581+
602582
583+{-# NOINLINE _main #-}
584+_main :: Name
585+_main = fromChars "main"
603586
604−{-# NOINLINE main #-}
605−main :: Name
606−main = "main"
587+
588+{-# NOINLINE _Main #-}
589+_Main :: Name
590+_Main = fromChars "Main"
607591
608592
609593{-# NOINLINE dollar #-}
610594dollar :: Name
611−dollar = "$"
595+dollar = fromChars "$"
612596
613597
614598{-# NOINLINE identity #-}
615599identity :: Name
616−identity = "identity"
600+identity = fromChars "identity"
617601
618602
619603{-# NOINLINE replModule #-}
620604replModule :: Name
621−replModule = "Elm_Repl"
605+replModule = fromChars "Elm_Repl"
606+
607+
608+{-# NOINLINE replValueToPrint #-}
609+replValueToPrint :: Name
610+replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hs+23−2
@@ -1,11 +1,14 @@
11module Data.NonEmptyList
22 ( List(..)
3+ , singleton
34 , toList
45 , sortBy
56 )
67 where
78
89
10+import Control.Monad (liftM2)
11+import Data.Binary (Binary, get, put)
912import qualified Data.List as List
1013
1114
@@ -17,6 +20,11 @@ data List a =
1720 List a [a]
1821
1922
23+singleton :: a -> List a
24+singleton a =
25+ List a []
26+
27+
2028toList :: List a -> [a]
2129toList (List x xs) =
2230 x:xs
@@ -44,8 +52,12 @@ instance Foldable List where
4452-- SORT BY
4553
4654
47−sortBy :: (a -> a -> Ordering) -> List a -> List a
48−sortBy comparison (List x xs) =
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
4961 case List.sortBy comparison xs of
5062 [] ->
5163 List x []
@@ -55,3 +67,12 @@ sortBy comparison (List x xs) =
5567 LT -> List x (y:ys)
5668 EQ -> List x (y:ys)
5769 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/Utf8.hs+157−300
@@ -1,37 +1,42 @@
11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
33module Data.Utf8
4− ( String
5− , Utf8(..)
6− , VeryLong
7− , Under256
4+ ( Utf8(..)
85 , isEmpty
96 , empty
107 , size
118 , contains
12− , containsDouble
139 , startsWith
1410 , startsWithChar
15− , endsWithWord
11+ , endsWithWord8
1612 , split
1713 , join
18− , all
19− , any
20− , toWord16
21− , fromWord16
22− -- conversions
23− , fromChars
14+ --
15+ , getUnder256
16+ , putUnder256
17+ --
18+ , getVeryLong
19+ , putVeryLong
20+ --
2421 , toChars
2522 , toBuilder
23+ , toEscapedBuilder
24+ --
2625 , fromPtr
27− , fromChunks
28− , Chunk(..)
26+ , fromSnippet
27+ , fromChars
28+ --
29+ , MBA
30+ , newByteArray
31+ , copyFromPtr
32+ , writeWord8
33+ , freeze
2934 )
3035 where
3136
3237
3338import Prelude hiding (String, all, any, concat)
34−import Data.Binary (Binary(..), Get, getWord8, putWord8)
39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)
3540import Data.Binary.Put (putBuilder)
3641import Data.Binary.Get.Internal (readN)
3742import Data.Bits ((.&.), shiftR)
@@ -39,7 +44,6 @@ import qualified Data.ByteString.Internal as B
3944import qualified Data.ByteString.Builder.Internal as B
4045import qualified Data.Char as Char
4146import qualified Data.List as List
42−import Data.String (IsString(..))
4347import Foreign.ForeignPtr (touchForeignPtr)
4448import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
4549import Foreign.Ptr (minusPtr, plusPtr)
@@ -54,36 +58,35 @@ import GHC.Exts
5458 , copyByteArray#
5559 , copyAddrToByteArray#
5660 , copyByteArrayToAddr#
57− , writeWord8Array#,
61+ , writeWord8Array#
5862 )
5963import GHC.IO
6064import GHC.ST (ST(ST), runST)
6165import GHC.Prim
62−import GHC.Word (Word8(W8#), Word16(W16#))
66+import GHC.Word (Word8(W8#))
67+
68+import qualified Parse.Primitives as P
6369
6470
6571
6672-- UTF-8
6773
6874
69−data Utf8 size tipe =
75+data Utf8 tipe =
7076 Utf8 ByteArray#
7177
7278
73−type String = Utf8 VERY_LONG STRING
74−type VeryLong t = Utf8 VERY_LONG t
75−type Under256 t = Utf8 UNDER_256 t
76−
77−data STRING
78−data VERY_LONG
79−data UNDER_256
8079
80+-- EMPTY
8181
8282
83−-- IS EMPTY
83+{-# NOINLINE empty #-}
84+empty :: Utf8 t
85+empty =
86+ runST (freeze =<< newByteArray 0)
8487
8588
86−isEmpty :: Utf8 l t -> Bool
89+isEmpty :: Utf8 t -> Bool
8790isEmpty (Utf8 ba#) =
8891 isTrue# (sizeofByteArray# ba# ==# 0#)
8992
@@ -92,7 +95,7 @@ isEmpty (Utf8 ba#) =
9295-- SIZE
9396
9497
95−size :: Utf8 l t -> Int
98+size :: Utf8 t -> Int
9699size (Utf8 ba#) =
97100 I# (sizeofByteArray# ba#)
98101
@@ -101,7 +104,7 @@ size (Utf8 ba#) =
101104-- CONTAINS
102105
103106
104−contains :: Word8 -> Utf8 l t -> Bool
107+contains :: Word8 -> Utf8 t -> Bool
105108contains (W8# word#) (Utf8 ba#) =
106109 containsHelp word# ba# 0# (sizeofByteArray# ba#)
107110
@@ -117,32 +120,11 @@ containsHelp word# ba# !offset# len# =
117120
118121
119122
120−-- CONTAINS DOUBLE
121−
122−
123−containsDouble :: Word8 -> Utf8 l t -> Bool
124−containsDouble (W8# word#) (Utf8 ba#) =
125− containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)
126−
127−
128−containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
129−containsDoubleHelp word# ba# !offset# len# =
130− let !offset1# = offset# +# 1# in
131− if isTrue# (offset1# <# len#) then
132− if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))
133− && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))
134− then True
135− else containsDoubleHelp word# ba# (offset# +# 1#) len#
136− else
137− False
138−
139−
140−
141123-- STARTS WITH
142124
143125
144126{-# INLINE startsWith #-}
145−startsWith :: Utf8 l t -> Utf8 l t -> Bool
127+startsWith :: Utf8 t -> Utf8 t -> Bool
146128startsWith (Utf8 ba1#) (Utf8 ba2#) =
147129 let
148130 !len1# = sizeofByteArray# ba1#
@@ -157,9 +139,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =
157139-- STARTS WITH CHAR
158140
159141
160−startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
161−startsWithChar isGood str@(Utf8 ba#) =
162− if isEmpty str then
142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
143+startsWithChar isGood bytes@(Utf8 ba#) =
144+ if isEmpty bytes then
163145 False
164146 else
165147 let
@@ -177,8 +159,8 @@ startsWithChar isGood str@(Utf8 ba#) =
177159-- ENDS WITH WORD
178160
179161
180−endsWithWord :: Word8 -> Utf8 l t -> Bool
181−endsWithWord (W8# w#) (Utf8 ba#) =
162+endsWithWord8 :: Word8 -> Utf8 t -> Bool
163+endsWithWord8 (W8# w#) (Utf8 ba#) =
182164 let len# = sizeofByteArray# ba# in
183165 isTrue# (len# ># 0#)
184166 &&
@@ -189,12 +171,12 @@ endsWithWord (W8# w#) (Utf8 ba#) =
189171-- SPLIT
190172
191173
192−split :: Word8 -> String -> [String]
174+split :: Word8 -> Utf8 t -> [Utf8 t]
193175split (W8# divider#) str@(Utf8 ba#) =
194176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
195177
196178
197−splitHelp :: String -> Int -> [Int] -> [String]
179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
198180splitHelp str start offsets =
199181 case offsets of
200182 [] ->
@@ -215,7 +197,7 @@ findDividers divider# ba# !offset# len# revOffsets =
215197 reverse revOffsets
216198
217199
218−unsafeSlice :: String -> Int -> Int -> String
200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
219201unsafeSlice str start end =
220202 let !len = end - start in
221203 if len == 0 then
@@ -231,7 +213,7 @@ unsafeSlice str start end =
231213-- JOIN
232214
233215
234−join :: Word8 -> [String] -> String
216+join :: Word8 -> [Utf8 t] -> Utf8 t
235217join sep strings =
236218 case strings of
237219 [] ->
@@ -245,7 +227,7 @@ join sep strings =
245227 freeze mba
246228
247229
248−joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
249231joinHelp sep mba offset str strings =
250232 let
251233 !len = size str
@@ -263,46 +245,10 @@ joinHelp sep mba offset str strings =
263245
264246
265247
266−-- ALL
267−
268−
269−all :: (Char -> Bool) -> Utf8 l t -> Bool
270−all isGood utf8 =
271− not (any (not . isGood) utf8)
272−
273−
274−
275−-- ANY
276−
277−
278−any :: (Char -> Bool) -> Utf8 l t -> Bool
279−any isGood (Utf8 ba#) =
280− anyHelp isGood ba# 0# (sizeofByteArray# ba#)
281−
282−
283−anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool
284−anyHelp isGood ba# offset# len# =
285− if isTrue# (offset# >=# len#) then
286− False
287− else
288− let
289− !w# = indexWord8Array# ba# offset#
290− !(# char, width# #)
291− | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
292− | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
293− | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
294− | True = (# chr4 ba# offset# w#, 4# #)
295− in
296− if isGood char
297− then True
298− else anyHelp isGood ba# (offset# +# width#) len#
299−
300−
301−
302248-- EQUAL
303249
304250
305−instance Eq (Utf8 l t) where
251+instance Eq (Utf8 t) where
306252 (==) (Utf8 ba1#) (Utf8 ba2#) =
307253 let
308254 !len1# = sizeofByteArray# ba1#
@@ -315,9 +261,11 @@ instance Eq (Utf8 l t) where
315261
316262
317263-- COMPARE
264+--
265+-- TODO: is it fine to sort by length and only compare bytes on length ties?
266+--
318267
319−
320−instance Ord (Utf8 l t) where
268+instance Ord (Utf8 t) where
321269 compare (Utf8 ba1#) (Utf8 ba2#) =
322270 let
323271 !len1# = sizeofByteArray# ba1#
@@ -334,84 +282,20 @@ instance Ord (Utf8 l t) where
334282
335283
336284
337−-- TO WORD16
338−
339−
340−toWord16 :: String -> Maybe Word16
341−toWord16 (Utf8 ba#) =
342− let !len# = sizeofByteArray# ba# in
343− if isTrue# (len# ==# 0#) then
344− Nothing
345− else
346− let !w# = indexWord8Array# ba# 0# in
347− if isTrue# (eqWord# w# 0x30##) then
348− if isTrue# (len# ==# 1#) then Just 0 else Nothing
349− else
350− toWordHelp ba# 0# len# 0##
351−
352−
353−toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16
354−toWordHelp ba# offset# len# number# =
355− if isTrue# (offset# <# len#) then
356− let !w# = indexWord8Array# ba# offset# in
357− if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then
358− let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in
359− toWordHelp ba# (offset# +# 1#) len# newNumber#
360− else
361− Nothing
362− else
363− Just (W16# number#)
364−
365−
366−
367−-- FROM WORD16
368−
369−
370−fromWord16 :: Word16 -> String
371−fromWord16 n =
372− runST $
373− do let !size = getWordSize n
374− mba <- newByteArray size
375− writeDigits mba (size - 1) n
376− freeze mba
377−
378−
379−getWordSize :: Word16 -> Int
380−getWordSize n
381− | n < 10 = 1
382− | n < 100 = 2
383− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
384−
385−
386−writeDigits :: MBA s -> Int -> Word16 -> ST s ()
387−writeDigits !mba !offset !n =
388− do let (q,r) = quotRem n 10
389− writeWord8 mba offset (0x30 + fromIntegral r)
390− if q <= 0
391− then return ()
392− else writeDigits mba (offset-1) q
393−
394−
395−
396285-- FROM STRING
397286
398287
399−fromChars :: [Char] -> Utf8 l t
400−fromChars =
401− fromString
402−
403−
404−instance IsString (Utf8 l t) where
405− fromString str =
406− runST
407− (
408− do mba <- newByteArray (sum (map getWidth str))
409− writeString mba 0 str
410− )
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+ )
411295
412296
413−writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
414−writeString !mba !offset chars =
297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
298+writeChars !mba !offset chars =
415299 case chars of
416300 [] ->
417301 freeze mba
@@ -419,25 +303,25 @@ writeString !mba !offset chars =
419303 char : chars
420304 | n < 0x80 ->
421305 do writeWord8 mba (offset ) (fromIntegral n)
422− writeString mba (offset + 1) chars
306+ writeChars mba (offset + 1) chars
423307
424308 | n < 0x800 ->
425309 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
426310 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
427− writeString mba (offset + 2) chars
311+ writeChars mba (offset + 2) chars
428312
429313 | n < 0x10000 ->
430314 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
431315 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
432316 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
433− writeString mba (offset + 3) chars
317+ writeChars mba (offset + 3) chars
434318
435319 | otherwise ->
436320 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
437321 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
438322 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
439323 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
440− writeString mba (offset + 4) chars
324+ writeChars mba (offset + 4) chars
441325
442326 where
443327 n = Char.ord char
@@ -455,10 +339,10 @@ getWidth char
455339
456340
457341
458−-- TO STRING
342+-- TO CHARS
459343
460344
461−toChars :: Utf8 l t -> [Char]
345+toChars :: Utf8 t -> [Char]
462346toChars (Utf8 ba#) =
463347 toCharsHelp ba# 0# (sizeofByteArray# ba#)
464348
@@ -528,13 +412,13 @@ chr4 ba# offset# firstWord# =
528412
529413
530414{-# INLINE toBuilder #-}
531−toBuilder :: Utf8 l t -> B.Builder
415+toBuilder :: Utf8 t -> B.Builder
532416toBuilder =
533417 \bytes -> B.builder (toBuilderHelp bytes)
534418
535419
536420{-# INLINE toBuilderHelp #-}
537−toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
538422toBuilderHelp !bytes@(Utf8 ba#) k =
539423 go 0 (I# (sizeofByteArray# ba#))
540424 where
@@ -554,144 +438,109 @@ toBuilderHelp !bytes@(Utf8 ba#) k =
554438
555439
556440
557−-- FROM PTR
441+-- TO ESCAPED BUILDER
558442
559443
560−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
561−fromPtr pos end =
562− unsafeDupablePerformIO (stToIO (
563− do let !len = minusPtr end pos
564− mba <- newByteArray len
565− copyFromPtr pos mba 0 len
566− freeze mba
567− ))
444+{-# INLINE toEscapedBuilder #-}
445+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
446+toEscapedBuilder before after =
447+ \name -> B.builder (toEscapedBuilderHelp before after name)
568448
569449
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 ()
570485
571−-- FROM CHUNKS
572486
573487
574−data Chunk
575− = Slice (Ptr Word8) Int
576− | Escape Word8
577− | CodePoint Int
488+-- FROM PTR
578489
579490
580−fromChunks :: [Chunk] -> Utf8 l t
581−fromChunks chunks =
491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
492+fromPtr pos end =
582493 unsafeDupablePerformIO (stToIO (
583− do let !len = sum (map chunkToWidth chunks)
494+ do let !len = minusPtr end pos
584495 mba <- newByteArray len
585− writeChunks mba 0 chunks
496+ copyFromPtr pos mba 0 len
586497 freeze mba
587498 ))
588499
589500
590−chunkToWidth :: Chunk -> Int
591−chunkToWidth chunk =
592− case chunk of
593− Slice _ len ->
594− len
595−
596− Escape _ ->
597− 2
598−
599− CodePoint code ->
600− if code < 0xFFFF then 6 else 12
601−
602−
603−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
604−writeChunks mba offset chunks =
605− case chunks of
606− [] ->
607− return ()
608−
609− chunk : chunks ->
610− case chunk of
611− Slice ptr len ->
612− do copyFromPtr ptr mba offset len
613− let !newOffset = offset + len
614− writeChunks mba newOffset chunks
615−
616− Escape word ->
617− do writeWord8 mba offset 0x5C {- \ -}
618− writeWord8 mba (offset + 1) word
619− let !newOffset = offset + 2
620− writeChunks mba newOffset chunks
621−
622− CodePoint code ->
623− if code < 0xFFFF then
624− do writeCode mba offset code
625− let !newOffset = offset + 6
626− writeChunks mba newOffset chunks
627− else
628− do let (hi,lo) = divMod (code - 0x10000) 0x400
629− writeCode mba (offset ) (hi + 0xD800)
630− writeCode mba (offset + 6) (lo + 0xDC00)
631− let !newOffset = offset + 12
632− writeChunks mba newOffset chunks
633−
634−
635−-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
636−writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
637−writeCode mba offset code =
638− do writeWord8 mba offset 0x5C {- \ -}
639− writeWord8 mba offset 0x75 {- u -}
640− writeHex mba (offset + 2) (shiftR code 12)
641− writeHex mba (offset + 3) (shiftR code 8)
642− writeHex mba (offset + 4) (shiftR code 4)
643− writeHex mba (offset + 5) code
644−
645−
646−writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
647−writeHex mba !offset !bits =
648− do let !n = fromIntegral bits .&. 0x0F
649− writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
650501
502+-- FROM SNIPPET
651503
652504
653−-- UNDER 256 BINARY
654−
655−
656−instance Binary (Utf8 UNDER_256 t) where
657− put bytes@(Utf8 ba#) =
658− do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
659− putBuilder (toBuilder bytes)
660− get =
661− getUnder256 =<< getWord8
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+ ))
662513
663514
664−{-# INLINE getUnder256 #-}
665−getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
666−getUnder256 w =
667− let !n = fromIntegral w in
668− readN n (copyFromByteString n)
669515
516+-- BINARY
670517
671518
672−-- VERY LONG BINARY
519+putUnder256 :: Utf8 t -> Put
520+putUnder256 bytes =
521+ do putWord8 (fromIntegral (size bytes))
522+ putBuilder (toBuilder bytes)
673523
674524
675−instance Binary (Utf8 VERY_LONG t) where
676− put str =
677− do put (size str)
678− putBuilder (toBuilder str)
679− get =
680− getVeryLong =<< get
525+getUnder256 :: Get (Utf8 t)
526+getUnder256 =
527+ do word <- getWord8
528+ let !n = fromIntegral word
529+ readN n (copyFromByteString n)
681530
682531
683−{-# INLINE getVeryLong #-}
684−getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
685−getVeryLong n =
686− if n > 0
687− then readN n (copyFromByteString n)
688− else return empty
532+putVeryLong :: Utf8 t -> Put
533+putVeryLong bytes =
534+ do put (size bytes)
535+ putBuilder (toBuilder bytes)
689536
690537
691−{-# NOINLINE empty #-}
692−empty :: Utf8 l t
693−empty =
694− runST (freeze =<< newByteArray 0)
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
695544
696545
697546
@@ -699,7 +548,7 @@ empty =
699548
700549
701550{-# INLINE copyFromByteString #-}
702−copyFromByteString :: Int -> B.ByteString -> Utf8 l t
551+copyFromByteString :: Int -> B.ByteString -> Utf8 t
703552copyFromByteString len (B.PS fptr offset _) =
704553 unsafeDupablePerformIO
705554 (
@@ -718,21 +567,21 @@ data MBA s =
718567 MBA# (MutableByteArray# s)
719568
720569
721−newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
722571newByteArray (I# len#) =
723572 ST $ \s ->
724573 case newByteArray# len# s of
725574 (# s, mba# #) -> (# s, MBA# mba# #)
726575
727576
728−freeze :: MBA s -> ST s (Utf8 l t)
577+freeze :: MBA s -> ST s (Utf8 t)
729578freeze (MBA# mba#) =
730579 ST $ \s ->
731580 case unsafeFreezeByteArray# mba# s of
732581 (# s, ba# #) -> (# s, Utf8 ba# #)
733582
734583
735−copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
736585copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
737586 ST $ \s ->
738587 case copyByteArray# ba# offset# mba# i# len# s of
@@ -746,11 +595,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
746595 s -> (# s, () #)
747596
748597
749−copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
750599copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
751− IO $ \s ->
752− case copyByteArrayToAddr# ba# offset# mba# len# s of
753− s -> (# s, () #)
600+ IO $ \s ->
601+ case copyByteArrayToAddr# ba# offset# mba# len# s of
602+ s -> (# s, () #)
754603
755604
756605{-# INLINE writeWord8 #-}
@@ -759,3 +608,11 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
759608 ST $ \s ->
760609 case writeWord8Array# mba# offset# w# s of
761610 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.hs+4−13
@@ -1,7 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Elm.Compiler.Imports
4− ( addDefaults
4+ ( defaults
55 )
66 where
77
@@ -14,15 +14,6 @@ import qualified Reporting.Annotation as A
1414
1515
1616
17−-- ADD DEFAULTS
18−
19−
20−addDefaults :: [Src.Import] -> [Src.Import]
21−addDefaults imports =
22− defaults ++ imports
23−
24−
25−
2617-- DEFAULTS
2718
2819
@@ -58,14 +49,14 @@ closed =
5849
5950typeOpen :: Name.Name -> Src.Exposing
6051typeOpen name =
61− Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]
52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
6253
6354
6455typeClosed :: Name.Name -> Src.Exposing
6556typeClosed name =
66− Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
6758
6859
6960operator :: Name.Name -> Src.Exposing
7061operator op =
71− Src.Explicit [ A.At A.zero (Src.Operator op) ]
62+ Src.Explicit [ Src.Operator A.zero op ]
compiler/src/Elm/Compiler/Type.hs+26−27
@@ -15,9 +15,12 @@ module Elm.Compiler.Type
1515
1616
1717import qualified Data.Name as Name
18−import qualified Data.Utf8 as Utf8
1918
2019import 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
2124import qualified Parse.Primitives as P
2225import qualified Parse.Type as Type
2326import qualified Reporting.Annotation as A
@@ -25,10 +28,6 @@ import qualified Reporting.Doc as D
2528import qualified Reporting.Render.Type as RT
2629import qualified Reporting.Render.Type.Localizer as L
2730
28−import qualified Json.Decode as D
29−import qualified Json.Encode as E
30−import Json.Encode ((==>))
31−
3231
3332
3433-- TYPES
@@ -114,18 +113,16 @@ collectLambdas tipe =
114113
115114encode :: Type -> E.Value
116115encode tipe =
117− E.string $ Utf8.fromChars $ D.toLine (toDoc L.empty RT.None tipe)
116+ E.chars $ D.toLine (toDoc L.empty RT.None tipe)
118117
119118
120119decoder :: D.Decoder () Type
121120decoder =
122− do str <- D.string
123− case P.fromByteString Type.expression (error "TODO turn Utf8 to something that can be parsed" str) of
124− P.Ok (tipe, _, _) _ ->
125− return (fromRawType tipe)
126−
127− P.Err _ _ _ _ ->
128− D.failure ()
121+ let
122+ parser =
123+ P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
124+ in
125+ D.customString parser (\_ _ -> ())
129126
130127
131128fromRawType :: Src.Type -> Type
@@ -167,29 +164,31 @@ encodeMetadata :: DebugMetadata -> E.Value
167164encodeMetadata (DebugMetadata msg aliases unions) =
168165 E.object
169166 [ "message" ==> encode msg
170− , "aliases" ==> E.object (map toAliasField aliases)
171− , "unions" ==> E.object (map toUnionField unions)
167+ , "aliases" ==> E.object (map toTypeAliasField aliases)
168+ , "unions" ==> E.object (map toCustomTypeField unions)
172169 ]
173170
174171
175−toAliasField :: Alias -> ( Utf8.String, E.Value )
176−toAliasField (Alias name args tipe) =
177− Name.toUtf8 name ==>
178− E.object
172+toTypeAliasField :: Alias -> ( Json.String, E.Value )
173+toTypeAliasField (Alias name args tipe) =
174+ ( Json.fromName name
175+ , E.object
179176 [ "args" ==> E.list E.name args
180177 , "type" ==> encode tipe
181178 ]
179+ )
182180
183181
184−toUnionField :: Union -> ( Utf8.String, E.Value )
185−toUnionField (Union name args constructors) =
186− Name.toUtf8 name ==>
187− E.object
182+toCustomTypeField :: Union -> ( Json.String, E.Value )
183+toCustomTypeField (Union name args constructors) =
184+ ( Json.fromName name
185+ , E.object
188186 [ "args" ==> E.list E.name args
189− , "tags" ==> E.object (map toCtorObject constructors)
187+ , "tags" ==> E.object (map toVariantObject constructors)
190188 ]
189+ )
191190
192191
193−toCtorObject :: (Name.Name, [Type]) -> ( Utf8.String, E.Value )
194−toCtorObject (name, args) =
195− Name.toUtf8 name ==> E.list encode args
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.hs+1−1
@@ -87,7 +87,7 @@ toPublicName (ModuleName.Canonical _ home) name =
8787
8888newtype Types =
8989 Types (Map.Map ModuleName.Canonical Types_)
90− -- TODO profile Opt.Global representation
90+ -- PERF profile Opt.Global representation
9191 -- current representation needs less allocation
9292 -- but maybe the lookup is much worse
9393
compiler/src/Elm/Constraint.hs+55−77
@@ -5,9 +5,6 @@ module Elm.Constraint
55 , exactly
66 , anything
77 , toChars
8− , toString
9− , Error(..)
10− , fromString
118 , satisfies
129 , check
1310 , intersect
@@ -16,6 +13,8 @@ module Elm.Constraint
1613 , untilNextMajor
1714 , untilNextMinor
1815 , expand
16+ --
17+ , Error(..)
1918 , decoder
2019 , encode
2120 )
@@ -24,11 +23,12 @@ module Elm.Constraint
2423
2524import Control.Monad (liftM4)
2625import Data.Binary (Binary, get, put, getWord8, putWord8)
27−import qualified Data.Utf8 as Utf8
2826
2927import qualified Elm.Version as V
3028import qualified Json.Decode as D
3129import qualified Json.Encode as E
30+import qualified Parse.Primitives as P
31+import Parse.Primitives (Row, Col)
3232
3333
3434
@@ -61,78 +61,21 @@ anything =
6161
6262
6363
64−-- TO STRING
64+-- TO CHARS
6565
6666
67−toChars :: Constraint -> String
67+toChars :: Constraint -> [Char]
6868toChars constraint =
69− Utf8.toChars (toString constraint)
70−
71−
72−toString :: Constraint -> Utf8.String
73−toString constraint =
7469 case constraint of
7570 Range lower lowerOp upperOp upper ->
76− Utf8.join 0x20 {- -}
77− [ V.toString lower
78− , toStringHelp lowerOp
79− , "v"
80− , toStringHelp upperOp
81− , V.toString upper
82− ]
71+ V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper
8372
8473
85−toStringHelp :: Op -> Utf8.String
86−toStringHelp op =
74+opToChars :: Op -> [Char]
75+opToChars op =
8776 case op of
88− Less -> "<"
89− LessOrEqual -> "<="
90−
91−
92−
93−-- FROM STRING
94−
95−
96−data Error
97− = BadLower Utf8.String
98− | BadUpper Utf8.String
99− | BadFormat
100− | InvalidOp
101− | InvalidRange V.Version V.Version
102−
103−
104−fromString :: Utf8.String -> Either Error Constraint
105−fromString string =
106− case Utf8.split 0x20 {- -} string of
107− [lower, lowerOp, "v", upperOp, upper] ->
108− do lo <- versionFromString lower BadLower
109− lop <- opFromString lowerOp
110− hop <- opFromString upperOp
111− hi <- versionFromString upper BadUpper
112− if lo < hi
113− then Right (Range lo lop hop hi)
114− else Left (InvalidRange lo hi)
115−
116− _ ->
117− Left BadFormat
118−
119−
120−versionFromString :: Utf8.String -> (Utf8.String -> Error) -> Either Error V.Version
121−versionFromString string toError =
122− case V.fromString string of
123− Just vsn ->
124− Right vsn
125−
126− Nothing ->
127− Left (toError string)
128−
129−
130−opFromString :: Utf8.String -> Either Error Op
131−opFromString text =
132− case text of
133− "<=" -> Right LessOrEqual
134− "<" -> Right Less
135− _ -> Left InvalidOp
77+ Less -> " < "
78+ LessOrEqual -> " <= "
13679
13780
13881
@@ -245,18 +188,12 @@ expand constraint@(Range lower lowerOp upperOp upper) version
245188
246189encode :: Constraint -> E.Value
247190encode constraint =
248− E.string (toString constraint)
191+ E.chars (toChars constraint)
249192
250193
251194decoder :: D.Decoder Error Constraint
252195decoder =
253− do str <- D.string
254− case fromString str of
255− Right constraint ->
256− return constraint
257−
258− Left err ->
259− D.failure err
196+ D.customString parser BadFormat
260197
261198
262199
@@ -279,4 +216,45 @@ instance Binary Op where
279216 case n of
280217 0 -> return Less
281218 1 -> return LessOrEqual
282− _ -> error "binary encoding of Op was corrupted"
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.hs+218−158
@@ -1,8 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
33module Elm.Docs
44 ( Documentation
5− , toDict
65 , Module(..)
76 , fromModule
87 , Union(..)
@@ -18,33 +17,35 @@ module Elm.Docs
1817 where
1918
2019
21−import qualified Data.ByteString as B
20+import qualified Data.Coerce as Coerce
2221import qualified Data.List as List
2322import Data.Map ((!))
2423import qualified Data.Map as Map
24+import qualified Data.Map.Merge.Strict as Map
2525import qualified Data.Name as Name
26−import qualified Data.Text as Text
27−import qualified Data.Text.Encoding as Text
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)
2830
2931import qualified AST.Canonical as Can
32+import qualified AST.Source as Src
3033import qualified AST.Utils.Binop as Binop
31−import qualified Data.OneOrMore as OneOrMore
3234import qualified Elm.Compiler.Type as Type
3335import qualified Elm.Compiler.Type.Extract as Extract
3436import qualified Elm.ModuleName as ModuleName
3537import qualified Json.Decode as D
3638import qualified Json.Encode as E
3739import 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
3846import qualified Reporting.Annotation as A
39−import qualified Reporting.Error as Error
4047import qualified Reporting.Error.Docs as E
41−import qualified Reporting.Region as R
4248import qualified Reporting.Result as Result
43−import Parse.Primitives (Parser)
44−import qualified Parse.Primitives as P
45−import qualified Parse.Primitives.Symbol as Symbol
46−import qualified Parse.Primitives.Variable as Var
47−import qualified Parse.Primitives.Whitespace as W
4849
4950
5051
@@ -55,21 +56,6 @@ type Documentation =
5556 Map.Map Name.Name Module
5657
5758
58−toDict :: [Module] -> Documentation
59−toDict modules =
60− Map.fromList (map toPair modules)
61−
62−
63−
64−toPair :: Module -> (Name.Name, Module)
65−toPair modul@(Module name _ _ _ _ _) =
66− (name, modul)
67−
68−
69−
70−-- MODULES
71−
72−
7359data Module =
7460 Module
7561 { _name :: Name.Name
@@ -80,9 +66,7 @@ data Module =
8066 , _binops :: Map.Map Name.Name Binop
8167 }
8268
83−
84−type Comment = Text.Text
85−
69+type Comment = Json.String
8670
8771data Alias = Alias Comment [Name.Name] Type.Type
8872data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -91,14 +75,19 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
9175
9276
9377
94−-- JSON ENCODE / DECODE
78+-- JSON
79+
80+
81+encode :: Documentation -> E.Value
82+encode docs =
83+ E.list encodeModule (Map.elems docs)
9584
9685
97−encode :: Module -> E.Value
98−encode (Module name comment unions aliases values binops) =
86+encodeModule :: Module -> E.Value
87+encodeModule (Module name comment unions aliases values binops) =
9988 E.object $
10089 [ "name" ==> ModuleName.encode name
101− , "comment" ==> E.text comment
90+ , "comment" ==> E.string comment
10291 , "unions" ==> E.list encodeUnion (Map.toList unions)
10392 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
10493 , "values" ==> E.list encodeValue (Map.toList values)
@@ -107,16 +96,31 @@ encode (Module name comment unions aliases values binops) =
10796
10897
10998data Error
110− = BadAssociativity Text.Text
111− | BadName
99+ = BadAssociativity
100+ | BadModuleName
112101 | BadType
113102
114103
115−decoder :: D.Decoder Error Module
104+decoder :: D.Decoder Error Documentation
116105decoder =
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 =
117121 Module
118− <$> D.field "name" nameDecoder
119− <*> D.field "comment" D.text
122+ <$> D.field "name" moduleNameDecoder
123+ <*> D.field "comment" D.string
120124 <*> D.field "unions" (dictDecoder union)
121125 <*> D.field "aliases" (dictDecoder alias)
122126 <*> D.field "values" (dictDecoder value)
@@ -131,13 +135,18 @@ dictDecoder entryDecoder =
131135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
132136named entryDecoder =
133137 (,)
134− <$> D.field "name" D.name
138+ <$> D.field "name" nameDecoder
135139 <*> entryDecoder
136140
137141
138−nameDecoder :: D.Decoder Error Name.Name
142+nameDecoder :: D.Decoder e Name.Name
139143nameDecoder =
140− D.mapError (const BadName) ModuleName.decoder
144+ fmap Coerce.coerce D.string
145+
146+
147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148+moduleNameDecoder =
149+ D.mapError (const BadModuleName) ModuleName.decoder
141150
142151
143152typeDecoder :: D.Decoder Error Type.Type
@@ -153,7 +162,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
153162encodeUnion (name, Union comment args cases) =
154163 E.object
155164 [ "name" ==> E.name name
156− , "comment" ==> E.text comment
165+ , "comment" ==> E.string comment
157166 , "args" ==> E.list E.name args
158167 , "cases" ==> E.list encodeCase cases
159168 ]
@@ -162,8 +171,8 @@ encodeUnion (name, Union comment args cases) =
162171union :: D.Decoder Error Union
163172union =
164173 Union
165− <$> D.field "comment" D.text
166− <*> D.field "args" (D.list D.name)
174+ <$> D.field "comment" D.string
175+ <*> D.field "args" (D.list nameDecoder)
167176 <*> D.field "cases" (D.list caseDecoder)
168177
169178
@@ -174,7 +183,7 @@ encodeCase ( tag, args ) =
174183
175184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
176185caseDecoder =
177− D.pair D.name (D.list typeDecoder)
186+ D.pair nameDecoder (D.list typeDecoder)
178187
179188
180189
@@ -185,7 +194,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
185194encodeAlias ( name, Alias comment args tipe) =
186195 E.object
187196 [ "name" ==> E.name name
188− , "comment" ==> E.text comment
197+ , "comment" ==> E.string comment
189198 , "args" ==> E.list E.name args
190199 , "type" ==> Type.encode tipe
191200 ]
@@ -194,8 +203,8 @@ encodeAlias ( name, Alias comment args tipe) =
194203alias :: D.Decoder Error Alias
195204alias =
196205 Alias
197− <$> D.field "comment" D.text
198− <*> D.field "args" (D.list D.name)
206+ <$> D.field "comment" D.string
207+ <*> D.field "args" (D.list nameDecoder)
199208 <*> D.field "type" typeDecoder
200209
201210
@@ -207,7 +216,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
207216encodeValue (name, Value comment tipe) =
208217 E.object
209218 [ "name" ==> E.name name
210− , "comment" ==> E.text comment
219+ , "comment" ==> E.string comment
211220 , "type" ==> Type.encode tipe
212221 ]
213222
@@ -215,7 +224,7 @@ encodeValue (name, Value comment tipe) =
215224value :: D.Decoder Error Value
216225value =
217226 Value
218− <$> D.field "comment" D.text
227+ <$> D.field "comment" D.string
219228 <*> D.field "type" typeDecoder
220229
221230
@@ -227,7 +236,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
227236encodeBinop (name, Binop comment tipe assoc prec) =
228237 E.object
229238 [ "name" ==> E.name name
230− , "comment" ==> E.text comment
239+ , "comment" ==> E.string comment
231240 , "type" ==> Type.encode tipe
232241 , "associativity" ==> encodeAssoc assoc
233242 , "precedence" ==> encodePrec prec
@@ -237,7 +246,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
237246binop :: D.Decoder Error Binop
238247binop =
239248 Binop
240− <$> D.field "comment" D.text
249+ <$> D.field "comment" D.string
241250 <*> D.field "type" typeDecoder
242251 <*> D.field "associativity" assocDecoder
243252 <*> D.field "precedence" precDecoder
@@ -250,19 +259,23 @@ binop =
250259encodeAssoc :: Binop.Associativity -> E.Value
251260encodeAssoc assoc =
252261 case assoc of
253− Binop.Left -> E.text "left"
254− Binop.Non -> E.text "non"
255− Binop.Right -> E.text "right"
262+ Binop.Left -> E.chars "left"
263+ Binop.Non -> E.chars "non"
264+ Binop.Right -> E.chars "right"
256265
257266
258267assocDecoder :: D.Decoder Error Binop.Associativity
259268assocDecoder =
260− do txt <- D.text
261− case txt of
262− "left" -> D.succeed Binop.Left
263− "non" -> D.succeed Binop.Non
264− "right" -> D.succeed Binop.Right
265− _ -> D.fail (BadAssociativity txt)
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
266279
267280
268281
@@ -283,142 +296,190 @@ precDecoder =
283296-- FROM MODULE
284297
285298
286−fromModule :: Can.Module -> Result.Result i w Error.Error Module
287−fromModule (Can.Module name docs exports decls unions aliases binops effects) =
299+fromModule :: Can.Module -> Either E.Error Module
300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
288301 case exports of
289302 Can.ExportEverything region ->
290− Result.throw $ Error.Docs $ E.ImplicitExposing region
303+ Left (E.ImplicitExposing region)
291304
292305 Can.Export exportDict ->
293306 case docs of
294− Can.NoDocs region ->
295− Result.throw $ Error.Docs $ E.NoDocs region
307+ Src.NoDocs region ->
308+ Left (E.NoDocs region)
296309
297− Can.YesDocs region overview comments ->
298− do names <- parseOverview region overview
299− Result.mapError Error.Docs $
300− do checkNames exportDict names
301− let types = gatherTypes decls Map.empty
302− let info = Info comments types unions aliases binops effects
303− inserters <- Map.traverseWithKey (checkExport info) exportDict
304− return $ foldr ($) (emptyModule name overview) inserters
305−
306−
307−emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
308−emptyModule (ModuleName.Canonical _ name) overview =
309− Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
310+ Src.YesDocs overview comments ->
311+ do names <- parseOverview overview
312+ checkNames exportDict names
313+ checkDefs exportDict overview (Map.fromList comments) modul
310314
311315
312316
313317-- PARSE OVERVIEW
314318
315319
316−parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
317−parseOverview (R.Region (R.Position row col) _) overview =
318− case P.runAt row (col + 3) (chompOverview []) overview of
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
319323 Left err ->
320− Result.throw (Error.Syntax err)
324+ Left (E.SyntaxProblem err)
321325
322326 Right names ->
323− Result.ok names
327+ Right names
328+
329+
330+type Parser a =
331+ P.Parser E.SyntaxProblem a
324332
325333
326334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
327335chompOverview names =
328− do isDocs <- W.chompUntilDocs
336+ do isDocs <- chompUntilDocs
329337 if isDocs
330− then chompOverviewHelp names
331− else return names
332−
333−
334−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335−chompOverviewHelp names =
336− do pos <- P.getPosition
337− (W.SPos spos) <- W.whitespace
338− if pos == spos
339− then chompOverview names
340− else chompOverview =<< chompDocs names
338+ then
339+ do Space.chomp E.Space
340+ chompOverview =<< chompDocs names
341+ else
342+ return names
341343
342344
343345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
344346chompDocs names =
345− do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
346− spos <- W.whitespace
347− P.oneOf
348− [ do P.checkSpace spos
349− Symbol.comma
350− P.spaces
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
351362 chompDocs (name:names)
352− , return (name:names)
353363 ]
354−
355−
356−chompBinop :: Parser Name.Name
357−chompBinop =
358− do Symbol.leftParen
359− name <- Symbol.binop
360− Symbol.rightParen
361− return name
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)
362409
363410
364411
365412-- CHECK NAMES
366413
367414
368−type Result i w a =
369− Result.Result i w E.Error a
370−
371−
372−type Dups =
373− Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
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))
374426
375427
376−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
377−checkNames exports names =
378− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
379− let overlap = Map.size (Map.intersection docs exports)
380− if Map.size exports == overlap && overlap == Map.size docs
381− then Result.ok ()
382− else
383− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
385− Result.ok ()
428+type DocNameRegions =
429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
386430
387431
388−addName :: Dups -> A.Located Name.Name -> Dups
432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
389433addName dict (A.At region name) =
390434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
391435
392436
393−isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
437+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
394438isUnique name regions =
395439 case regions of
396440 OneOrMore.One region ->
397441 Result.ok region
398442
399− OneOrMore.More _ _ ->
400− let (r1:r2:_) = OneOrMore.toList regions in
401− Result.throw (E.Duplicate name r1 r2)
443+ OneOrMore.More left right ->
444+ let (r1, r2) = OneOrMore.getFirstTwo left right in
445+ Result.throw (E.NameDuplicate name r1 r2)
402446
403447
404−onlyInDocs :: Name.Name -> R.Region -> Result i w a
405−onlyInDocs name region =
406− Result.throw $ E.OnlyInDocs name region
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
407452
408453
409−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
454+onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
410455onlyInExports name (A.At region _) =
411− Result.throw $ E.OnlyInExports name region
456+ Result.throw $ E.NameOnlyInExports name region
457+
458+
459+
460+-- CHECK DEFS
461+
412462
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
413472
414473
415−-- CHECK EXPORTS
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
416477
417478
418479data Info =
419480 Info
420− { _iComments :: Map.Map Name.Name Comment
421− , _iValues :: Types
481+ { _iComments :: Map.Map Name.Name Src.Comment
482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
422483 , _iUnions :: Map.Map Name.Name Can.Union
423484 , _iAliases :: Map.Map Name.Name Can.Alias
424485 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -426,7 +487,7 @@ data Info =
426487 }
427488
428489
429−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
490+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
430491checkExport info name (A.At region export) =
431492 case export of
432493 Can.ExportValue ->
@@ -467,23 +528,23 @@ checkExport info name (A.At region export) =
467528 m { _values = Map.insert name (Value comment tipe) (_values m) }
468529
469530
470−getComment :: R.Region -> Name.Name -> Info -> Result i w Comment
531+getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
471532getComment region name info =
472533 case Map.lookup name (_iComments info) of
473534 Nothing ->
474535 Result.throw (E.NoComment name region)
475536
476− Just comment ->
477− Result.ok comment
537+ Just (Src.Comment snippet) ->
538+ Result.ok (Json.fromComment snippet)
478539
479540
480−getType :: Name.Name -> Info -> Result i w Type.Type
541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
481542getType name info =
482543 case _iValues info ! name of
483− A.At defRegion Nothing ->
484− Result.throw (E.NoAnnotation name defRegion)
544+ Left region ->
545+ Result.throw (E.NoAnnotation name region)
485546
486− A.At _ (Just tipe) ->
547+ Right tipe ->
487548 Result.ok (Extract.fromType tipe)
488549
489550
@@ -497,7 +558,7 @@ dector (Can.Ctor name _ _ args) =
497558
498559
499560type Types =
500− Map.Map Name.Name (A.Located (Maybe Can.Type))
561+ Map.Map Name.Name (Either A.Region Can.Type)
501562
502563
503564gatherTypes :: Can.Decls -> Types -> Types
@@ -506,8 +567,8 @@ gatherTypes decls types =
506567 Can.Declare def subDecls ->
507568 gatherTypes subDecls (addDef types def)
508569
509− Can.DeclareRec defs subDecls ->
510− gatherTypes subDecls (List.foldl' addDef types defs)
570+ Can.DeclareRec def defs subDecls ->
571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
511572
512573 Can.SaveTheEnvironment ->
513574 types
@@ -517,11 +578,10 @@ addDef :: Types -> Can.Def -> Types
517578addDef types def =
518579 case def of
519580 Can.Def (A.At region name) _ _ ->
520− Map.insert name (A.At region Nothing) types
581+ Map.insert name (Left region) types
521582
522− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
523584 let
524− tipe =
525− foldr Can.TLambda resultType (map snd typedArgs)
585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)
526586 in
527− Map.insert name (A.At region (Just tipe)) types
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.hs+4−4
@@ -73,7 +73,7 @@ data Binop =
7373
7474
7575fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
76−fromModule home (Can.Module _ exports _ unions aliases binops _) annotations =
76+fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =
7777 Interface
7878 { _home = home
7979 , _values = restrict exports annotations
@@ -215,7 +215,7 @@ instance Binary Union where
215215 0 -> liftM OpenUnion get
216216 1 -> liftM ClosedUnion get
217217 2 -> liftM PrivateUnion get
218− _ -> error "binary encoding of Union was corrupted"
218+ _ -> fail "binary encoding of Union was corrupted"
219219
220220
221221instance Binary Alias where
@@ -229,7 +229,7 @@ instance Binary Alias where
229229 case n of
230230 0 -> liftM PublicAlias get
231231 1 -> liftM PrivateAlias get
232− _ -> error "binary encoding of Alias was corrupted"
232+ _ -> fail "binary encoding of Alias was corrupted"
233233
234234
235235instance Binary Binop where
@@ -251,4 +251,4 @@ instance Binary DependencyInterface where
251251 case n of
252252 0 -> liftM Public get
253253 1 -> liftM3 Private get get get
254− _ -> error "binary encoding of DependencyInterface was corrupted"
254+ _ -> fail "binary encoding of DependencyInterface was corrupted"
compiler/src/Elm/Kernel.hs+48−46
@@ -11,14 +11,14 @@ module Elm.Kernel
1111
1212import Control.Monad (liftM, liftM2)
1313import Data.Binary (Binary, get, put, getWord8, putWord8)
14−import qualified Data.ByteString as BS
15−import Data.Coerce (coerce)
14+import qualified Data.ByteString.Internal as B
1615import qualified Data.List as List
1716import qualified Data.Map as Map
1817import qualified Data.Name as Name
19−import qualified Data.Utf8 as Utf8
20−import Data.Word (Word8, Word16)
21−import Foreign.Ptr (Ptr, plusPtr)
18+import Data.Word (Word8)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20+import Foreign.ForeignPtr (ForeignPtr)
21+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
2222
2323import qualified AST.Source as Src
2424import qualified Elm.ModuleName as ModuleName
@@ -36,7 +36,7 @@ import qualified Reporting.Annotation as A
3636
3737
3838data Chunk
39− = JS (Utf8.VeryLong UNCHECKED)
39+ = JS B.ByteString
4040 | ElmVar ModuleName.Canonical Name.Name
4141 | JsVar Name.Name Name.Name
4242 | ElmField Name.Name
@@ -46,9 +46,6 @@ data Chunk
4646 | Prod
4747
4848
49−data UNCHECKED
50−
51−
5249
5350-- COUNT FIELDS
5451
@@ -83,13 +80,13 @@ type Foreigns =
8380 Map.Map ModuleName.Raw Pkg.Name
8481
8582
86−fromByteString :: Pkg.Name -> Foreigns -> BS.ByteString -> Maybe Content
83+fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content
8784fromByteString pkg foreigns bytes =
88− case P.fromByteString (parser pkg foreigns) bytes of
89− P.Ok content _ ->
85+ case P.fromByteString (parser pkg foreigns) toError bytes of
86+ Right content ->
9087 Just content
9188
92− P.Err () ->
89+ Left () ->
9390 Nothing
9491
9592
@@ -120,21 +117,21 @@ ignoreError _ _ _ =
120117
121118parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
122119parseChunks vtable enums fields =
123− P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
120+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
124121 let
125122 (# chunks, newPos, newRow, newCol #) =
126− chompChunks vtable enums fields pos end row col pos []
123+ chompChunks vtable enums fields src pos end row col pos []
127124 in
128125 if newPos == end then
129− cok chunks (P.State newPos end indent newRow newCol)
126+ cok chunks (P.State src newPos end indent newRow newCol)
130127 else
131128 cerr row col toError
132129
133130
134−chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
135−chompChunks vs es fs pos end row col lastPos revChunks =
131+chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
132+chompChunks vs es fs src pos end row col lastPos revChunks =
136133 if pos >= end then
137− let !js = Utf8.fromPtr lastPos end in
134+ let !js = toByteString src lastPos end in
138135 (# reverse (JS js : revChunks), pos, row, col #)
139136
140137 else
@@ -145,24 +142,34 @@ chompChunks vs es fs pos end row col lastPos revChunks =
145142 !pos3 = plusPtr pos 3
146143 in
147144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
148− let !js = Utf8.fromPtr lastPos pos in
149− chompTag vs es fs pos3 end row (col + 3) (JS js : revChunks)
145+ let !js = toByteString src lastPos pos in
146+ chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)
150147 else
151− chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks
148+ chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks
152149
153150 else if word == 0x0A {-\n-} then
154− chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
151+ chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
155152
156153 else
157154 let
158− !newPos = plusPtr pos (getCharWidth pos end word)
155+ !newPos = plusPtr pos (getCharWidth word)
159156 in
160− chompChunks vs es fs newPos end row (col + 1) lastPos revChunks
157+ chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
158+
159+
160+toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString
161+toByteString src pos end =
162+ let
163+ !off = minusPtr pos (unsafeForeignPtrToPtr src)
164+ !len = minusPtr end pos
165+ in
166+ B.PS src off len
167+
161168
162169
163170-- relies on external checks in chompChunks
164−chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
165−chompTag vs es fs pos end row col revChunks =
171+chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
172+chompTag vs es fs src pos end row col revChunks =
166173 let
167174 (# newPos, newCol #) = Var.chompInnerChars pos end col
168175 !tagPos = plusPtr pos (-1)
@@ -172,7 +179,7 @@ chompTag vs es fs pos end row col revChunks =
172179 let
173180 !name = Name.fromPtr pos newPos
174181 in
175− chompChunks vs es fs newPos end row newCol newPos $
182+ chompChunks vs es fs src newPos end row newCol newPos $
176183 ElmField name : revChunks
177184 else
178185 let
@@ -183,7 +190,7 @@ chompTag vs es fs pos end row col revChunks =
183190 (enum, newEnums) =
184191 lookupEnum (word - 0x30) name es
185192 in
186− chompChunks vs newEnums fs newPos end row newCol newPos $
193+ chompChunks vs newEnums fs src newPos end row newCol newPos $
187194 JsEnum enum : revChunks
188195
189196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
@@ -191,19 +198,19 @@ chompTag vs es fs pos end row col revChunks =
191198 (field, newFields) =
192199 lookupField name fs
193200 in
194− chompChunks vs es newFields newPos end row newCol newPos $
201+ chompChunks vs es newFields src newPos end row newCol newPos $
195202 JsField field : revChunks
196203
197204 else if name == "DEBUG" then
198− chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)
205+ chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)
199206
200207 else if name == "PROD" then
201− chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)
208+ chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)
202209
203210 else
204211 case Map.lookup name vs of
205212 Just chunk ->
206− chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)
213+ chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)
207214
208215 Nothing ->
209216 (# revChunks, pos, row, col #)
@@ -312,19 +319,19 @@ toNames exposing =
312319 map toName exposedList
313320
314321
315−toName :: A.Located Src.Exposed -> Name.Name
316−toName (A.At _ exposed) =
322+toName :: Src.Exposed -> Name.Name
323+toName exposed =
317324 case exposed of
318− Src.Lower name ->
325+ Src.Lower (A.At _ name) ->
319326 name
320327
321− Src.Upper name Src.Private ->
328+ Src.Upper (A.At _ name) Src.Private ->
322329 name
323330
324− Src.Upper _ Src.Public ->
331+ Src.Upper _ (Src.Public _) ->
325332 error "cannot have Maybe(..) syntax in kernel code header"
326333
327− Src.Operator _ ->
334+ Src.Operator _ _ ->
328335 error "cannot use binops in kernel code"
329336
330337
@@ -335,7 +342,7 @@ toName (A.At _ exposed) =
335342instance Binary Chunk where
336343 put chunk =
337344 case chunk of
338− JS a -> putWord8 0 >> put (coerce a :: Utf8.String)
345+ JS a -> putWord8 0 >> put a
339346 ElmVar a b -> putWord8 1 >> put a >> put b
340347 JsVar a b -> putWord8 2 >> put a >> put b
341348 ElmField a -> putWord8 3 >> put a
@@ -347,7 +354,7 @@ instance Binary Chunk where
347354 get =
348355 do word <- getWord8
349356 case word of
350− 0 -> liftM toJS get
357+ 0 -> liftM JS get
351358 1 -> liftM2 ElmVar get get
352359 2 -> liftM2 JsVar get get
353360 3 -> liftM ElmField get
@@ -356,8 +363,3 @@ instance Binary Chunk where
356363 6 -> return Debug
357364 7 -> return Prod
358365 _ -> error "problem deserializing Elm.Kernel.Chunk"
359−
360−
361−toJS :: Utf8.String -> Chunk
362−toJS str =
363− JS (coerce str)
compiler/src/Elm/Licenses.hs+48−65
@@ -9,14 +9,12 @@ module Elm.Licenses
99 where
1010
1111
12−import Control.Monad (liftM2)
13−import Data.Binary (Binary, get, put)
14−import Data.Map ((!))
1512import qualified Data.Map as Map
1613import qualified Data.Utf8 as Utf8
1714
1815import qualified Json.Decode as D
1916import qualified Json.Encode as E
17+import qualified Json.String as Json
2018import qualified Reporting.Suggest as Suggest
2119
2220
@@ -24,25 +22,21 @@ import qualified Reporting.Suggest as Suggest
2422-- LICENCES
2523
2624
27−data License =
28− License
29− { _name :: Utf8.String
30− , _code :: Utf8.String
31− }
32− deriving (Eq, Ord)
25+newtype License =
26+ License Json.String
3327
3428
3529bsd3 :: License
3630bsd3 =
37− osiApprovedSpdxLicenses ! "BSD-3-Clause"
31+ License (Json.fromChars "BSD-3-Clause")
3832
3933
4034encode :: License -> E.Value
41−encode (License _ code) =
35+encode (License code) =
4236 E.string code
4337
4438
45−decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License
39+decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License
4640decoder toError =
4741 do str <- D.string
4842 case check str of
@@ -57,97 +51,93 @@ decoder toError =
5751-- CHECK
5852
5953
60−check :: Utf8.String -> Either [Utf8.String] License
61−check rawName =
62− case Map.lookup rawName osiApprovedSpdxLicenses of
63− Just license ->
64− Right license
54+check :: Json.String -> Either [Json.String] License
55+check givenCode =
56+ if Map.member givenCode osiApprovedSpdxLicenses then
57+ Right (License givenCode)
6558
66− Nothing ->
67− let
68− toPairs (License name code) =
69− [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]
70−
71− pairs =
72− concatMap toPairs (Map.elems osiApprovedSpdxLicenses)
73− in
74− Left $ map snd $
75− Suggest.sort (Utf8.toChars rawName) fst pairs
59+ else
60+ let
61+ pairs =
62+ map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)
63+ ++
64+ Map.toList osiApprovedSpdxLicenses
65+ in
66+ Left $ map fst $ take 4 $
67+ Suggest.sort (Utf8.toChars givenCode) snd pairs
7668
7769
7870
7971-- LIST OF LICENCES
8072
8173
82−(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)
83−(==>) code name =
84− ( code, License name code )
74+(==>) :: [Char] -> [Char] -> (Json.String, [Char])
75+(==>) code fullName =
76+ ( Json.fromChars code, fullName )
8577
8678
8779--
8880-- OSI approved licenses in SPDX format.
8981-- <https://spdx.org/licenses/>
9082--
91−osiApprovedSpdxLicenses :: Map.Map Utf8.String License
83+osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
9284osiApprovedSpdxLicenses =
9385 Map.fromList
94− [ "AFL-1.1" ==> "Academic Free License v1.1"
86+ [ "0BSD" ==> "BSD Zero Clause License"
87+ , "AAL" ==> "Attribution Assurance License"
88+ , "AFL-1.1" ==> "Academic Free License v1.1"
9589 , "AFL-1.2" ==> "Academic Free License v1.2"
9690 , "AFL-2.0" ==> "Academic Free License v2.0"
9791 , "AFL-2.1" ==> "Academic Free License v2.1"
9892 , "AFL-3.0" ==> "Academic Free License v3.0"
99− , "APL-1.0" ==> "Adaptive Public License 1.0"
93+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
10094 , "Apache-1.1" ==> "Apache License 1.1"
10195 , "Apache-2.0" ==> "Apache License 2.0"
96+ , "APL-1.0" ==> "Adaptive Public License 1.0"
10297 , "APSL-1.0" ==> "Apple Public Source License 1.0"
10398 , "APSL-1.1" ==> "Apple Public Source License 1.1"
10499 , "APSL-1.2" ==> "Apple Public Source License 1.2"
105100 , "APSL-2.0" ==> "Apple Public Source License 2.0"
106101 , "Artistic-1.0" ==> "Artistic License 1.0"
107− , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
108102 , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
103+ , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
109104 , "Artistic-2.0" ==> "Artistic License 2.0"
110− , "AAL" ==> "Attribution Assurance License"
111− , "BSL-1.0" ==> "Boost Software License 1.0"
112105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
113106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
114− , "0BSD" ==> "BSD Zero Clause License"
107+ , "BSL-1.0" ==> "Boost Software License 1.0"
108+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
115110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
116111 , "CNRI-Python" ==> "CNRI Python License"
117− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
118112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
119113 , "CPL-1.0" ==> "Common Public License 1.0"
120− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
121114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
122− , "EPL-1.0" ==> "Eclipse Public License 1.0"
123115 , "ECL-1.0" ==> "Educational Community License v1.0"
124116 , "ECL-2.0" ==> "Educational Community License v2.0"
125117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
126118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
127119 , "Entessa" ==> "Entessa Public License v1.0"
120+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
128121 , "EUDatagrid" ==> "EU DataGrid Software License"
129122 , "EUPL-1.1" ==> "European Union Public License 1.1"
130123 , "Fair" ==> "Fair License"
131124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
132− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
133125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
134126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
135− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
136− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
137− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
138127 , "HPND" ==> "Historic Permission Notice and Disclaimer"
139− , "IPL-1.0" ==> "IBM Public License v1.0"
140128 , "Intel" ==> "Intel Open Source License"
141129 , "IPA" ==> "IPA Font License"
130+ , "IPL-1.0" ==> "IBM Public License v1.0"
142131 , "ISC" ==> "ISC License"
143− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
132+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
133+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
144135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
145− , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
146136 , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
147− , "LPL-1.02" ==> "Lucent Public License v1.02"
137+ , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
148138 , "LPL-1.0" ==> "Lucent Public License Version 1.0"
149− , "MS-PL" ==> "Microsoft Public License"
150− , "MS-RL" ==> "Microsoft Reciprocal License"
139+ , "LPL-1.02" ==> "Lucent Public License v1.02"
140+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
151141 , "MirOS" ==> "MirOS Licence"
152142 , "MIT" ==> "MIT License"
153143 , "Motosoto" ==> "Motosoto License"
@@ -155,48 +145,41 @@ osiApprovedSpdxLicenses =
155145 , "MPL-1.1" ==> "Mozilla Public License 1.1"
156146 , "MPL-2.0" ==> "Mozilla Public License 2.0"
157147 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
148+ , "MS-PL" ==> "Microsoft Public License"
149+ , "MS-RL" ==> "Microsoft Reciprocal License"
158150 , "Multics" ==> "Multics License"
159151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
160152 , "Naumen" ==> "Naumen Public License"
153+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
161154 , "NGPL" ==> "Nethack General Public License"
162155 , "Nokia" ==> "Nokia Open Source License"
163156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
164157 , "NTP" ==> "NTP License"
165158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
166160 , "OGTSL" ==> "Open Group Test Suite License"
161+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
167162 , "OSL-1.0" ==> "Open Software License 1.0"
168163 , "OSL-2.0" ==> "Open Software License 2.0"
169164 , "OSL-2.1" ==> "Open Software License 2.1"
170165 , "OSL-3.0" ==> "Open Software License 3.0"
171− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
172166 , "PHP-3.0" ==> "PHP License v3.0"
173167 , "PostgreSQL" ==> "PostgreSQL License"
174168 , "Python-2.0" ==> "Python License 2.0"
175169 , "QPL-1.0" ==> "Q Public License 1.0"
176− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
177170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
178171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
179173 , "RSCPL" ==> "Ricoh Source Code Public License"
180− , "OFL-1.1" ==> "SIL Open Font License 1.1"
181174 , "SimPL-2.0" ==> "Simple Public License 2.0"
182− , "Sleepycat" ==> "Sleepycat License"
183175 , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176+ , "Sleepycat" ==> "Sleepycat License"
184177 , "SPL-1.0" ==> "Sun Public License v1.0"
185− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
186178 , "UPL-1.0" ==> "Universal Permissive License v1.0"
187− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
188179 , "VSL-1.0" ==> "Vovida Software License v1.0"
189180 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
190182 , "Xnet" ==> "X.Net License"
191183 , "Zlib" ==> "zlib License"
192184 , "ZPL-2.0" ==> "Zope Public License 2.0"
193185 ]
194−
195−
196−
197−-- BINARY
198−
199−
200−instance Binary License where
201− get = liftM2 License get get
202− put (License a b) = put a >> put b
compiler/src/Elm/ModuleName.hs+65−39
@@ -1,18 +1,19 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}
22module Elm.ModuleName
33 ( Raw
44 , toChars
5− , toString
65 , toFilePath
76 , toHyphenPath
8− , fromHyphenPath
7+ --
98 , encode
109 , decoder
10+ , parser
11+ --
1112 , Canonical(..)
1213 , basics, char, string
1314 , maybe, result, list, array, dict, tuple
1415 , platform, cmd, sub
15− , debug, bitwise
16+ , debug
1617 , virtualDom
1718 , jsonDecode, jsonEncode
1819 , webgl, texture, vector2, vector3, vector4, matrix4
@@ -22,15 +23,19 @@ module Elm.ModuleName
2223
2324import Control.Monad (liftM2)
2425import Data.Binary (Binary(..))
25−import qualified Data.Char as Char
2626import qualified Data.Name as Name
2727import qualified Data.Utf8 as Utf8
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
2830import Prelude hiding (maybe)
2931import qualified System.FilePath as FP
3032
3133import qualified Elm.Package as Pkg
32−import qualified Json.Decode as Decode
33−import qualified Json.Encode as Encode
34+import qualified Json.Decode as D
35+import qualified Json.Encode as E
36+import qualified Parse.Variable as Var
37+import qualified Parse.Primitives as P
38+import Parse.Primitives (Row, Col)
3439
3540
3641
@@ -45,11 +50,6 @@ toChars =
4550 Name.toChars
4651
4752
48−toString :: Raw -> Utf8.String
49−toString =
50− Name.toUtf8
51−
52−
5353toFilePath :: Raw -> FilePath
5454toFilePath name =
5555 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)
@@ -60,38 +60,68 @@ toHyphenPath name =
6060 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
6161
6262
63−fromHyphenPath :: Utf8.String -> Maybe Raw
64−fromHyphenPath str =
65− let
66− chunks =
67− Utf8.split 0x2D {- - -} str
68− in
69− if all isGoodChunk chunks
70− then Just (Name.fromUtf8 (Utf8.join 0x2E {- . -} chunks))
71− else Nothing
72−
73−
7463
7564-- JSON
7665
7766
78−encode :: Raw -> Encode.Value
67+encode :: Raw -> E.Value
7968encode =
80− Encode.name
69+ E.name
8170
8271
83−decoder :: Decode.Decoder Utf8.String Raw
72+decoder :: D.Decoder (Row, Col) Raw
8473decoder =
85− do str <- Decode.string
86− if all isGoodChunk (Utf8.split 0x2E {- . -} str)
87− then return (Name.fromUtf8 str)
88− else Decode.failure str
74+ D.customString parser (,)
75+
76+
77+
78+-- PARSER
8979
9080
91−isGoodChunk :: Utf8.String -> Bool
92−isGoodChunk chunk =
93− Utf8.startsWithChar Char.isUpper chunk
94− && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk
81+parser :: P.Parser (Row, Col) Raw
82+parser =
83+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
84+ let
85+ (# isGood, newPos, newCol #) = chompStart pos end col
86+ in
87+ if isGood && minusPtr newPos pos < 256 then
88+ let !newState = P.State src newPos end indent row newCol in
89+ cok (Utf8.fromPtr pos newPos) newState
90+
91+ else if col == newCol then
92+ eerr row newCol (,)
93+
94+ else
95+ cerr row newCol (,)
96+
97+
98+chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
99+chompStart pos end col =
100+ let
101+ !width = Var.getUpperWidth pos end
102+ in
103+ if width == 0 then
104+ (# False, pos, col #)
105+ else
106+ chompInner (plusPtr pos width) end (col + 1)
107+
108+
109+chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
110+chompInner pos end col =
111+ if pos >= end then
112+ (# True, pos, col #)
113+ else
114+ let
115+ !word = P.unsafeIndex pos
116+ !width = Var.getInnerWidthHelp pos end word
117+ in
118+ if width == 0 then
119+ if word == 0x2E {-.-} then
120+ chompStart (plusPtr pos 1) end (col + 1)
121+ else
122+ (# True, pos, col #)
123+ else
124+ chompInner (plusPtr pos width) end (col + 1)
95125
96126
97127
@@ -105,6 +135,7 @@ data Canonical =
105135 }
106136
107137
138+
108139-- INSTANCES
109140
110141
@@ -195,11 +226,6 @@ debug :: Canonical
195226debug = Canonical Pkg.core Name.debug
196227
197228
198−{-# NOINLINE bitwise #-}
199−bitwise :: Canonical
200−bitwise = Canonical Pkg.core Name.bitwise
201−
202−
203229
204230-- HTML
205231
compiler/src/Elm/Package.hs+205−83
@@ -1,38 +1,52 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}
33module Elm.Package
44 ( Name(..)
5+ , Author
6+ , Project
57 , Canonical(..)
68 , isKernel
7− , toString
89 , toChars
910 , toUrl
1011 , toFilePath
11− , BadName(..)
12− , fromString
12+ , toJsonString
13+ --
1314 , dummyName, kernel, core
1415 , browser, virtualDom, html
1516 , json, http, url
1617 , webgl, linearAlgebra
18+ --
1719 , suggestions
20+ , nearbyNames
21+ --
1822 , decoder
1923 , encode
24+ , keyDecoder
25+ --
26+ , parser
2027 )
2128 where
2229
2330
2431import Control.Monad (liftM2)
2532import Data.Binary (Binary, get, put)
26−import qualified Data.Char as Char
27−import qualified Data.Name as Name
33+import qualified Data.Coerce as Coerce
34+import qualified Data.List as List
2835import qualified Data.Map as Map
36+import qualified Data.Name as Name
2937import Data.Monoid ((<>))
3038import qualified Data.Utf8 as Utf8
39+import Data.Word (Word8)
40+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
3141import System.FilePath ((</>))
3242
3343import qualified Elm.Version as V
34−import qualified Json.Decode as Decode
35−import qualified Json.Encode as Encode
44+import qualified Json.Decode as D
45+import qualified Json.Encode as E
46+import qualified Json.String as Json
47+import qualified Parse.Primitives as P
48+import Parse.Primitives (Row, Col)
49+import qualified Reporting.Suggest as Suggest
3650
3751
3852
@@ -41,9 +55,17 @@ import qualified Json.Encode as Encode
4155
4256data Name =
4357 Name
44− { _author :: !Name.Name
45− , _project :: !Name.Name
58+ { _author :: !Author
59+ , _project :: !Project
4660 }
61+ deriving (Ord)
62+
63+
64+type Author = Utf8.Utf8 AUTHOR
65+type Project = Utf8.Utf8 PROJECT
66+
67+data AUTHOR
68+data PROJECT
4769
4870
4971data Canonical =
@@ -60,127 +82,114 @@ data Canonical =
6082
6183isKernel :: Name -> Bool
6284isKernel (Name author _) =
63− author == "elm" || author == "elm-explorations"
64−
65−
66−toString :: Name -> Utf8.String
67−toString (Name author project) =
68− Utf8.join 0x2F [ Name.toUtf8 author, Name.toUtf8 project ]
85+ author == elm || author == elm_explorations
6986
7087
7188toChars :: Name -> String
7289toChars (Name author project) =
73− Name.toChars author <> "/" <> Name.toChars project
90+ Utf8.toChars author <> "/" <> Utf8.toChars project
7491
7592
7693toUrl :: Name -> String
7794toUrl (Name author project) =
78− Name.toChars author ++ "/" ++ Name.toChars project
95+ Utf8.toChars author ++ "/" ++ Utf8.toChars project
7996
8097
8198toFilePath :: Name -> FilePath
8299toFilePath (Name author project) =
83− Name.toChars author </> Name.toChars project
100+ Utf8.toChars author </> Utf8.toChars project
84101
85102
86−fromString :: Utf8.String -> Either BadName Name
87−fromString str =
88− case Utf8.split 0x2F {- / -} str of
89− [author, project]
90− | Utf8.isEmpty author -> Left BadStructure
91− | Utf8.isEmpty project -> Left BadStructure
92− | Utf8.size project >= 256 -> Left TooLong
93− | Utf8.containsDouble 0x2D {- - -} project -> Left HasDoubleDash
94− | Utf8.contains 0x5F {- _ -} project -> Left HasUnderscore
95− | Utf8.contains 0x2E {- . -} project -> Left HasDot
96− | Utf8.any Char.isUpper project -> Left HasUppercase
97− | Utf8.endsWithWord 0x2D {- - -} project -> Left HasDashEnd
98− | Utf8.startsWithChar Char.isLower project -> Right (Name (Name.fromUtf8 author) (Name.fromUtf8 project))
99− | True -> Left HasNonLowercaseStart
103+toJsonString :: Name -> Json.String
104+toJsonString (Name author project) =
105+ Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]
100106
101− _ ->
102− Left BadStructure
103107
104108
105−data BadName
106− = BadStructure
107− | TooLong
108− | HasDoubleDash
109− | HasUnderscore
110− | HasDot
111− | HasUppercase
112− | HasDashEnd
113− | HasNonLowercaseStart
114−
109+-- COMMON PACKAGE NAMES
115110
116111
117−-- COMMON PACKAGE NAMES
112+toName :: Author -> [Char] -> Name
113+toName author project =
114+ Name author (Utf8.fromChars project)
118115
119116
120117{-# NOINLINE dummyName #-}
121118dummyName :: Name
122119dummyName =
123− Name "author" "project"
120+ toName (Utf8.fromChars "author") "project"
124121
125122
126123{-# NOINLINE kernel #-}
127124kernel :: Name
128125kernel =
129− Name "elm" "kernel"
126+ toName elm "kernel"
130127
131128
132129{-# NOINLINE core #-}
133130core :: Name
134131core =
135− Name "elm" "core"
132+ toName elm "core"
136133
137134
138135{-# NOINLINE browser #-}
139136browser :: Name
140137browser =
141− Name "elm" "browser"
138+ toName elm "browser"
142139
143140
144141{-# NOINLINE virtualDom #-}
145142virtualDom :: Name
146143virtualDom =
147− Name "elm" "virtual-dom"
144+ toName elm "virtual-dom"
148145
149146
150147{-# NOINLINE html #-}
151148html :: Name
152149html =
153− Name "elm" "html"
150+ toName elm "html"
154151
155152
156153{-# NOINLINE json #-}
157154json :: Name
158155json =
159− Name "elm" "json"
156+ toName elm "json"
160157
161158
162159{-# NOINLINE http #-}
163160http :: Name
164161http =
165− Name "elm" "http"
162+ toName elm "http"
166163
167164
168165{-# NOINLINE url #-}
169166url :: Name
170167url =
171− Name "elm" "url"
168+ toName elm "url"
172169
173170
174171{-# NOINLINE webgl #-}
175172webgl :: Name
176173webgl =
177− Name "elm-explorations" "webgl"
174+ toName elm_explorations "webgl"
178175
179176
180177{-# NOINLINE linearAlgebra #-}
181178linearAlgebra :: Name
182179linearAlgebra =
183− Name "elm-explorations" "linear-algebra"
180+ toName elm_explorations "linear-algebra"
181+
182+
183+{-# NOINLINE elm #-}
184+elm :: Author
185+elm =
186+ Utf8.fromChars "elm"
187+
188+
189+{-# NOINLINE elm_explorations #-}
190+elm_explorations :: Author
191+elm_explorations =
192+ Utf8.fromChars "elm-explorations"
184193
185194
186195
@@ -189,17 +198,62 @@ linearAlgebra =
189198
190199suggestions :: Map.Map Name.Name Name
191200suggestions =
201+ let
202+ random = toName elm "random"
203+ time = toName elm "time"
204+ file = toName elm "file"
205+ in
192206 Map.fromList
193− [ ("Browser", browser)
194− , ("Html", html)
195− , ("Http", http)
196− , ("Json.Decode", json)
197− , ("Json.Encode", json)
198− , ("Url.Parser", url)
199− , ("Url", url)
207+ [ "Browser" ==> browser
208+ , "File" ==> file
209+ , "File.Download" ==> file
210+ , "File.Select" ==> file
211+ , "Html" ==> html
212+ , "Html.Attributes" ==> html
213+ , "Html.Events" ==> html
214+ , "Http" ==> http
215+ , "Json.Decode" ==> json
216+ , "Json.Encode" ==> json
217+ , "Random" ==> random
218+ , "Time" ==> time
219+ , "Url.Parser" ==> url
220+ , "Url" ==> url
200221 ]
201222
202223
224+(==>) :: [Char] -> Name -> (Name.Name, Name)
225+(==>) moduleName package =
226+ ( Utf8.fromChars moduleName, package )
227+
228+
229+
230+-- NEARBY NAMES
231+
232+
233+nearbyNames :: Name -> [Name] -> [Name]
234+nearbyNames (Name author1 project1) possibleNames =
235+ let
236+ authorDist = authorDistance (Utf8.toChars author1)
237+ projectDist = projectDistance (Utf8.toChars project1)
238+
239+ nameDistance (Name author2 project2) =
240+ authorDist author2 + projectDist project2
241+ in
242+ take 4 $ List.sortOn nameDistance possibleNames
243+
244+
245+authorDistance :: [Char] -> Author -> Int
246+authorDistance given possibility =
247+ if possibility == elm || possibility == elm_explorations
248+ then 0
249+ else abs (Suggest.distance given (Utf8.toChars possibility))
250+
251+
252+projectDistance :: [Char] -> Project -> Int
253+projectDistance given possibility =
254+ abs (Suggest.distance given (Utf8.toChars possibility))
255+
256+
203257
204258-- INSTANCES
205259
@@ -214,17 +268,13 @@ instance Eq Canonical where
214268 version1 == version2 && package1 == package2
215269
216270
217−instance Ord Name where
218− compare (Name author1 project1) (Name author2 project2) =
219− case compare project1 project2 of
220− LT -> LT
221− EQ -> compare author1 author2
222− GT -> GT
271+
272+-- BINARY
223273
224274
225−instance Binary Name where
226− get = liftM2 Name get get
227− put (Name a b) = put a >> put b
275+instance Binary Name where -- PERF try storing as a Word16
276+ get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
277+ put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
228278
229279
230280instance Binary Canonical where
@@ -236,17 +286,89 @@ instance Binary Canonical where
236286-- JSON
237287
238288
239−decoder :: Decode.Decoder BadName Name
289+decoder :: D.Decoder (Row, Col) Name
240290decoder =
241− do str <- Decode.string
242− case fromString str of
243− Right name ->
244− return name
245−
246− Left err ->
247− Decode.failure err
291+ D.customString parser (,)
248292
249293
250−encode :: Name -> Encode.Value
294+encode :: Name -> E.Value
251295encode name =
252− Encode.string (toString name)
296+ E.chars (toChars name)
297+
298+
299+keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name
300+keyDecoder toError =
301+ let
302+ keyParser =
303+ P.specialize (\(r,c) _ _ -> toError r c) parser
304+ in
305+ D.KeyDecoder keyParser toError
306+
307+
308+
309+-- PARSER
310+
311+
312+parser :: P.Parser (Row, Col) Name
313+parser =
314+ do author <- parseName isAlphaOrDigit isAlphaOrDigit
315+ P.word1 0x2F {-/-} (,)
316+ project <- parseName isLower isLowerOrDigit
317+ return (Name author project)
318+
319+
320+parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)
321+parseName isGoodStart isGoodInner =
322+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
323+ if pos >= end then
324+ eerr row col (,)
325+ else
326+ let !word = P.unsafeIndex pos in
327+ if not (isGoodStart word) then
328+ eerr row col (,)
329+ else
330+ let
331+ (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False
332+ !len = fromIntegral (minusPtr newPos pos)
333+ !newCol = col + len
334+ in
335+ if isGood && len < 256 then
336+ let !newState = P.State src newPos end indent row newCol in
337+ cok (Utf8.fromPtr pos newPos) newState
338+ else
339+ cerr row newCol (,)
340+
341+
342+isLower :: Word8 -> Bool
343+isLower word =
344+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
345+
346+
347+isLowerOrDigit :: Word8 -> Bool
348+isLowerOrDigit word =
349+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
350+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}
351+
352+
353+isAlphaOrDigit :: Word8 -> Bool
354+isAlphaOrDigit word =
355+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
356+ || 0x41 {-A-} <= word && word <= 0x5A {-Z-}
357+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}
358+
359+
360+chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)
361+chompName isGoodChar pos end prevWasDash =
362+ if pos >= end then
363+ (# not prevWasDash, pos #)
364+ else
365+ let !word = P.unsafeIndex pos in
366+ if isGoodChar word then
367+ chompName isGoodChar (plusPtr pos 1) end False
368+ else if word == 0x2D {---} then
369+ if prevWasDash then
370+ (# False, pos #)
371+ else
372+ chompName isGoodChar (plusPtr pos 1) end True
373+ else
374+ (# True, pos #)
compiler/src/Elm/String.hsnew file+133
@@ -0,0 +1,133 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}
3+module Elm.String
4+ ( String
5+ , toChars
6+ , toBuilder
7+ , Chunk(..)
8+ , fromChunks
9+ )
10+ where
11+
12+
13+import Prelude hiding (String)
14+import Data.Binary (Binary, get, put)
15+import Data.Bits ((.&.), shiftR)
16+import qualified Data.ByteString.Builder as B
17+import qualified Data.Utf8 as Utf8
18+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
19+import GHC.Exts (RealWorld, Ptr)
20+import GHC.IO (stToIO, unsafeDupablePerformIO)
21+import GHC.ST (ST)
22+import GHC.Word (Word8)
23+
24+
25+
26+-- STRINGS
27+
28+
29+type String =
30+ Utf8.Utf8 ELM_STRING
31+
32+
33+data ELM_STRING
34+
35+
36+
37+-- HELPERS
38+
39+
40+toChars :: String -> [Char]
41+toChars =
42+ Utf8.toChars
43+
44+
45+{-# INLINE toBuilder #-}
46+toBuilder :: String -> B.Builder
47+toBuilder =
48+ Utf8.toBuilder
49+
50+
51+
52+-- FROM CHUNKS
53+
54+
55+data Chunk
56+ = Slice (Ptr Word8) Int
57+ | Escape Word8
58+ | CodePoint Int
59+
60+
61+fromChunks :: [Chunk] -> String
62+fromChunks chunks =
63+ unsafeDupablePerformIO (stToIO (
64+ do let !len = sum (map chunkToWidth chunks)
65+ mba <- newByteArray len
66+ writeChunks mba 0 chunks
67+ freeze mba
68+ ))
69+
70+
71+chunkToWidth :: Chunk -> Int
72+chunkToWidth chunk =
73+ case chunk of
74+ Slice _ len -> len
75+ Escape _ -> 2
76+ CodePoint c -> if c < 0xFFFF then 6 else 12
77+
78+
79+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
80+writeChunks mba offset chunks =
81+ case chunks of
82+ [] ->
83+ return ()
84+
85+ chunk : chunks ->
86+ case chunk of
87+ Slice ptr len ->
88+ do copyFromPtr ptr mba offset len
89+ let !newOffset = offset + len
90+ writeChunks mba newOffset chunks
91+
92+ Escape word ->
93+ do writeWord8 mba offset 0x5C {- \ -}
94+ writeWord8 mba (offset + 1) word
95+ let !newOffset = offset + 2
96+ writeChunks mba newOffset chunks
97+
98+ CodePoint code ->
99+ if code < 0xFFFF then
100+ do writeCode mba offset code
101+ let !newOffset = offset + 6
102+ writeChunks mba newOffset chunks
103+ else
104+ do let (hi,lo) = divMod (code - 0x10000) 0x400
105+ writeCode mba (offset ) (hi + 0xD800)
106+ writeCode mba (offset + 6) (lo + 0xDC00)
107+ let !newOffset = offset + 12
108+ writeChunks mba newOffset chunks
109+
110+
111+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112+writeCode mba offset code =
113+ do writeWord8 mba offset 0x5C {- \ -}
114+ writeWord8 mba (offset + 1) 0x75 {- u -}
115+ writeHex mba (offset + 2) (shiftR code 12)
116+ writeHex mba (offset + 3) (shiftR code 8)
117+ writeHex mba (offset + 4) (shiftR code 4)
118+ writeHex mba (offset + 5) code
119+
120+
121+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
122+writeHex mba !offset !bits =
123+ do let !n = fromIntegral bits .&. 0x0F
124+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
125+
126+
127+
128+-- BINARY
129+
130+
131+instance Binary (Utf8.Utf8 ELM_STRING) where
132+ get = Utf8.getVeryLong
133+ put = Utf8.putVeryLong
compiler/src/Elm/Version.hs+73−43
@@ -1,3 +1,5 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
13module Elm.Version
24 ( Version(..)
35 , one
@@ -7,10 +9,11 @@ module Elm.Version
79 , bumpMinor
810 , bumpMajor
911 , toChars
10− , toString
11− , fromString
12+ --
1213 , decoder
1314 , encode
15+ --
16+ , parser
1417 )
1518 where
1619
@@ -18,13 +21,15 @@ module Elm.Version
1821import Prelude hiding (max)
1922import Control.Monad (liftM3)
2023import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Utf8 as Utf8
2224import qualified Data.Version as Version
23−import Data.Word (Word16)
25+import Data.Word (Word8, Word16)
26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
2427import qualified Paths_elm
2528
2629import qualified Json.Decode as D
2730import qualified Json.Encode as E
31+import qualified Parse.Primitives as P
32+import Parse.Primitives (Row, Col)
2833
2934
3035
@@ -86,58 +91,26 @@ bumpMajor (Version major _minor _patch) =
8691
8792
8893
89−-- TO STRING
94+-- TO CHARS
9095
9196
92−toChars :: Version -> String
93−toChars vsn =
94− Utf8.toChars (toString vsn)
95−
96−
97−toString :: Version -> Utf8.String
98−toString (Version major minor patch) =
99− Utf8.join 0x2E {- . -}
100− [ Utf8.fromWord16 major
101− , Utf8.fromWord16 minor
102− , Utf8.fromWord16 patch
103− ]
104−
105−
106−
107−-- FROM STRING
108−
109−
110−fromString :: Utf8.String -> Maybe Version
111−fromString str =
112− case Utf8.split 0x2E {- . -} str of
113− [major, minor, patch] ->
114− Version
115− <$> Utf8.toWord16 major
116− <*> Utf8.toWord16 minor
117− <*> Utf8.toWord16 patch
118−
119− _ ->
120− Nothing
97+toChars :: Version -> [Char]
98+toChars (Version major minor patch) =
99+ show major ++ '.' : show minor ++ '.' : show patch
121100
122101
123102
124103-- JSON
125104
126105
127−decoder :: D.Decoder Utf8.String Version
106+decoder :: D.Decoder (Row, Col) Version
128107decoder =
129− do str <- D.string
130− case fromString str of
131− Just version ->
132− return version
133−
134− Nothing ->
135− D.failure str
108+ D.customString parser (,)
136109
137110
138111encode :: Version -> E.Value
139112encode version =
140− E.string (toString version)
113+ E.chars (toChars version)
141114
142115
143116
@@ -164,3 +137,60 @@ instance Binary Version where
164137 put major
165138 put minor
166139 put patch
140+
141+
142+
143+-- PARSER
144+
145+
146+parser :: P.Parser (Row, Col) Version
147+parser =
148+ do major <- numberParser
149+ P.word1 0x2E {-.-} (,)
150+ minor <- numberParser
151+ P.word1 0x2E {-.-} (,)
152+ patch <- numberParser
153+ return (Version major minor patch)
154+
155+
156+numberParser :: P.Parser (Row, Col) Word16
157+numberParser =
158+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
159+ if pos >= end then
160+ eerr row col (,)
161+ else
162+ let !word = P.unsafeIndex pos in
163+ if word == 0x30 {-0-} then
164+
165+ let
166+ !newState = P.State src (plusPtr pos 1) end indent row (col + 1)
167+ in
168+ cok 0 newState
169+
170+ else if isDigit word then
171+
172+ let
173+ (# total, newPos #) = chompWord16 (plusPtr pos 1) end (fromIntegral (word - 0x30))
174+ !newState = P.State src newPos end indent row (col + fromIntegral (minusPtr newPos pos))
175+ in
176+ cok total newState
177+
178+ else
179+ eerr row col (,)
180+
181+
182+chompWord16 :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Word16, Ptr Word8 #)
183+chompWord16 pos end total =
184+ if pos >= end then
185+ (# total, pos #)
186+ else
187+ let !word = P.unsafeIndex pos in
188+ if isDigit word then
189+ chompWord16 (plusPtr pos 1) end (10 * total + fromIntegral (word - 0x30))
190+ else
191+ (# total, pos #)
192+
193+
194+isDigit :: Word8 -> Bool
195+isDigit word =
196+ 0x30 {-0-} <= word && word <= 0x39 {-9-}
compiler/src/Generate/Html.hs+11−10
@@ -29,22 +29,23 @@ sandwich moduleName javascript =
2929
3030<body>
3131
32−<pre id="elm">
33−This is a headless program, meaning there is nothing to show here.
34−
35−I started the program anyway though!
36−
37−You can access it as `app` in the developer console.
38−</pre>
32+<pre id="elm"></pre>
3933
4034<script>
35+try {
4136|] <> javascript <> [r|
4237
43−try {
4438 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
45−} catch (e) {
39+}
40+catch (e)
41+{
4642 // display initialization errors (e.g. bad flags, infinite recursion)
47− document.getElementById("elm").innerText = e;
43+ var header = document.createElement("h1");
44+ header.style.fontFamily = "monospace";
45+ header.innerText = "Initialization Error";
46+ var pre = document.getElementById("elm");
47+ document.body.insertBefore(header, pre);
48+ pre.innerText = e;
4849 throw e;
4950}
5051</script>
compiler/src/Generate/JavaScript.hs+76−55
@@ -2,6 +2,7 @@
22module Generate.JavaScript
33 ( generate
44 , generateForRepl
5+ , generateForReplEndpoint
56 )
67 where
78
@@ -85,7 +86,9 @@ generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _
8586 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
8687 evalState = addGlobal mode graph debugState (Opt.Global home name)
8788 in
88− stateToBuilder evalState
89+ "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90+ <> Functions.functions
91+ <> stateToBuilder evalState
8992 <> print ansi localizer home name tipe
9093
9194
@@ -97,14 +100,47 @@ print ansi localizer home name tipe =
97100 tipeDoc = RT.canToDoc localizer RT.None tipe
98101 bool = if ansi then "true" else "false"
99102 in
100− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
101− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
102− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
103− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
104− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
105− \} else {\n\
106− \ _print(' : ' + _type);\n\
107− \}\n"
103+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
104+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
105+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
106+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
107+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
108+ \} else {\n\
109+ \ _print(' : ' + _type);\n\
110+ \}\n"
111+
112+
113+
114+-- GENERATE FOR REPL ENDPOINT
115+
116+
117+generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118+generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119+ let
120+ name = maybe Name.replValueToPrint id maybeName
121+ mode = Mode.Dev Nothing
122+ debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
123+ evalState = addGlobal mode graph debugState (Opt.Global home name)
124+ in
125+ Functions.functions
126+ <> stateToBuilder evalState
127+ <> postMessage localizer home maybeName tipe
128+
129+
130+postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131+postMessage localizer home maybeName tipe =
132+ let
133+ name = maybe Name.replValueToPrint id maybeName
134+ value = JsName.toBuilder (JsName.fromGlobal home name)
135+ toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136+ tipeDoc = RT.canToDoc localizer RT.None tipe
137+ toName n = "\"" <> Name.toBuilder n <> "\""
138+ in
139+ "self.postMessage({\n\
140+ \ name: " <> maybe "null" toName maybeName <> ",\n\
141+ \ value: " <> toString <> "(true, " <> value <> "),\n\
142+ \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
143+ \});\n"
108144
109145
110146
@@ -225,7 +261,7 @@ addKernel (State revKernels revBuilders seen) kernel =
225261
226262var :: Opt.Global -> Expr.Code -> JS.Stmt
227263var (Opt.Global home name) code =
228− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
264+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
229265
230266
231267isDebugger :: Opt.Global -> Bool
@@ -256,7 +292,7 @@ generateCycle mode (Opt.Global home _) names values functions =
256292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
257293 <> drawCycle names
258294 <> "\\n\\nThese errors are very tricky, so read "
259− <> B.stringUtf8 (D.makeNakedLink "halting-problem")
295+ <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
260296 <> " to learn how to fix it!"
261297 ]
262298
@@ -265,10 +301,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
265301generateCycleFunc mode home def =
266302 case def of
267303 Opt.Def name expr ->
268− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
304+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
269305
270306 Opt.TailDef name args expr ->
271− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
307+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
272308
273309
274310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
@@ -284,9 +320,9 @@ generateRealCycle home (name, _) =
284320 realName = JsName.fromGlobal home name
285321 in
286322 JS.Block
287− [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
323+ [ JS.Var realName (JS.Call (JS.Ref safeName) [])
288324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
289− JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
325+ JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
290326 ]
291327
292328
@@ -314,7 +350,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
314350addChunk mode chunk builder =
315351 case chunk of
316352 K.JS javascript ->
317− Utf8.toBuilder javascript <> builder
353+ B.byteString javascript <> builder
318354
319355 K.ElmVar home name ->
320356 JsName.toBuilder (JsName.fromGlobal home name) <> builder
@@ -354,16 +390,13 @@ addChunk mode chunk builder =
354390
355391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
356392generateEnum mode global@(Opt.Global home name) index =
357− let
358− definition =
359− case mode of
360− Mode.Dev _ ->
361− Expr.codeToExpr (Expr.generateCtor mode global index 0)
393+ JS.Var (JsName.fromGlobal home name) $
394+ case mode of
395+ Mode.Dev _ ->
396+ Expr.codeToExpr (Expr.generateCtor mode global index 0)
362397
363− Mode.Prod _ ->
364− JS.Int (Index.toMachine index)
365− in
366− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
398+ Mode.Prod _ ->
399+ JS.Int (Index.toMachine index)
367400
368401
369402
@@ -372,16 +405,13 @@ generateEnum mode global@(Opt.Global home name) index =
372405
373406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
374407generateBox mode global@(Opt.Global home name) =
375− let
376− definition =
377− case mode of
378− Mode.Dev _ ->
379− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
408+ JS.Var (JsName.fromGlobal home name) $
409+ case mode of
410+ Mode.Dev _ ->
411+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
380412
381− Mode.Prod _ ->
382− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
383− in
384− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
413+ Mode.Prod _ ->
414+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
385415
386416
387417{-# NOINLINE identity #-}
@@ -396,14 +426,11 @@ identity =
396426
397427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
398428generatePort mode (Opt.Global home name) makePort converter =
399− let
400− definition =
401− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
402− [ JS.String (Name.toBuilder name)
403− , Expr.codeToExpr (Expr.generate mode converter)
404− ]
405− in
406− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
429+ JS.Var (JsName.fromGlobal home name) $
430+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
431+ [ JS.String (Name.toBuilder name)
432+ , Expr.codeToExpr (Expr.generate mode converter)
433+ ]
407434
408435
409436
@@ -431,11 +458,9 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)
431458
432459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
433460generateLeaf home@(ModuleName.Canonical _ moduleName) name =
434− let
435− definition =
436− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
437− in
438− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
461+ JS.Var (JsName.fromGlobal home name) $
462+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
463+
439464
440465
441466{-# NOINLINE leaf #-}
@@ -509,7 +534,7 @@ generateExports mode (Trie maybeMain subs) =
509534 <> List.foldl' (addSubTrie mode) "}" otherSubTries
510535
511536
512−addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
537+addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
513538addSubTrie mode end (name, trie) =
514539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
515540
@@ -521,7 +546,7 @@ addSubTrie mode end (name, trie) =
521546data Trie =
522547 Trie
523548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
524− , _subs :: Map.Map Utf8.String Trie
549+ , _subs :: Map.Map Name.Name Trie
525550 }
526551
527552
@@ -532,14 +557,10 @@ emptyTrie =
532557
533558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
534559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
535− let
536− segments =
537− Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
538− in
539− merge trie $ segmentsToTrie home segments main
560+ merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
540561
541562
542−segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
563+segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
543564segmentsToTrie home segments main =
544565 case segments of
545566 [] ->
compiler/src/Generate/JavaScript/Builder.hs+207−217
@@ -16,6 +16,7 @@ module Generate.JavaScript.Builder
1616
1717import Prelude hiding (lines)
1818import qualified Data.List as List
19+import qualified Data.ByteString as BS
1920import Data.ByteString.Builder as B
2021import Data.Monoid ((<>))
2122import qualified Generate.JavaScript.Name as Name
@@ -27,6 +28,19 @@ import qualified Json.Encode as Json
2728-- EXPRESSIONS
2829
2930
31+-- NOTE: I tried making this create a B.Builder directly.
32+--
33+-- The hope was that it'd allocate less and speed things up, but it seemed
34+-- to be neutral for perf.
35+--
36+-- The downside is that Generate.JavaScript.Expression inspects the
37+-- structure of Expr and Stmt on some occassions to try to strip out
38+-- unnecessary closures. I think these closures are already avoided
39+-- by other logic in code gen these days, but I am not 100% certain.
40+--
41+-- For this to be worth it, I think it would be necessary to avoid
42+-- returning tuples when generating expressions.
43+--
3044data Expr
3145 = String Builder
3246 | Float Builder
@@ -37,13 +51,13 @@ data Expr
3751 | Array [Expr]
3852 | Object [(Name, Expr)]
3953 | Ref Name
40− | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
41− | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
54+ | Access Expr Name -- foo.bar
55+ | Index Expr Expr -- foo[bar]
4256 | Prefix PrefixOp Expr
4357 | Infix InfixOp Expr Expr
4458 | If Expr Expr Expr
4559 | Assign LValue Expr
46− | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
60+ | Call Expr [Expr]
4761 | Function (Maybe Name) [Name] [Stmt]
4862
4963
@@ -58,20 +72,21 @@ data LValue
5872
5973
6074data Stmt
61− = Block [Stmt] -- {stmts}
62− | EmptyStmt -- ;
63− | ExprStmt Expr -- expr;
64− | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
65− | Switch Expr [Case] -- switch (e) clauses
66− | While Expr Stmt -- while (e) do stmt
67− | Break (Maybe Name) -- break lab;
68− | Continue (Maybe Name) -- continue lab;
69− | Labelled Name Stmt -- lab: stmt
70− | Try Stmt Name Stmt -- try stmt catch (x) stmt
71− | Throw Expr -- throw expr;
72− | Return (Maybe Expr) -- return expr;
73− | Var [(Name, Maybe Expr)] -- var x, y=42;
74− | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
75+ = Block [Stmt]
76+ | EmptyStmt
77+ | ExprStmt Expr
78+ | IfStmt Expr Stmt Stmt
79+ | Switch Expr [Case]
80+ | While Expr Stmt
81+ | Break (Maybe Name)
82+ | Continue (Maybe Name)
83+ | Labelled Name Stmt
84+ | Try Stmt Name Stmt
85+ | Throw Expr
86+ | Return Expr
87+ | Var Name Expr
88+ | Vars [(Name, Expr)]
89+ | FunctionStmt Name [Name] [Stmt]
7590
7691
7792data Case
@@ -84,37 +99,31 @@ data Case
8499
85100
86101data InfixOp
87− = OpLT -- <
88− | OpLEq -- <=
89− | OpGT -- >
90− | OpGEq -- >=
91− | OpIn -- in
92− | OpInstanceof -- instanceof
93− | OpEq -- ==
94− | OpNEq -- !=
95− | OpStrictEq -- ===
96− | OpStrictNEq -- !==
97− | OpLAnd -- &&
98− | OpLOr -- ||
102+ = OpAdd -- +
103+ | OpSub -- -
99104 | OpMul -- *
100105 | OpDiv -- /
101106 | OpMod -- %
102− | OpSub -- -
103− | OpLShift -- <<
104− | OpSpRShift -- >>
105− | OpZfRShift -- >>>
106− | OpBAnd -- &
107− | OpBXor -- ^
108− | OpBOr -- |
109− | OpAdd -- +
107+ | OpEq -- ===
108+ | OpNe -- !==
109+ | OpLt -- <
110+ | OpLe -- <=
111+ | OpGt -- >
112+ | OpGe -- >=
113+ | OpAnd -- &&
114+ | OpOr -- ||
115+ | OpBitwiseAnd -- &
116+ | OpBitwiseXor -- ^
117+ | OpBitwiseOr -- |
118+ | OpLShift -- <<
119+ | OpSpRShift -- >>
120+ | OpZfRShift -- >>>
110121
111122
112123data PrefixOp
113− = PrefixLNot -- !
114− | PrefixBNot -- ~
115− | PrefixPlus -- +
116− | PrefixMinus -- -
117− | PrefixTypeof -- typeof
124+ = PrefixNot -- !
125+ | PrefixNegate -- -
126+ | PrefixComplement -- ~
118127
119128
120129
@@ -123,21 +132,40 @@ data PrefixOp
123132
124133stmtToBuilder :: Stmt -> Builder
125134stmtToBuilder stmts =
126− fromStmt "" stmts
135+ fromStmt levelZero stmts
127136
128137
129138exprToBuilder :: Expr -> Builder
130139exprToBuilder expr =
131− snd $ fromExpr "" Whatever expr
140+ snd $ fromExpr levelZero Whatever expr
132141
133142
134143
135−-- HELPERS
144+-- INDENT LEVEL
145+
146+
147+data Level =
148+ Level Builder Level
149+
150+
151+levelZero :: Level
152+levelZero =
153+ Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
154+
155+
156+makeLevel :: Int -> BS.ByteString -> Level
157+makeLevel level oldTabs =
158+ let
159+ tabs =
160+ if level <= BS.length oldTabs
161+ then oldTabs
162+ else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
163+ in
164+ Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
165+
136166
137167
138−deeper :: Builder -> Builder
139−deeper indent =
140− "\t" <> indent
168+-- HELPERS
141169
142170
143171commaSep :: [Builder] -> Builder
@@ -145,52 +173,52 @@ commaSep builders =
145173 mconcat (List.intersperse ", " builders)
146174
147175
148−commaNewlineSep :: Builder -> [Builder] -> Builder
149−commaNewlineSep indent builders =
150− mconcat (List.intersperse (",\n" <> deeper indent) builders)
176+commaNewlineSep :: Level -> [Builder] -> Builder
177+commaNewlineSep (Level _ (Level deeperIndent _)) builders =
178+ mconcat (List.intersperse (",\n" <> deeperIndent) builders)
151179
152180
153181
154182-- STATEMENTS
155183
156184
157−fromStmtBlock :: Builder -> [Stmt] -> Builder
158−fromStmtBlock indent stmts =
159− mconcat (map (fromStmt indent) stmts)
185+fromStmtBlock :: Level -> [Stmt] -> Builder
186+fromStmtBlock level stmts =
187+ mconcat (map (fromStmt level) stmts)
160188
161189
162−fromStmt :: Builder -> Stmt -> Builder
163−fromStmt indent statement =
190+fromStmt :: Level -> Stmt -> Builder
191+fromStmt level@(Level indent nextLevel) statement =
164192 case statement of
165193 Block stmts ->
166− fromStmtBlock indent stmts
194+ fromStmtBlock level stmts
167195
168196 EmptyStmt ->
169197 mempty
170198
171199 ExprStmt expr ->
172− indent <> snd (fromExpr indent Whatever expr) <> ";\n"
200+ indent <> snd (fromExpr level Whatever expr) <> ";\n"
173201
174202 IfStmt condition thenStmt elseStmt ->
175203 mconcat
176− [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
177− , fromStmt (deeper indent) thenStmt
204+ [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
205+ , fromStmt nextLevel thenStmt
178206 , indent, "} else {\n"
179− , fromStmt (deeper indent) elseStmt
207+ , fromStmt nextLevel elseStmt
180208 , indent, "}\n"
181209 ]
182210
183211 Switch expr clauses ->
184212 mconcat
185− [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
186− , mconcat (map (fromClause (deeper indent)) clauses)
213+ [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
214+ , mconcat (map (fromClause nextLevel) clauses)
187215 , indent, "}\n"
188216 ]
189217
190218 While expr stmt ->
191219 mconcat
192− [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
193− , fromStmt (deeper indent) stmt
220+ [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
221+ , fromStmt nextLevel stmt
194222 , indent, "}\n"
195223 ]
196224
@@ -209,37 +237,37 @@ fromStmt indent statement =
209237 Labelled label stmt ->
210238 mconcat
211239 [ indent, Name.toBuilder label, ":\n"
212− , fromStmt indent stmt
240+ , fromStmt level stmt
213241 ]
214242
215243 Try tryStmt errorName catchStmt ->
216244 mconcat
217245 [ indent, "try {\n"
218− , fromStmt (deeper indent) tryStmt
246+ , fromStmt nextLevel tryStmt
219247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
220− , fromStmt (deeper indent) catchStmt
248+ , fromStmt nextLevel catchStmt
221249 , indent, "}\n"
222250 ]
223251
224252 Throw expr ->
225− "throw " <> snd (fromExpr indent Whatever expr) <> ";"
253+ indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
226254
227− Return Nothing ->
228− indent <> "return;\n"
255+ Return expr ->
256+ indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
229257
230− Return (Just expr) ->
231− indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
258+ Var name expr ->
259+ indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
232260
233− Var [] ->
261+ Vars [] ->
234262 mempty
235263
236− Var vars ->
237− indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
264+ Vars vars ->
265+ indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
238266
239267 FunctionStmt name args stmts ->
240268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
241269 <>
242− fromStmtBlock (deeper indent) stmts
270+ fromStmtBlock nextLevel stmts
243271 <>
244272 indent <> "}\n"
245273
@@ -248,30 +276,25 @@ fromStmt indent statement =
248276-- SWITCH CLAUSES
249277
250278
251−fromClause :: Builder -> Case -> Builder
252−fromClause indent clause =
279+fromClause :: Level -> Case -> Builder
280+fromClause level@(Level indent nextLevel) clause =
253281 case clause of
254282 Case expr stmts ->
255− indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
256− <> fromStmtBlock (deeper indent) stmts
283+ indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
284+ <> fromStmtBlock nextLevel stmts
257285
258286 Default stmts ->
259287 indent <> "default:\n"
260− <> fromStmtBlock (deeper indent) stmts
288+ <> fromStmtBlock nextLevel stmts
261289
262290
263291
264292-- VAR DECLS
265293
266294
267−varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
268−varToBuilder indent (name, maybeExpr) =
269− case maybeExpr of
270− Nothing ->
271− Name.toBuilder name
272−
273− Just expr ->
274− Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
295+varToBuilder :: Level -> (Name, Expr) -> Builder
296+varToBuilder level (name, expr) =
297+ Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
275298
276299
277300
@@ -289,12 +312,11 @@ merge a b =
289312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
290313linesMap func xs =
291314 let
292− pairs =
293− map func xs
315+ pairs = map func xs
294316 in
295− ( any ((==) Many . fst) pairs
296− , map snd pairs
297− )
317+ ( any ((==) Many . fst) pairs
318+ , map snd pairs
319+ )
298320
299321
300322data Grouping = Atomic | Whatever
@@ -310,23 +332,23 @@ parensFor grouping builder =
310332 builder
311333
312334
313−fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
314−fromExpr indent grouping expression =
335+fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
336+fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
315337 case expression of
316338 String string ->
317− (One, "'" <> string <> "'")
339+ ( One, "'" <> string <> "'" )
318340
319341 Float float ->
320− (One, float)
342+ ( One, float )
321343
322344 Int n ->
323− (One, B.intDec n)
345+ ( One, B.intDec n )
324346
325347 Bool bool ->
326− (One, if bool then "true" else "false")
348+ ( One, if bool then "true" else "false" )
327349
328350 Null ->
329− (One, "null")
351+ ( One, "null" )
330352
331353 Json json ->
332354 ( One, Json.encodeUgly json )
@@ -334,111 +356,90 @@ fromExpr indent grouping expression =
334356 Array exprs ->
335357 (,) Many $
336358 let
337− (anyMany, builders) =
338− linesMap (fromExpr indent Whatever) exprs
359+ (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
339360 in
340− if anyMany then
341− "[\n"
342− <> deeper indent
343− <> commaNewlineSep indent builders
344− <> "\n" <> indent <> "]"
345−
346− else
347− "[" <> commaSep builders <> "]"
361+ if anyMany then
362+ "[\n"
363+ <> deeperIndent
364+ <> commaNewlineSep level builders
365+ <> "\n" <> indent <> "]"
366+ else
367+ "[" <> commaSep builders <> "]"
348368
349369 Object fields ->
350370 (,) Many $
351371 let
352− deeperIndent =
353− deeper indent
354−
355− (anyMany, builders) =
356− linesMap (fromField deeperIndent) fields
372+ (anyMany, builders) = linesMap (fromField nextLevel) fields
357373 in
358− if anyMany then
359− "{\n"
360− <> deeperIndent
361− <> commaNewlineSep indent builders
362− <> "\n" <> indent <> "}"
363−
364− else
365− "{" <> commaSep builders <> "}"
374+ if anyMany then
375+ "{\n"
376+ <> deeperIndent
377+ <> commaNewlineSep level builders
378+ <> "\n" <> indent <> "}"
379+ else
380+ "{" <> commaSep builders <> "}"
366381
367382 Ref name ->
368− (One, Name.toBuilder name)
383+ ( One, Name.toBuilder name )
369384
370385 Access expr field ->
371− makeDot indent expr field
386+ makeDot level expr field
372387
373388 Index expr bracketedExpr ->
374− makeBracketed indent expr bracketedExpr
389+ makeBracketed level expr bracketedExpr
375390
376391 Prefix op expr ->
377392 let
378− (lines, builder) =
379− fromExpr indent Atomic expr
393+ (lines, builder) = fromExpr level Atomic expr
380394 in
381− ( lines
382− , parensFor grouping (fromPrefix op <> builder)
383− )
395+ ( lines
396+ , parensFor grouping (fromPrefix op <> builder)
397+ )
384398
385399 Infix op leftExpr rightExpr ->
386400 let
387− (leftLines, left) =
388− fromExpr indent Atomic leftExpr
389−
390− (rightLines, right) =
391− fromExpr indent Atomic rightExpr
401+ (leftLines , left ) = fromExpr level Atomic leftExpr
402+ (rightLines, right) = fromExpr level Atomic rightExpr
392403 in
393− ( merge leftLines rightLines
394− , parensFor grouping (left <> fromInfix op <> right)
395− )
404+ ( merge leftLines rightLines
405+ , parensFor grouping (left <> fromInfix op <> right)
406+ )
396407
397408 If condExpr thenExpr elseExpr ->
398409 let
399− condB = snd (fromExpr indent Atomic condExpr)
400− thenB = snd (fromExpr indent Atomic thenExpr)
401− elseB = snd (fromExpr indent Atomic elseExpr)
410+ condB = snd (fromExpr level Atomic condExpr)
411+ thenB = snd (fromExpr level Atomic thenExpr)
412+ elseB = snd (fromExpr level Atomic elseExpr)
402413 in
403− ( Many
404− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
405− )
414+ ( Many
415+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
416+ )
406417
407418 Assign lValue expr ->
408419 let
409− (leftLines, left) =
410− fromLValue indent lValue
411−
412− (rightLines, right) =
413− fromExpr indent Whatever expr
420+ (leftLines , left ) = fromLValue level lValue
421+ (rightLines, right) = fromExpr level Whatever expr
414422 in
415− ( merge leftLines rightLines
416− , parensFor grouping (left <> " = " <> right)
417− )
423+ ( merge leftLines rightLines
424+ , parensFor grouping (left <> " = " <> right)
425+ )
418426
419427 Call function args ->
420428 (,) Many $
421429 let
422− deeperIndent =
423− deeper indent
424−
425− funcB =
426− snd (fromExpr indent Atomic function)
427−
428− (anyMany, argsB) =
429− linesMap (fromExpr deeperIndent Whatever) args
430+ (_ , funcB) = fromExpr level Atomic function
431+ (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
430432 in
431− if anyMany then
432− funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
433−
434− else
435− funcB <> "(" <> commaSep argsB <> ")"
433+ if anyMany then
434+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
435+ else
436+ funcB <> "(" <> commaSep argsB <> ")"
436437
437438 Function maybeName args stmts ->
438439 (,) Many $
439440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
440441 <>
441− fromStmtBlock (deeper indent) stmts
442+ fromStmtBlock nextLevel stmts
442443 <>
443444 indent <> "}"
444445
@@ -447,55 +448,50 @@ fromExpr indent grouping expression =
447448-- FIELDS
448449
449450
450−fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
451−fromField indent (field, expr) =
451+fromField :: Level -> (Name, Expr) -> (Lines, Builder)
452+fromField level (field, expr) =
452453 let
453− (lines, builder) =
454− fromExpr indent Whatever expr
454+ (lines, builder) = fromExpr level Whatever expr
455455 in
456− ( lines
457− , Name.toBuilder field <> ": " <> builder
458− )
456+ ( lines
457+ , Name.toBuilder field <> ": " <> builder
458+ )
459459
460460
461461
462462-- VALUES
463463
464464
465−fromLValue :: Builder -> LValue -> (Lines, Builder)
466−fromLValue indent lValue =
465+fromLValue :: Level -> LValue -> (Lines, Builder)
466+fromLValue level lValue =
467467 case lValue of
468468 LRef name ->
469469 (One, Name.toBuilder name)
470470
471471 LDot expr field ->
472− makeDot indent expr field
472+ makeDot level expr field
473473
474474 LBracket expr bracketedExpr ->
475− makeBracketed indent expr bracketedExpr
475+ makeBracketed level expr bracketedExpr
476476
477477
478−makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
479−makeDot indent expr field =
478+makeDot :: Level -> Expr -> Name -> (Lines, Builder)
479+makeDot level expr field =
480480 let
481− (lines, builder) =
482− fromExpr indent Atomic expr
481+ (lines, builder) = fromExpr level Atomic expr
483482 in
484− (lines, builder <> "." <> Name.toBuilder field)
483+ (lines, builder <> "." <> Name.toBuilder field)
485484
486485
487−makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
488−makeBracketed indent expr bracketedExpr =
486+makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
487+makeBracketed level expr bracketedExpr =
489488 let
490− (lines, builder) =
491− fromExpr indent Atomic expr
492−
493− (bracketedLines, bracketedBuilder) =
494− fromExpr indent Whatever bracketedExpr
489+ (lines , builder ) = fromExpr level Atomic expr
490+ (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
495491 in
496− ( merge lines bracketedLines
497− , builder <> "[" <> bracketedBuilder <> "]"
498− )
492+ ( merge lines bracketedLines
493+ , builder <> "[" <> bracketedBuilder <> "]"
494+ )
499495
500496
501497
@@ -505,36 +501,30 @@ makeBracketed indent expr bracketedExpr =
505501fromPrefix :: PrefixOp -> Builder
506502fromPrefix op =
507503 case op of
508− PrefixLNot -> "!"
509− PrefixBNot -> "~"
510− PrefixPlus -> "+"
511− PrefixMinus -> "-"
512− PrefixTypeof -> "typeof "
504+ PrefixNot -> "!"
505+ PrefixNegate -> "-"
506+ PrefixComplement -> "~"
513507
514508
515509fromInfix :: InfixOp -> Builder
516510fromInfix op =
517511 case op of
518− OpLT -> " < "
519− OpLEq -> " <= "
520− OpGT -> " > "
521− OpGEq -> " >= "
522− OpIn -> " in "
523− OpInstanceof -> " instanceof "
524− OpEq -> " == "
525− OpNEq -> " != "
526− OpStrictEq -> " === "
527− OpStrictNEq -> " !== "
528− OpLAnd -> " && "
529− OpLOr -> " || "
512+ OpAdd -> " + "
513+ OpSub -> " - "
530514 OpMul -> " * "
531515 OpDiv -> " / "
532516 OpMod -> " % "
533− OpSub -> " - "
517+ OpEq -> " === "
518+ OpNe -> " !== "
519+ OpLt -> " < "
520+ OpLe -> " <= "
521+ OpGt -> " > "
522+ OpGe -> " >= "
523+ OpAnd -> " && "
524+ OpOr -> " || "
525+ OpBitwiseAnd -> " & "
526+ OpBitwiseXor -> " ^ "
527+ OpBitwiseOr -> " | "
534528 OpLShift -> " << "
535529 OpSpRShift -> " >> "
536530 OpZfRShift -> " >>> "
537− OpBAnd -> " & "
538− OpBXor -> " ^ "
539− OpBOr -> " | "
540− OpAdd -> " + "
compiler/src/Generate/JavaScript/Expression.hs+46−45
@@ -22,6 +22,7 @@ import qualified Data.Utf8 as Utf8
2222
2323import qualified AST.Canonical as Can
2424import qualified AST.Optimized as Opt
25+import qualified AST.Utils.Shader as Shader
2526import qualified Data.Index as Index
2627import qualified Elm.Compiler.Type as Type
2728import qualified Elm.Compiler.Type.Extract as Extract
@@ -32,6 +33,7 @@ import qualified Generate.JavaScript.Builder as JS
3233import qualified Generate.JavaScript.Name as JsName
3334import qualified Generate.Mode as Mode
3435import qualified Json.Encode as Encode
36+import Json.Encode ((==>))
3537import qualified Optimize.DecisionTree as DT
3638import qualified Reporting.Annotation as A
3739
@@ -128,8 +130,7 @@ generate mode expression =
128130
129131 Opt.Destruct (Opt.Destructor name path) body ->
130132 let
131− pathExpr = generatePath mode path
132− pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]
133+ pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
133134 in
134135 JsBlock $ pathDef : codeToStmtList (generate mode body)
135136
@@ -138,7 +139,7 @@ generate mode expression =
138139
139140 Opt.Accessor field ->
140141 JsExpr $ JS.Function Nothing [JsName.dollar]
141− [ JS.Return $ Just $
142+ [ JS.Return $
142143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
143144 ]
144145
@@ -190,7 +191,7 @@ generate mode expression =
190191 JS.Object (map toTranlation (Set.toList fields))
191192 in
192193 JsExpr $ JS.Object $
193− [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
194+ [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
194195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
195196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
196197 ]
@@ -211,7 +212,7 @@ codeToExpr code =
211212 JsExpr expr ->
212213 expr
213214
214− JsBlock [ JS.Return (Just expr) ] ->
215+ JsBlock [ JS.Return expr ] ->
215216 expr
216217
217218 JsBlock stmts ->
@@ -225,7 +226,7 @@ codeToStmtList code =
225226 stmts
226227
227228 JsExpr expr ->
228− [ JS.Return (Just expr) ]
229+ [ JS.Return expr ]
229230
230231 JsBlock stmts ->
231232 stmts
@@ -238,7 +239,7 @@ codeToStmt code =
238239 JS.Block stmts
239240
240241 JsExpr expr ->
241− JS.Return (Just expr)
242+ JS.Return expr
242243
243244 JsBlock [stmt] ->
244245 stmt
@@ -482,17 +483,17 @@ generateBitwiseCall home name args =
482483 case args of
483484 [arg] ->
484485 case name of
485− "complement" -> JS.Prefix JS.PrefixBNot arg
486+ "complement" -> JS.Prefix JS.PrefixComplement arg
486487 _ -> generateGlobalCall home name args
487488
488489 [left,right] ->
489490 case name of
490− "and" -> JS.Infix JS.OpBAnd left right
491− "or" -> JS.Infix JS.OpBOr left right
492− "xor" -> JS.Infix JS.OpBXor left right
493− "shiftLeftBy" -> JS.Infix JS.OpLShift right left
494− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
495− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
491+ "and" -> JS.Infix JS.OpBitwiseAnd left right
492+ "or" -> JS.Infix JS.OpBitwiseOr left right
493+ "xor" -> JS.Infix JS.OpBitwiseXor left right
494+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left
495+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
496+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
496497 _ -> generateGlobalCall home name args
497498
498499 _ ->
@@ -505,10 +506,10 @@ generateBasicsCall mode home name args =
505506 [elmArg] ->
506507 let arg = generateJsExpr mode elmArg in
507508 case name of
508− "not" -> JS.Prefix JS.PrefixLNot arg
509− "negate" -> JS.Prefix JS.PrefixMinus arg
509+ "not" -> JS.Prefix JS.PrefixNot arg
510+ "negate" -> JS.Prefix JS.PrefixNegate arg
510511 "toFloat" -> arg
511− "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
512+ "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
512513 _ -> generateGlobalCall home name [arg]
513514
514515 [elmLeft, elmRight] ->
@@ -528,16 +529,16 @@ generateBasicsCall mode home name args =
528529 "sub" -> JS.Infix JS.OpSub left right
529530 "mul" -> JS.Infix JS.OpMul left right
530531 "fdiv" -> JS.Infix JS.OpDiv left right
531− "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
532+ "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
532533 "eq" -> equal left right
533534 "neq" -> notEqual left right
534− "lt" -> cmp JS.OpLT JS.OpLT 0 left right
535− "gt" -> cmp JS.OpGT JS.OpGT 0 left right
536− "le" -> cmp JS.OpLEq JS.OpLT 1 left right
537− "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
538− "or" -> JS.Infix JS.OpLOr left right
539− "and" -> JS.Infix JS.OpLAnd left right
540− "xor" -> JS.Infix JS.OpStrictNEq left right
535+ "lt" -> cmp JS.OpLt JS.OpLt 0 left right
536+ "gt" -> cmp JS.OpGt JS.OpGt 0 left right
537+ "le" -> cmp JS.OpLe JS.OpLt 1 left right
538+ "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
539+ "or" -> JS.Infix JS.OpOr left right
540+ "and" -> JS.Infix JS.OpAnd left right
541+ "xor" -> JS.Infix JS.OpNe left right
541542 "remainderBy" -> JS.Infix JS.OpMod right left
542543 _ -> generateGlobalCall home name [left, right]
543544
@@ -558,7 +559,7 @@ notEqual left right =
558559 if isLiteral left || isLiteral right then
559560 strictNEq left right
560561 else
561− JS.Prefix JS.PrefixLNot $
562+ JS.Prefix JS.PrefixNot $
562563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
563564
564565
@@ -647,42 +648,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr
647648strictEq left right =
648649 case left of
649650 JS.Int 0 ->
650− JS.Prefix JS.PrefixLNot right
651+ JS.Prefix JS.PrefixNot right
651652
652653 JS.Bool bool ->
653− if bool then right else JS.Prefix JS.PrefixLNot right
654+ if bool then right else JS.Prefix JS.PrefixNot right
654655
655656 _ ->
656657 case right of
657658 JS.Int 0 ->
658− JS.Prefix JS.PrefixLNot left
659+ JS.Prefix JS.PrefixNot left
659660
660661 JS.Bool bool ->
661− if bool then left else JS.Prefix JS.PrefixLNot left
662+ if bool then left else JS.Prefix JS.PrefixNot left
662663
663664 _ ->
664− JS.Infix JS.OpStrictEq left right
665+ JS.Infix JS.OpEq left right
665666
666667
667668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
668669strictNEq left right =
669670 case left of
670671 JS.Int 0 ->
671− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)
672+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
672673
673674 JS.Bool bool ->
674− if bool then JS.Prefix JS.PrefixLNot right else right
675+ if bool then JS.Prefix JS.PrefixNot right else right
675676
676677 _ ->
677678 case right of
678679 JS.Int 0 ->
679− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)
680+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
680681
681682 JS.Bool bool ->
682− if bool then JS.Prefix JS.PrefixLNot left else left
683+ if bool then JS.Prefix JS.PrefixNot left else left
683684
684685 _ ->
685− JS.Infix JS.OpStrictNEq left right
686+ JS.Infix JS.OpNe left right
686687
687688
688689
@@ -695,13 +696,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm
695696generateTailCall mode name args =
696697 let
697698 toTempVars (argName, arg) =
698− ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )
699+ ( JsName.makeTemp argName, generateJsExpr mode arg )
699700
700701 toRealVars (argName, _) =
701702 JS.ExprStmt $
702703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
703704 in
704− JS.Var (map toTempVars args)
705+ JS.Vars (map toTempVars args)
705706 : map toRealVars args
706707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
707708
@@ -714,10 +715,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
714715generateDef mode def =
715716 case def of
716717 Opt.Def name body ->
717− JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]
718+ JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
718719
719720 Opt.TailDef name argNames body ->
720− JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
721+ JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
721722
722723
723724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
@@ -850,7 +851,7 @@ generateDecider mode label root decisionTree =
850851
851852 Opt.Chain testChain success failure ->
852853 [ JS.IfStmt
853− (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
854+ (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
854855 (JS.Block $ generateDecider mode label root success)
855856 (JS.Block $ generateDecider mode label root failure)
856857 ]
@@ -892,7 +893,7 @@ generateIfTest mode root (path, test) =
892893 value
893894
894895 DT.IsBool False ->
895− JS.Prefix JS.PrefixLNot value
896+ JS.Prefix JS.PrefixNot value
896897
897898 DT.IsInt int ->
898899 strictEq value (JS.Int int)
@@ -910,7 +911,7 @@ generateIfTest mode root (path, test) =
910911 JS.Access value (JsName.fromLocal "b")
911912
912913 DT.IsNil ->
913− JS.Prefix JS.PrefixLNot $
914+ JS.Prefix JS.PrefixNot $
914915 JS.Access value (JsName.fromLocal "b")
915916
916917 DT.IsTuple ->
@@ -1064,6 +1065,6 @@ toDebugMetadata mode msgType =
10641065
10651066 Mode.Dev (Just interfaces) ->
10661067 JS.Json $ Encode.object $
1067− [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1068− , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
1068+ [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1069+ , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
10691070 ]
compiler/src/Generate/JavaScript/Name.hs+22−12
@@ -62,19 +62,13 @@ fromLocal name =
6262
6363
6464fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
65−fromGlobal (ModuleName.Canonical (Pkg.Name author project) home) name =
66− Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
67− <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
68− <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
69− <> "$" <> Name.toBuilder name
65+fromGlobal home name =
66+ Name $ homeToBuilder home <> usd <> Name.toBuilder name
7067
7168
7269fromCycle :: ModuleName.Canonical -> Name.Name -> Name
73−fromCycle (ModuleName.Canonical (Pkg.Name author project) home) name =
74− Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
75− <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
76− <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
77− <> "$cyclic$" <> Name.toBuilder name
70+fromCycle home name =
71+ Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name
7872
7973
8074fromKernel :: Name.Name -> Name.Name -> Name
@@ -82,6 +76,17 @@ fromKernel home name =
8276 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
8377
8478
79+{-# INLINE homeToBuilder #-}
80+homeToBuilder :: ModuleName.Canonical -> B.Builder
81+homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =
82+ usd <>
83+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
84+ <> usd <>
85+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
86+ <> usd <>
87+ Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
88+
89+
8590
8691-- TEMPORARY NAMES
8792
@@ -98,7 +103,7 @@ makeA n =
98103
99104makeLabel :: Name.Name -> Int -> Name
100105makeLabel name index =
101− Name (Name.toBuilder name <> "$" <> B.intDec index)
106+ Name (Name.toBuilder name <> usd <> B.intDec index)
102107
103108
104109makeTemp :: Name.Name -> Name
@@ -108,7 +113,12 @@ makeTemp name =
108113
109114dollar :: Name
110115dollar =
111− Name (Name.toBuilder Name.dollar)
116+ Name usd
117+
118+
119+usd :: B.Builder
120+usd =
121+ Name.toBuilder Name.dollar
112122
113123
114124
compiler/src/Generate/Mode.hs−1
@@ -49,7 +49,6 @@ shortenFieldNames (Opt.GlobalGraph _ frequencies) =
4949
5050addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
5151addToBuckets field frequency buckets =
52− -- TODO try using an IntMap for buckets
5352 Map.insertWith (++) frequency [field] buckets
5453
5554
compiler/src/Json/Decode.hs+329−177
@@ -4,68 +4,110 @@ module Json.Decode
44 ( fromByteString
55 , Decoder
66 , string
7+ , customString
78 , bool
89 , int
9− , list, pair
10− , dict, pairs, field
10+ , list
11+ , nonEmptyList
12+ , pair
13+ --
14+ , KeyDecoder(..)
15+ , dict
16+ , pairs
17+ , field
18+ --
1119 , oneOf
1220 , failure
1321 , mapError
22+ --
23+ , Error(..)
24+ , Problem(..)
25+ , DecodeExpectation(..)
26+ , ParseError(..)
27+ , StringProblem(..)
1428 )
1529 where
1630
1731
18−import qualified Data.ByteString as B
19−import qualified Data.List as List
32+import qualified Data.ByteString.Internal as B
2033import qualified Data.Map as Map
21−import qualified Data.Utf8 as Utf8
22−import Data.Word (Word8, Word16)
34+import qualified Data.NonEmptyList as NE
35+import Data.Word (Word8)
2336import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
2438
39+import qualified Json.String as Json
2540import qualified Parse.Keyword as K
2641import qualified Parse.Primitives as P
27−import qualified Reporting.Error.Json as E
42+import Parse.Primitives (Row, Col)
43+import qualified Reporting.Annotation as A
2844
2945
3046
3147-- RUNNERS
3248
3349
34−fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
35−fromByteString decoder src =
36− fromAST decoder (P.fromByteString pFile src)
50+fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
51+fromByteString (Decoder decode) src =
52+ case P.fromByteString pFile BadEnd src of
53+ Right ast ->
54+ decode ast Right (Left . DecodeProblem src)
3755
38−
39−fromAST :: Decoder e a -> P.Result E.ParseError AST -> Either (E.Error e) a
40−fromAST (Decoder decode) parserResult =
41− case parserResult of
42− P.Ok ast _ ->
43− decode ast Right (Left . E.DecodeProblem)
44−
45− P.Err err ->
46− Left (E.ParseProblem err)
56+ Left problem ->
57+ Left (ParseProblem src problem)
4758
4859
4960
5061-- DECODERS
5162
5263
53−newtype Decoder e a =
64+newtype Decoder x a =
5465 Decoder
5566 (
5667 forall b.
5768 AST
5869 -> (a -> b)
59− -> (E.Problem e -> b)
70+ -> (Problem x -> b)
6071 -> b
6172 )
6273
6374
6475
76+-- ERRORS
77+
78+
79+data Error x
80+ = DecodeProblem B.ByteString (Problem x)
81+ | ParseProblem B.ByteString ParseError
82+
83+
84+
85+-- DECODE PROBLEMS
86+
87+
88+data Problem x
89+ = Field B.ByteString (Problem x)
90+ | Index Int (Problem x)
91+ | OneOf (Problem x) [Problem x]
92+ | Failure A.Region x
93+ | Expecting A.Region DecodeExpectation
94+
95+
96+data DecodeExpectation
97+ = TObject
98+ | TArray
99+ | TString
100+ | TBool
101+ | TInt
102+ | TObjectWith B.ByteString
103+ | TArrayPair Int
104+
105+
106+
65107-- INSTANCES
66108
67109
68−instance Functor (Decoder e) where
110+instance Functor (Decoder x) where
69111 {-# INLINE fmap #-}
70112 fmap func (Decoder decodeA) =
71113 Decoder $ \ast ok err ->
@@ -75,7 +117,7 @@ instance Functor (Decoder e) where
75117 decodeA ast ok' err
76118
77119
78−instance Applicative (Decoder e) where
120+instance Applicative (Decoder x) where
79121 {-# INLINE pure #-}
80122 pure = return
81123
@@ -92,7 +134,7 @@ instance Applicative (Decoder e) where
92134 decodeFunc ast okF err
93135
94136
95−instance Monad (Decoder e) where
137+instance Monad (Decoder x) where
96138 {-# INLINE return #-}
97139 return a =
98140 Decoder $ \_ ok _ ->
@@ -113,24 +155,37 @@ instance Monad (Decoder e) where
113155-- STRINGS
114156
115157
116−string :: Decoder e Utf8.String
158+string :: Decoder x Json.String
117159string =
118− Decoder $ \ast ok err ->
160+ Decoder $ \(A.At region ast) ok err ->
119161 case ast of
120− String bits ->
121− ok bits
162+ String snippet ->
163+ ok (Json.fromSnippet snippet)
122164
123165 _ ->
124− err (E.Expecting E.TString)
166+ err (Expecting region TString)
167+
168+
169+customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
170+customString parser toBadEnd =
171+ Decoder $ \(A.At region ast) ok err ->
172+ case ast of
173+ String snippet ->
174+ case P.fromSnippet parser toBadEnd snippet of
175+ Right a -> ok a
176+ Left x -> err (Failure region x)
177+
178+ _ ->
179+ err (Expecting region TString)
125180
126181
127182
128183-- BOOL
129184
130185
131−bool :: Decoder e Bool
186+bool :: Decoder x Bool
132187bool =
133− Decoder $ \ast ok err ->
188+ Decoder $ \(A.At region ast) ok err ->
134189 case ast of
135190 TRUE ->
136191 ok True
@@ -139,40 +194,40 @@ bool =
139194 ok False
140195
141196 _ ->
142− err (E.Expecting E.TBool)
197+ err (Expecting region TBool)
143198
144199
145200
146201-- INT
147202
148203
149−int :: Decoder e Int
204+int :: Decoder x Int
150205int =
151− Decoder $ \ast ok err ->
206+ Decoder $ \(A.At region ast) ok err ->
152207 case ast of
153208 Int n ->
154209 ok n
155210
156211 _ ->
157− err (E.Expecting E.TInt)
212+ err (Expecting region TInt)
158213
159214
160215
161−-- ARRAYS
216+-- LISTS
162217
163218
164−list :: Decoder e a -> Decoder e [a]
219+list :: Decoder x a -> Decoder x [a]
165220list decoder =
166− Decoder $ \ast ok err ->
221+ Decoder $ \(A.At region ast) ok err ->
167222 case ast of
168223 Array asts ->
169224 listHelp decoder ok err 0 asts []
170225
171226 _ ->
172− err (E.Expecting E.TArray)
227+ err (Expecting region TArray)
173228
174229
175−listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
230+listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
176231listHelp decoder@(Decoder decodeA) ok err !i asts revs =
177232 case asts of
178233 [] ->
@@ -180,24 +235,40 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
180235
181236 ast:asts ->
182237 let
183− ok' a = listHelp decoder ok err (i+1) asts (a:revs)
184− err' e = err (E.Index i e)
238+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)
239+ err' prob = err (Index i prob)
185240 in
186241 decodeA ast ok' err'
187242
188243
189−pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
244+
245+-- NON-EMPTY LISTS
246+
247+
248+nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
249+nonEmptyList decoder x =
250+ do values <- list decoder
251+ case values of
252+ v:vs -> return (NE.List v vs)
253+ [] -> failure x
254+
255+
256+
257+-- PAIR
258+
259+
260+pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
190261pair (Decoder decodeA) (Decoder decodeB) =
191− Decoder $ \ast ok err ->
262+ Decoder $ \(A.At region ast) ok err ->
192263 case ast of
193264 Array vs ->
194265 case vs of
195266 [astA,astB] ->
196267 let
197− err0 e = err (E.Index 0 e)
268+ err0 e = err (Index 0 e)
198269 ok0 a =
199270 let
200− err1 e = err (E.Index 1 e)
271+ err1 e = err (Index 1 e)
201272 ok1 b = ok (a,b)
202273 in
203274 decodeB astB ok1 err1
@@ -205,70 +276,103 @@ pair (Decoder decodeA) (Decoder decodeB) =
205276 decodeA astA ok0 err0
206277
207278 _ ->
208− err (E.Expecting (E.TArrayPair (length vs)))
279+ err (Expecting region (TArrayPair (length vs)))
209280
210281 _ ->
211− err (E.Expecting E.TArray)
282+ err (Expecting region TArray)
212283
213284
214285
215−-- OBJECT
286+-- OBJECTS
216287
217288
218−dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
219−dict decoder =
220− Map.fromList <$> pairs decoder
289+data KeyDecoder x a =
290+ KeyDecoder (P.Parser x a) (Row -> Col -> x)
221291
222292
223−pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
224−pairs decoder =
225− Decoder $ \ast ok err ->
293+dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
294+dict keyDecoder valueDecoder =
295+ Map.fromList <$> pairs keyDecoder valueDecoder
296+
297+
298+pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
299+pairs keyDecoder valueDecoder =
300+ Decoder $ \(A.At region ast) ok err ->
226301 case ast of
227302 Object kvs ->
228− pairsHelp decoder ok err kvs []
303+ pairsHelp keyDecoder valueDecoder ok err kvs []
229304
230305 _ ->
231− err (E.Expecting E.TObject)
306+ err (Expecting region TObject)
232307
233308
234−pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
235−pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
309+pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
310+pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
236311 case kvs of
237312 [] ->
238313 ok (reverse revs)
239314
240− (key, ast) : kvs ->
241− let
242− ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
243− err' e = err (E.Field key e)
244− in
245− decodeA ast ok' err'
315+ (snippet, ast) : kvs ->
316+ case P.fromSnippet keyParser toBadEnd snippet of
317+ Left x ->
318+ err (Failure (snippetToRegion snippet) x)
319+
320+ Right key ->
321+ let
322+ ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
323+ err' prob =
324+ let (P.Snippet fptr off len _ _) = snippet in
325+ err (Field (B.PS fptr off len) prob)
326+ in
327+ decodeA ast ok' err'
328+
246329
330+snippetToRegion :: P.Snippet -> A.Region
331+snippetToRegion (P.Snippet _ _ len row col) =
332+ A.Region (A.Position row col) (A.Position row (col + fromIntegral len))
247333
248−field :: Utf8.String -> Decoder e a -> Decoder e a
334+
335+
336+-- FIELDS
337+
338+
339+field :: B.ByteString -> Decoder x a -> Decoder x a
249340field key (Decoder decodeA) =
250− Decoder $ \ast ok err ->
341+ Decoder $ \(A.At region ast) ok err ->
251342 case ast of
252343 Object kvs ->
253− case List.lookup key kvs of
254− Just v ->
344+ case findField key kvs of
345+ Just value ->
255346 let
256− err' e = err (E.Field key e)
347+ err' prob =
348+ err (Field key prob)
257349 in
258− decodeA v ok err'
350+ decodeA value ok err'
259351
260352 Nothing ->
261− err (E.Expecting (E.TObjectWith key))
353+ err (Expecting region (TObjectWith key))
262354
263355 _ ->
264− err (E.Expecting E.TObject)
356+ err (Expecting region TObject)
357+
358+
359+findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
360+findField key pairs =
361+ case pairs of
362+ [] ->
363+ Nothing
364+
365+ (P.Snippet fptr off len _ _, value) : remainingPairs ->
366+ if key == B.PS fptr off len
367+ then Just value
368+ else findField key remainingPairs
265369
266370
267371
268372-- ONE OF
269373
270374
271−oneOf :: [Decoder e a] -> Decoder e a
375+oneOf :: [Decoder x a] -> Decoder x a
272376oneOf decoders =
273377 Decoder $ \ast ok err ->
274378 case decoders of
@@ -283,71 +387,75 @@ oneOf decoders =
283387 error "Ran into (Json.Decode.oneOf [])"
284388
285389
286−oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
287−oneOfHelp ast ok err decoders e es =
390+oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
391+oneOfHelp ast ok err decoders p ps =
288392 case decoders of
289393 Decoder decodeA : decoders ->
290394 let
291− err' e' =
292− oneOfHelp ast ok err decoders e' (e:es)
395+ err' p' =
396+ oneOfHelp ast ok err decoders p' (p:ps)
293397 in
294398 decodeA ast ok err'
295399
296400 [] ->
297− err (oneOfError [] e es)
401+ err (oneOfError [] p ps)
298402
299403
300−oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
301−oneOfError errors err es =
302− case es of
404+oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
405+oneOfError problems prob ps =
406+ case ps of
303407 [] ->
304− E.OneOf err errors
408+ OneOf prob problems
305409
306− e:es ->
307− oneOfError (err:errors) e es
410+ p:ps ->
411+ oneOfError (prob:problems) p ps
308412
309413
310414
311415-- FAILURE
312416
313417
314−failure :: e -> Decoder e a
315−failure e =
316− Decoder $ \_ _ err ->
317− err (E.Failure e)
418+failure :: x -> Decoder x a
419+failure x =
420+ Decoder $ \(A.At region _) _ err ->
421+ err (Failure region x)
318422
319423
320424
321425-- ERRORS
322426
323427
324−mapError :: (e -> e') -> Decoder e a -> Decoder e' a
428+mapError :: (x -> y) -> Decoder x a -> Decoder y a
325429mapError func (Decoder decodeA) =
326430 Decoder $ \ast ok err ->
327431 let
328− err' e = err (mapErrorHelp func e)
432+ err' prob = err (mapErrorHelp func prob)
329433 in
330434 decodeA ast ok err'
331435
332436
333−mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
334−mapErrorHelp func err =
335− case err of
336− E.Field k e -> E.Field k (mapErrorHelp func e)
337− E.Index i e -> E.Index i (mapErrorHelp func e)
338− E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
339− E.Failure e -> E.Failure (func e)
340− E.Expecting e -> E.Expecting e
437+mapErrorHelp :: (x -> y) -> Problem x -> Problem y
438+mapErrorHelp func problem =
439+ case problem of
440+ Field k p -> Field k (mapErrorHelp func p)
441+ Index i p -> Index i (mapErrorHelp func p)
442+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
443+ Failure r x -> Failure r (func x)
444+ Expecting r e -> Expecting r e
341445
342446
343447
344448-- AST
345449
346450
347−data AST
451+type AST =
452+ A.Located AST_
453+
454+
455+data AST_
348456 = Array [AST]
349− | Object [(Utf8.String, AST)]
350− | String Utf8.String
457+ | Object [(P.Snippet, AST)]
458+ | String P.Snippet
351459 | Int Int
352460 | TRUE
353461 | FALSE
@@ -359,7 +467,33 @@ data AST
359467
360468
361469type Parser a =
362− P.Parser E.ParseError a
470+ P.Parser ParseError a
471+
472+
473+data ParseError
474+ = Start Row Col
475+ | ObjectField Row Col
476+ | ObjectColon Row Col
477+ | ObjectEnd Row Col
478+ | ArrayEnd Row Col
479+ | StringProblem StringProblem Row Col
480+ | NoLeadingZeros Row Col
481+ | NoFloats Row Col
482+ | BadEnd Row Col
483+
484+-- PIndex Int ParseError Row Col
485+-- PField Json.String ParseError Row Col
486+
487+
488+data StringProblem
489+ = BadStringEnd
490+ | BadStringControlChar
491+ | BadStringEscapeChar
492+ | BadStringEscapeHex
493+
494+
495+
496+-- PARSE AST
363497
364498
365499pFile :: Parser AST
@@ -367,69 +501,60 @@ pFile =
367501 do spaces
368502 value <- pValue
369503 spaces
370− endOfFile
371504 return value
372505
373506
374507pValue :: Parser AST
375508pValue =
376− P.oneOf E.Value
377− [ fmap String pString
509+ P.addLocation $
510+ P.oneOf Start
511+ [ String <$> pString Start
378512 , pObject
379513 , pArray
380514 , pInt
381− , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
382− , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
383− , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
515+ , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
516+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
517+ , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
384518 ]
385519
386520
387−endOfFile :: Parser ()
388−endOfFile =
389− P.Parser $ \state@(P.State pos end _ row col) _ eok _ eerr ->
390− if pos < end then
391− eerr row col E.EndOfFile
392− else
393− eok () state
394−
395−
396521
397522-- OBJECT
398523
399524
400−pObject :: Parser AST
525+pObject :: Parser AST_
401526pObject =
402− do P.word1 0x7B {- { -} E.ObjectStart
527+ do P.word1 0x7B {- { -} Start
403528 spaces
404− P.oneOf E.ObjectMore
529+ P.oneOf ObjectField
405530 [ do entry <- pField
406531 spaces
407532 pObjectHelp [entry]
408− , do P.word1 0x7D {-}-} E.ObjectEnd
533+ , do P.word1 0x7D {-}-} ObjectEnd
409534 return (Object [])
410535 ]
411536
412537
413−pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
538+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
414539pObjectHelp revEntries =
415− P.oneOf E.ObjectMore
540+ P.oneOf ObjectEnd
416541 [
417− do P.word1 0x2C {-,-} E.ObjectMore
542+ do P.word1 0x2C {-,-} ObjectEnd
418543 spaces
419544 entry <- pField
420545 spaces
421546 pObjectHelp (entry:revEntries)
422547 ,
423− do P.word1 0x7D {-}-} E.ObjectEnd
548+ do P.word1 0x7D {-}-} ObjectEnd
424549 return (Object (reverse revEntries))
425550 ]
426551
427552
428−pField :: Parser (Utf8.String, AST)
553+pField :: Parser (P.Snippet, AST)
429554pField =
430− do key <- pString
555+ do key <- pString ObjectField
431556 spaces
432− P.word1 0x3A {-:-} E.Colon
557+ P.word1 0x3A {-:-} ObjectColon
433558 spaces
434559 value <- pValue
435560 return (key, value)
@@ -439,30 +564,30 @@ pField =
439564-- ARRAY
440565
441566
442−pArray :: Parser AST
567+pArray :: Parser AST_
443568pArray =
444− do P.word1 0x5B {-[-} E.ArrayStart
569+ do P.word1 0x5B {-[-} Start
445570 spaces
446− P.oneOf E.ArrayMore
571+ P.oneOf Start
447572 [ do entry <- pValue
448573 spaces
449574 pArrayHelp 1 [entry]
450− , do P.word1 0x5D {-]-} E.ArrayEnd
575+ , do P.word1 0x5D {-]-} ArrayEnd
451576 return (Array [])
452577 ]
453578
454579
455−pArrayHelp :: Int -> [AST] -> Parser AST
580+pArrayHelp :: Int -> [AST] -> Parser AST_
456581pArrayHelp !len revEntries =
457− P.oneOf E.ArrayMore
582+ P.oneOf ArrayEnd
458583 [
459− do P.word1 0x2C {-,-} E.ArrayMore
584+ do P.word1 0x2C {-,-} ArrayEnd
460585 spaces
461586 entry <- pValue
462587 spaces
463588 pArrayHelp (len + 1) (entry:revEntries)
464589 ,
465− do P.word1 0x5D {-]-} E.ArrayEnd
590+ do P.word1 0x5D {-]-} ArrayEnd
466591 return (Array (reverse revEntries))
467592 ]
468593
@@ -471,41 +596,44 @@ pArrayHelp !len revEntries =
471596-- STRING
472597
473598
474−pString :: Parser Utf8.String
475−pString =
476− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
599+pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
600+pString start =
601+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
477602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
478603
479604 let
480605 !pos1 = plusPtr pos 1
606+ !col1 = col + 1
481607
482608 (# status, newPos, newRow, newCol #) =
483− pStringHelp pos1 end row (col + 1)
609+ pStringHelp pos1 end row col1
484610 in
485611 case status of
486612 GoodString ->
487613 let
488− !newState = P.State newPos end indent newRow newCol
489− !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
614+ !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
615+ !len = minusPtr newPos pos1 - 1
616+ !snp = P.Snippet src off len row col1
617+ !newState = P.State src newPos end indent newRow newCol
490618 in
491− cok content newState
619+ cok snp newState
492620
493− BadStringEnd ->
494− cerr newRow newCol E.StringEnd
621+ BadString problem ->
622+ cerr newRow newCol (StringProblem problem)
495623
496624 else
497− eerr row col E.StringStart
625+ eerr row col start
498626
499627
500628data StringStatus
501629 = GoodString
502− | BadStringEnd
630+ | BadString StringProblem
503631
504632
505−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
633+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
506634pStringHelp pos end row col =
507635 if pos >= end then
508− (# BadStringEnd, pos, row, col #)
636+ (# BadString BadStringEnd, pos, row, col #)
509637
510638 else
511639 case P.unsafeIndex pos of
@@ -513,26 +641,50 @@ pStringHelp pos end row col =
513641 (# GoodString, plusPtr pos 1, row, col + 1 #)
514642
515643 0x0A {-\n-} ->
516− (# BadStringEnd, pos, row, col #)
644+ (# BadString BadStringEnd, pos, row, col #)
517645
518646 0x5C {-\-} ->
519− let
520− !pos1 = plusPtr pos 1
521− in
522− if pos1 < end then
523−
524− let
525− !word = P.unsafeIndex pos1
526− !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
527− in
528− pStringHelp newPos end row (col + 2)
529−
647+ let !pos1 = plusPtr pos 1 in
648+ if pos1 >= end then
649+ (# BadString BadStringEnd, pos1, row + 1, col #)
530650 else
531− (# BadStringEnd, pos1, row + 1, col #)
651+ case P.unsafeIndex pos1 of
652+ 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
653+ 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
654+ 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
655+ 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
656+ 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
657+ 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
658+ 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
659+ 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
660+ 0x75 {-u-} ->
661+ let !pos6 = plusPtr pos 6 in
662+ if pos6 <= end
663+ && isHex (P.unsafeIndex (plusPtr pos 2))
664+ && isHex (P.unsafeIndex (plusPtr pos 3))
665+ && isHex (P.unsafeIndex (plusPtr pos 4))
666+ && isHex (P.unsafeIndex (plusPtr pos 5))
667+ then
668+ pStringHelp pos6 end row (col + 6)
669+ else
670+ (# BadString BadStringEscapeHex, pos, row, col #)
671+
672+ _ ->
673+ (# BadString BadStringEscapeChar, pos, row, col #)
532674
533675 word ->
534− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
535− pStringHelp newPos end row (col + 1)
676+ if word < 0x20 then
677+ (# BadString BadStringControlChar, pos, row, col #)
678+ else
679+ let !newPos = plusPtr pos (P.getCharWidth word) in
680+ pStringHelp newPos end row (col + 1)
681+
682+
683+isHex :: Word8 -> Bool
684+isHex word =
685+ 0x30 {-0-} <= word && word <= 0x39 {-9-}
686+ || 0x61 {-a-} <= word && word <= 0x66 {-f-}
687+ || 0x41 {-A-} <= word && word <= 0x46 {-F-}
536688
537689
538690
@@ -541,7 +693,7 @@ pStringHelp pos end row col =
541693
542694spaces :: Parser ()
543695spaces =
544− P.Parser $ \state@(P.State pos end indent row col) cok eok _ _ ->
696+ P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
545697 let
546698 (# newPos, newRow, newCol #) =
547699 eatSpaces pos end row col
@@ -551,12 +703,12 @@ spaces =
551703 else
552704 let
553705 !newState =
554− P.State newPos end indent newRow newCol
706+ P.State src newPos end indent newRow newCol
555707 in
556708 cok () newState
557709
558710
559−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
711+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
560712eatSpaces pos end row col =
561713 if pos >= end then
562714 (# pos, row, col #)
@@ -575,29 +727,29 @@ eatSpaces pos end row col =
575727-- INTS
576728
577729
578−pInt :: Parser AST
730+pInt :: Parser AST_
579731pInt =
580− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
732+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
581733 if pos >= end then
582− eerr row col E.IntStart
734+ eerr row col Start
583735
584736 else
585737 let !word = P.unsafeIndex pos in
586738 if not (isDecimalDigit word) then
587− eerr row col E.IntStart
739+ eerr row col Start
588740
589741 else if word == 0x30 {-0-} then
590742
591743 let
592744 !pos1 = plusPtr pos 1
593− !newState = P.State pos1 end indent row (col + 1)
745+ !newState = P.State src pos1 end indent row (col + 1)
594746 in
595747 if pos1 < end then
596748 let !word1 = P.unsafeIndex pos1 in
597749 if isDecimalDigit word1 then
598− cerr row (col + 1) E.NoLeadingZeros
750+ cerr row (col + 1) NoLeadingZeros
599751 else if word1 == 0x2E {-.-} then
600− cerr row (col + 1) E.NoFloats
752+ cerr row (col + 1) NoFloats
601753 else
602754 cok (Int 0) newState
603755 else
@@ -614,12 +766,12 @@ pInt =
614766 GoodInt ->
615767 let
616768 !newState =
617− P.State newPos end indent row (col + len)
769+ P.State src newPos end indent row (col + len)
618770 in
619771 cok (Int n) newState
620772
621773 BadIntEnd ->
622− cerr row (col + len) E.NoFloats
774+ cerr row (col + len) NoFloats
623775
624776
625777data IntStatus = GoodInt | BadIntEnd
compiler/src/Json/Encode.hs+37−21
@@ -10,6 +10,7 @@ module Json.Encode
1010 , object
1111 , string
1212 , name
13+ , chars
1314 , bool
1415 , int
1516 , number
@@ -32,6 +33,7 @@ import qualified Data.Name as Name
3233import qualified Data.Utf8 as Utf8
3334
3435import qualified File
36+import qualified Json.String as Json
3537
3638
3739
@@ -40,7 +42,7 @@ import qualified File
4042
4143data Value
4244 = Array [Value]
43− | Object [(Utf8.String, Value)]
45+ | Object [(Json.String, Value)]
4446 | String B.Builder
4547 | Boolean Bool
4648 | Integer Int
@@ -53,14 +55,14 @@ array =
5355 Array
5456
5557
56−object :: [(Utf8.String,Value)] -> Value
58+object :: [(Json.String, Value)] -> Value
5759object =
5860 Object
5961
6062
61−string :: Utf8.String -> Value
63+string :: Json.String -> Value
6264string str =
63− String (encodeUtf8 str)
65+ String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')
6466
6567
6668name :: Name.Name -> Value
@@ -88,7 +90,7 @@ null =
8890 Null
8991
9092
91−dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value
93+dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value
9294dict encodeKey encodeValue pairs =
9395 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
9496
@@ -99,12 +101,35 @@ list encodeEntry entries =
99101
100102
101103
104+-- CHARS
105+
106+
107+chars :: [Char] -> Value -- PERF can this be done better? Look for examples.
108+chars chrs =
109+ String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')
110+
111+
112+escape :: [Char] -> [Char]
113+escape chrs =
114+ case chrs of
115+ [] ->
116+ []
117+
118+ c:cs
119+ | c == '\r' -> '\\' : 'r' : escape cs
120+ | c == '\n' -> '\\' : 'n' : escape cs
121+ | c == '\"' -> '\\' : '"' : escape cs
122+ | c == '\\' -> '\\' : '\\' : escape cs
123+ | otherwise -> c : escape cs
124+
125+
126+
102127-- HELPERS
103128
104129
105−(==>) :: a -> b -> (a, b)
106−(==>) a b =
107− (a, b)
130+(==>) :: [Char] -> value -> (Json.String, value)
131+(==>) key value =
132+ (Json.fromChars key, value)
108133
109134
110135
@@ -144,7 +169,7 @@ encodeUgly value =
144169 Object (first : rest) ->
145170 let
146171 encodeEntry char (key, entry) =
147− B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry
172+ B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry
148173 in
149174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
150175
@@ -205,15 +230,6 @@ encodeHelp indent value =
205230
206231
207232
208−-- ENCODE UTF-8
209−
210−
211−encodeUtf8 :: Utf8.String -> B.Builder
212−encodeUtf8 str =
213− B.char7 '"' <> Utf8.toBuilder str <> B.char7 '"'
214−
215−
216−
217233-- ENCODE ARRAY
218234
219235
@@ -236,7 +252,7 @@ arrayClose =
236252-- ENCODE OBJECT
237253
238254
239−encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder
255+encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder
240256encodeObject =
241257 encodeSequence objectOpen objectClose encodeField
242258
@@ -251,9 +267,9 @@ objectClose =
251267 B.char7 '}'
252268
253269
254−encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder
270+encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder
255271encodeField indent (key, value) =
256− encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value
272+ B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value
257273
258274
259275
compiler/src/Json/String.hsnew file+192
@@ -0,0 +1,192 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
3+module Json.String
4+ ( String
5+ , isEmpty
6+ --
7+ , fromPtr
8+ , fromName
9+ , fromChars
10+ , fromSnippet
11+ , fromComment
12+ --
13+ , toChars
14+ , toBuilder
15+ )
16+ where
17+
18+
19+import Prelude hiding (String)
20+import qualified Data.ByteString.Builder as B
21+import qualified Data.Coerce as Coerce
22+import qualified Data.Name as Name
23+import qualified Data.Utf8 as Utf8
24+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
25+import Data.Word (Word8)
26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
27+import Foreign.ForeignPtr (withForeignPtr)
28+import GHC.Exts (RealWorld)
29+import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)
30+import GHC.ST (ST)
31+
32+import qualified Parse.Primitives as P
33+
34+
35+
36+-- JSON STRINGS
37+
38+
39+-- INVARIANT: any Json.String is appropriately escaped already
40+-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
41+--
42+type String =
43+ Utf8.Utf8 JSON_STRING
44+
45+
46+data JSON_STRING
47+
48+
49+isEmpty :: String -> Bool
50+isEmpty =
51+ Utf8.isEmpty
52+
53+
54+
55+-- FROM
56+
57+
58+fromPtr :: Ptr Word8 -> Ptr Word8 -> String
59+fromPtr =
60+ Utf8.fromPtr
61+
62+
63+fromChars :: [Char] -> String
64+fromChars =
65+ Utf8.fromChars
66+
67+
68+fromSnippet :: P.Snippet -> String
69+fromSnippet =
70+ Utf8.fromSnippet
71+
72+
73+fromName :: Name.Name -> String
74+fromName =
75+ Coerce.coerce
76+
77+
78+
79+-- TO
80+
81+
82+toChars :: String -> [Char]
83+toChars =
84+ Utf8.toChars
85+
86+
87+{-# INLINE toBuilder #-}
88+toBuilder :: String -> B.Builder
89+toBuilder =
90+ Utf8.toBuilder
91+
92+
93+
94+-- FROM COMMENT
95+
96+
97+fromComment :: P.Snippet -> String
98+fromComment (P.Snippet fptr off len _ _) =
99+ unsafePerformIO $ withForeignPtr fptr $ \ptr ->
100+ let
101+ !pos = plusPtr ptr off
102+ !end = plusPtr pos len
103+ !str = fromChunks (chompChunks pos end pos [])
104+ in
105+ return str
106+
107+
108+chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
109+chompChunks pos end start revChunks =
110+ if pos >= end then
111+ reverse (addSlice start end revChunks)
112+ else
113+ let
114+ !word = P.unsafeIndex pos
115+ in
116+ case word of
117+ 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
118+ 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
119+ 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
120+ 0x0D {-\r-} ->
121+ let
122+ !newPos = plusPtr pos 1
123+ in
124+ chompChunks newPos end newPos (addSlice start pos revChunks)
125+
126+ _ ->
127+ let
128+ !width = P.getCharWidth word
129+ !newPos = plusPtr pos width
130+ in
131+ chompChunks newPos end start revChunks
132+
133+
134+chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
135+chompEscape escape pos end start revChunks =
136+ let
137+ !pos1 = plusPtr pos 1
138+ in
139+ chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)
140+
141+
142+addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
143+addSlice start end revChunks =
144+ if start == end
145+ then revChunks
146+ else Slice start (minusPtr end start) : revChunks
147+
148+
149+
150+-- FROM CHUNKS
151+
152+
153+data Chunk
154+ = Slice (Ptr Word8) Int
155+ | Escape Word8
156+
157+
158+fromChunks :: [Chunk] -> String
159+fromChunks chunks =
160+ unsafeDupablePerformIO (stToIO (
161+ do let !len = sum (map chunkToWidth chunks)
162+ mba <- newByteArray len
163+ writeChunks mba 0 chunks
164+ freeze mba
165+ ))
166+
167+
168+chunkToWidth :: Chunk -> Int
169+chunkToWidth chunk =
170+ case chunk of
171+ Slice _ len -> len
172+ Escape _ -> 2
173+
174+
175+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
176+writeChunks mba offset chunks =
177+ case chunks of
178+ [] ->
179+ return ()
180+
181+ chunk : chunks ->
182+ case chunk of
183+ Slice ptr len ->
184+ do copyFromPtr ptr mba offset len
185+ let !newOffset = offset + len
186+ writeChunks mba newOffset chunks
187+
188+ Escape word ->
189+ do writeWord8 mba offset 0x5C {- \ -}
190+ writeWord8 mba (offset + 1) word
191+ let !newOffset = offset + 2
192+ writeChunks mba newOffset chunks
compiler/src/Nitpick/PatternMatches.hs+4−4
@@ -22,11 +22,11 @@ import qualified Data.Map as Map
2222import qualified Data.Maybe as Maybe
2323import qualified Data.Name as Name
2424import qualified Data.NonEmptyList as NE
25−import qualified Data.Utf8 as Utf8
2625
2726import qualified AST.Canonical as Can
2827import qualified Data.Index as Index
2928import qualified Elm.ModuleName as ModuleName
29+import qualified Elm.String as ES
3030import qualified Reporting.Annotation as A
3131
3232
@@ -41,8 +41,8 @@ data Pattern
4141
4242
4343data Literal
44− = Chr Utf8.String
45− | Str Utf8.String
44+ = Chr ES.String
45+ | Str ES.String
4646 | Int Int
4747 deriving (Eq)
4848
@@ -204,7 +204,7 @@ data Context
204204
205205
206206check :: Can.Module -> Either (NE.List Error) ()
207−check (Can.Module _ _ decls _ _ _ _) =
207+check (Can.Module _ _ _ decls _ _ _ _) =
208208 case checkDecls decls [] of
209209 [] ->
210210 Right ()
compiler/src/Optimize/DecisionTree.hs+5−5
@@ -27,11 +27,11 @@ import qualified Data.List as List
2727import qualified Data.Maybe as Maybe
2828import qualified Data.Name as Name
2929import qualified Data.Set as Set
30−import qualified Data.Utf8 as Utf8
3130
3231import qualified AST.Canonical as Can
3332import qualified Data.Index as Index
3433import qualified Elm.ModuleName as ModuleName
34+import qualified Elm.String as ES
3535import qualified Reporting.Annotation as A
3636
3737
@@ -77,8 +77,8 @@ data Test
7777 | IsNil
7878 | IsTuple
7979 | IsInt Int
80− | IsChr Utf8.String
81− | IsStr Utf8.String
80+ | IsChr ES.String
81+ | IsStr ES.String
8282 | IsBool Bool
8383 deriving (Eq, Ord)
8484
@@ -618,7 +618,7 @@ instance Binary Test where
618618 5 -> liftM IsStr get
619619 6 -> liftM IsInt get
620620 7 -> liftM IsBool get
621− _ -> error "problem getting DecisionTree.Test binary"
621+ _ -> fail "problem getting DecisionTree.Test binary"
622622
623623
624624instance Binary Path where
@@ -634,4 +634,4 @@ instance Binary Path where
634634 0 -> liftM2 Index get get
635635 1 -> liftM Unbox get
636636 2 -> pure Empty
637− _ -> error "problem getting DecisionTree.Path binary"
637+ _ -> fail "problem getting DecisionTree.Path binary"
compiler/src/Optimize/Module.hs+4−4
@@ -41,7 +41,7 @@ type Annotations =
4141
4242
4343optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
44−optimize annotations (Can.Module home _ decls unions aliases _ effects) =
44+optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =
4545 addDecls home annotations decls $
4646 addEffects home effects $
4747 addUnions home unions $
@@ -213,10 +213,10 @@ findMain defs =
213213 def:rest ->
214214 case def of
215215 Can.Def (A.At region name) _ _ ->
216− if name == Name.main then Just region else findMain rest
216+ if name == Name._main then Just region else findMain rest
217217
218218 Can.TypedDef (A.At region name) _ _ _ _ ->
219− if name == Name.main then Just region else findMain rest
219+ if name == Name._main then Just region else findMain rest
220220
221221
222222defToName :: Can.Def -> Name.Name
@@ -244,7 +244,7 @@ addDef home annotations def graph =
244244
245245addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
246246addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
247− if name /= Name.main then
247+ if name /= Name._main then
248248 Result.ok (addDefNode home name args body Set.empty graph)
249249 else
250250 let
compiler/src/Optimize/Port.hs+3−3
@@ -58,7 +58,7 @@ toEncoder tipe =
5858 | name == Name.array -> encodeArray arg
5959
6060 _ ->
61− error "toEncoder: bad union type"
61+ error "toEncoder: bad custom type"
6262
6363 Can.TRecord _ (Just _) ->
6464 error "toEncoder: bad record"
@@ -68,7 +68,7 @@ toEncoder tipe =
6868 encodeField (name, Can.FieldType _ fieldType) =
6969 do encoder <- toEncoder fieldType
7070 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
71− return $ Opt.Tuple (Opt.Str (Name.toUtf8 name)) value Nothing
71+ return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing
7272 in
7373 do object <- encode "object"
7474 keyValuePairs <- traverse encodeField (Map.toList fields)
@@ -309,7 +309,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) =
309309 return $
310310 Opt.Call andThen
311311 [ Opt.Function [key] decoder
312− , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]
312+ , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]
313313 ]
314314
315315
compiler/src/Parse/Declaration.hs+18−19
@@ -20,7 +20,6 @@ import qualified Parse.Space as Space
2020import qualified Parse.Symbol as Symbol
2121import qualified Parse.Type as Type
2222import qualified Parse.Variable as Var
23−import Parse.Space (DocComment)
2423import Parse.Primitives hiding (State)
2524import qualified Parse.Primitives as P
2625import qualified Reporting.Annotation as A
@@ -32,10 +31,10 @@ import qualified Reporting.Error.Syntax as E
3231
3332
3433data Decl
35− = Value (Maybe DocComment) (A.Located Src.Value)
36− | Union (Maybe DocComment) (A.Located Src.Union)
37− | Alias (Maybe DocComment) (A.Located Src.Alias)
38− | Port (Maybe DocComment) Src.Port
34+ = Value (Maybe Src.Comment) (A.Located Src.Value)
35+ | Union (Maybe Src.Comment) (A.Located Src.Union)
36+ | Alias (Maybe Src.Comment) (A.Located Src.Alias)
37+ | Port (Maybe Src.Comment) Src.Port
3938
4039
4140declaration :: Space.Parser E.Decl Decl
@@ -53,7 +52,7 @@ declaration =
5352-- DOC COMMENT
5453
5554
56−chompDocComment :: Parser E.Decl (Maybe DocComment)
55+chompDocComment :: Parser E.Decl (Maybe Src.Comment)
5756chompDocComment =
5857 oneOfWithFallback
5958 [
@@ -70,7 +69,7 @@ chompDocComment =
7069
7170
7271{-# INLINE valueDecl #-}
73−valueDecl :: Maybe DocComment -> A.Position -> Space.Parser E.Decl Decl
72+valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
7473valueDecl maybeDocs start =
7574 do name <- Var.lower E.DeclStart
7675 end <- getPosition
@@ -81,7 +80,7 @@ valueDecl maybeDocs start =
8180 do word1 0x3A {-:-} E.DeclDefEquals
8281 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
8382 (tipe, _) <- specialize E.DeclDefType Type.expression
84− Space.checkFreshLine E.DeclDefFreshLineAfterType
83+ Space.checkFreshLine E.DeclDefNameRepeat
8584 defName <- chompMatchingName name
8685 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
8786 chompDefArgsAndBody maybeDocs start defName (Just tipe) []
@@ -90,7 +89,7 @@ valueDecl maybeDocs start =
9089 ]
9190
9291
93−chompDefArgsAndBody :: Maybe DocComment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
92+chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
9493chompDefArgsAndBody maybeDocs start name tipe revArgs =
9594 oneOf E.DeclDefEquals
9695 [ do arg <- specialize E.DeclDefArg Pattern.term
@@ -108,19 +107,19 @@ chompDefArgsAndBody maybeDocs start name tipe revArgs =
108107chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
109108chompMatchingName expectedName =
110109 let
111− (P.Parser parserL) = Var.lower (E.DeclDefNameRepeat expectedName)
110+ (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
112111 in
113− P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
112+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
114113 let
115− cokL name newState@(P.State _ _ _ er ec) =
114+ cokL name newState@(P.State _ _ _ _ er ec) =
116115 if expectedName == name
117116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
118− else cerr sr sc (E.DeclDefNameMatch expectedName name)
117+ else cerr sr sc (E.DeclDefNameMatch name)
119118
120− eokL name newState@(P.State _ _ _ er ec) =
119+ eokL name newState@(P.State _ _ _ _ er ec) =
121120 if expectedName == name
122121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
123− else eerr sr sc (E.DeclDefNameMatch expectedName name)
122+ else eerr sr sc (E.DeclDefNameMatch name)
124123 in
125124 parserL state cokL eokL cerr eerr
126125
@@ -130,7 +129,7 @@ chompMatchingName expectedName =
130129
131130
132131{-# INLINE typeDecl #-}
133−typeDecl :: Maybe DocComment -> A.Position -> Space.Parser E.Decl Decl
132+typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
134133typeDecl maybeDocs start =
135134 inContext E.DeclType (Keyword.type_ E.DeclStart) $
136135 do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
@@ -215,7 +214,7 @@ chompVariants variants end =
215214
216215
217216{-# INLINE portDecl #-}
218−portDecl :: Maybe DocComment -> Space.Parser E.Decl Decl
217+portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl
219218portDecl maybeDocs =
220219 inContext E.Port (Keyword.port_ E.DeclStart) $
221220 do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
@@ -236,7 +235,7 @@ portDecl maybeDocs =
236235
237236-- INVARIANT: always chomps to a freshline
238237--
239−infix_ :: Parser E.Module (A.Located Src.Binop)
238+infix_ :: Parser E.Module (A.Located Src.Infix)
240239infix_ =
241240 let
242241 err = E.Infix
@@ -264,4 +263,4 @@ infix_ =
264263 end <- getPosition
265264 Space.chomp _err
266265 Space.checkFreshLine err
267− return (A.at start end (Src.Binop op associativity precedence name))
266+ return (A.at start end (Src.Infix op associativity precedence name))
compiler/src/Parse/Docs.hsdeleted−275
@@ -1,275 +0,0 @@
1−module Parse.Docs
2− ( Docs(..)
3− , parser
4− )
5− where
6−
7−
8−
9−-- DOCS
10−
11−
12−data Docs =
13− Docs
14− { _exposed :: [A.Located Name.Name]
15− , _overview :: Utf8.String
16− , _listed :: [A.Located Name.Name]
17− , _comments :: Map.Map Name.Name Utf8.String
18− }
19−
20−
21−
22−-- PARSER
23−
24−
25−parser :: Parser Docs
26−parser =
27− error "TODO implement docs parser"
28−
29−
30−chompUntilDocs :: Parser Bool
31−chompUntilDocs =
32− P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33− let
34− (# isStart, newOffset, newRow, newCol #) =
35− eatDocs fp offset terminal row col
36−
37− !newState =
38− P.State fp newOffset terminal indent newRow newCol ctx
39− in
40− cok isStart newState
41−
42−
43−eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44−eatDocs fp offset terminal row col =
45− if offset >= terminal then
46− (# False, offset, row, col #)
47−
48− else if isDocsStart fp offset terminal then
49− (# True, offset + 5, row, col + 5 #)
50−
51− else
52− let !word = P.unsafeIndex fp offset in
53− if word == 0x0A {- \n -} then
54− eatDocs fp (offset + 1) terminal (row + 1) 1
55−
56− else
57− let !newOffset = offset + P.getCharWidth fp offset terminal word in
58− eatDocs fp newOffset terminal row (col + 1)
59−
60−
61−isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62−isDocsStart =
63− let (B.PS dfp doff dlen) = docsStart in
64− P.isSubstring dfp doff dlen
65−
66−
67−{-# NOINLINE docsStart #-}
68−docsStart :: B.ByteString
69−docsStart =
70− "@docs"
71−
72−
73−chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74−chompOverview names =
75− do isDocs <- chompUntilDocs
76− if isDocs
77− then chompOverviewHelp names
78− else return names
79−
80−
81−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82−chompOverviewHelp names =
83− do pos <- getPosition
84− (SPos spos) <- whitespace
85− if pos == spos
86− then chompOverview names
87− else chompOverview =<< chompDocs names
88−
89−
90−chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91−chompDocs names =
92− do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93− spos <- whitespace
94− oneOf SE.XXX
95− [ do checkSpace spos
96− word1 0x2C {-,-} SE.XXX
97− spaces
98− chompDocs (name:names)
99− , return (name:names)
100− ]
101−
102−
103−chompBinop :: Parser Name.Name
104−chompBinop =
105− do word1 0x28 {-(-} SE.XXX
106− name <- Symbol.binop
107− word1 0x29 {-)-} SE.XXX
108− return name
109−
110−
111−
112−
113−-- CHECK NAMES
114−
115−
116−type Result i w a =
117− Result.Result i w E.Error a
118−
119−
120−type Dups =
121− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122−
123−
124−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125−checkNames exports names =
126− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127− let overlap = Map.size (Map.intersection docs exports)
128− if Map.size exports == overlap && overlap == Map.size docs
129− then Result.ok ()
130− else
131− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133− Result.ok ()
134−
135−
136−addName :: Dups -> A.Located Name.Name -> Dups
137−addName dict (A.At region name) =
138− Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139−
140−
141−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142−isUnique name regions =
143− case regions of
144− OneOrMore.One region ->
145− Result.ok region
146−
147− OneOrMore.More _ _ ->
148− let (r1:r2:_) = OneOrMore.toList regions in
149− Result.throw (E.Duplicate name r1 r2)
150−
151−
152−onlyInDocs :: Name.Name -> A.Region -> Result i w a
153−onlyInDocs name region =
154− Result.throw $ E.OnlyInDocs name region
155−
156−
157−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158−onlyInExports name (A.At region _) =
159− Result.throw $ E.OnlyInExports name region
160−
161−
162−
163−-- CHECK EXPORTS
164−
165−
166−data Info =
167− Info
168− { _iComments :: Map.Map Name.Name Comment
169− , _iValues :: Types
170− , _iUnions :: Map.Map Name.Name Can.Union
171− , _iAliases :: Map.Map Name.Name Can.Alias
172− , _iBinops :: Map.Map Name.Name Can.Binop
173− , _iEffects :: Can.Effects
174− }
175−
176−
177−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178−checkExport info name (A.At region export) =
179− case export of
180− Can.ExportValue ->
181− do tipe <- getType name info
182− comment <- getComment region name info
183− Result.ok $ \m ->
184− m { _values = Map.insert name (Value comment tipe) (_values m) }
185−
186− Can.ExportBinop ->
187− do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188− tipe <- getType realName info
189− comment <- getComment region realName info
190− Result.ok $ \m ->
191− m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192−
193− Can.ExportAlias ->
194− do let (Can.Alias tvars tipe) = _iAliases info ! name
195− comment <- getComment region name info
196− Result.ok $ \m ->
197− m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198−
199− Can.ExportUnionOpen ->
200− do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201− comment <- getComment region name info
202− Result.ok $ \m ->
203− m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204−
205− Can.ExportUnionClosed ->
206− do let (Can.Union tvars _ _ _) = _iUnions info ! name
207− comment <- getComment region name info
208− Result.ok $ \m ->
209− m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210−
211− Can.ExportPort ->
212− do tipe <- getType name info
213− comment <- getComment region name info
214− Result.ok $ \m ->
215− m { _values = Map.insert name (Value comment tipe) (_values m) }
216−
217−
218−getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219−getComment region name info =
220− case Map.lookup name (_iComments info) of
221− Nothing ->
222− Result.throw (E.NoComment name region)
223−
224− Just comment ->
225− Result.ok comment
226−
227−
228−getType :: Name.Name -> Info -> Result i w Type.Type
229−getType name info =
230− case _iValues info ! name of
231− A.At defRegion Nothing ->
232− Result.throw (E.NoAnnotation name defRegion)
233−
234− A.At _ (Just tipe) ->
235− Result.ok (Extract.fromType tipe)
236−
237−
238−dector :: Can.Ctor -> (Name.Name, [Type.Type])
239−dector (Can.Ctor name _ _ args) =
240− ( name, map Extract.fromType args )
241−
242−
243−
244−-- GATHER TYPES
245−
246−
247−type Types =
248− Map.Map Name.Name (A.Located (Maybe Can.Type))
249−
250−
251−gatherTypes :: Can.Decls -> Types -> Types
252−gatherTypes decls types =
253− case decls of
254− Can.Declare def subDecls ->
255− gatherTypes subDecls (addDef types def)
256−
257− Can.DeclareRec defs subDecls ->
258− gatherTypes subDecls (List.foldl' addDef types defs)
259−
260− Can.SaveTheEnvironment ->
261− types
262−
263−
264−addDef :: Types -> Can.Def -> Types
265−addDef types def =
266− case def of
267− Can.Def (A.At region name) _ _ ->
268− Map.insert name (A.At region Nothing) types
269−
270− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271− let
272− tipe =
273− foldr Can.TLambda resultType (map snd typedArgs)
274− in
275− Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+57−45
@@ -16,7 +16,7 @@ import qualified Parse.Shader as Shader
1616import qualified Parse.Space as Space
1717import qualified Parse.Symbol as Symbol
1818import qualified Parse.Type as Type
19−import qualified Parse.Utf8 as Utf8
19+import qualified Parse.String as String
2020import qualified Parse.Variable as Var
2121import Parse.Primitives hiding (State)
2222import qualified Parse.Primitives as P
@@ -46,13 +46,13 @@ term =
4646
4747string :: A.Position -> Parser E.Expr Src.Expr
4848string start =
49− do str <- Utf8.string E.Start E.String
49+ do str <- String.string E.Start E.String
5050 addEnd start (Src.Str str)
5151
5252
5353character :: A.Position -> Parser E.Expr Src.Expr
5454character start =
55− do chr <- Utf8.character E.Start E.Char
55+ do chr <- String.character E.Start E.Char
5656 addEnd start (Src.Chr chr)
5757
5858
@@ -128,42 +128,53 @@ chompListEnd start entries =
128128tuple :: A.Position -> Parser E.Expr Src.Expr
129129tuple start@(A.Position row col) =
130130 inContext E.Tuple (word1 0x28 {-(-} E.Start) $
131− oneOf E.TupleOpen
132− [
133− do op <- Symbol.operator E.TupleOpen E.TupleOperatorReserved
134− if op == "-"
135− then
136− oneOf E.TupleOperatorClose
137− [
138− do word1 0x29 {-)-} E.TupleOperatorClose
139− addEnd start (Src.Op op)
140− ,
141− specialize E.TupleExpr $
142− do negatedExpr@(A.At (A.Region _ end) _) <- term
143− Space.chomp E.Space
144− let exprStart = A.Position row (col + 2)
145− let expr = A.at exprStart end (Src.Negate negatedExpr)
146− fst <$> chompExprEnd exprStart (State [] expr [] end)
147− ]
148− else
149− do word1 0x29 {-)-} E.TupleOperatorClose
150− addEnd start (Src.Op op)
151− ,
152− do word1 0x29 {-)-} E.TupleOpen
153− addEnd start Src.Unit
154− ,
155− do Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr
156− (entry, end) <- specialize E.TupleExpr expression
157− Space.checkIndent end E.TupleIndentEnd
158− chompTupleEnd start entry []
159− ]
131+ do before <- getPosition
132+ Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
133+ after <- getPosition
134+ if before /= after
135+ then
136+ do (entry, end) <- specialize E.TupleExpr expression
137+ Space.checkIndent end E.TupleIndentEnd
138+ chompTupleEnd start entry []
139+ else
140+ oneOf E.TupleIndentExpr1
141+ [
142+ do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
143+ if op == "-"
144+ then
145+ oneOf E.TupleOperatorClose
146+ [
147+ do word1 0x29 {-)-} E.TupleOperatorClose
148+ addEnd start (Src.Op op)
149+ ,
150+ do (entry, end) <-
151+ specialize E.TupleExpr $
152+ do negatedExpr@(A.At (A.Region _ end) _) <- term
153+ Space.chomp E.Space
154+ let exprStart = A.Position row (col + 2)
155+ let expr = A.at exprStart end (Src.Negate negatedExpr)
156+ chompExprEnd exprStart (State [] expr [] end)
157+ Space.checkIndent end E.TupleIndentEnd
158+ chompTupleEnd start entry []
159+ ]
160+ else
161+ do word1 0x29 {-)-} E.TupleOperatorClose
162+ addEnd start (Src.Op op)
163+ ,
164+ do word1 0x29 {-)-} E.TupleIndentExpr1
165+ addEnd start Src.Unit
166+ ,
167+ do (entry, end) <- specialize E.TupleExpr expression
168+ Space.checkIndent end E.TupleIndentEnd
169+ chompTupleEnd start entry []
170+ ]
160171
161172
162173chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
163174chompTupleEnd start firstExpr revExprs =
164175 oneOf E.TupleEnd
165176 [ do word1 0x2C {-,-} E.TupleEnd
166− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr
177+ Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN
167178 (entry, end) <- specialize E.TupleExpr expression
168179 Space.checkIndent end E.TupleIndentEnd
169180 chompTupleEnd start firstExpr (entry : revExprs)
@@ -213,7 +224,7 @@ chompFields :: [Field] -> Parser E.Record [Field]
213224chompFields fields =
214225 oneOf E.RecordEnd
215226 [ do word1 0x2C {-,-} E.RecordEnd
216− Space.chompAndCheckIndent E.RecordSpace E.RecordField
227+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
217228 f <- chompField
218229 chompFields (f : fields)
219230 , do word1 0x7D {-}-} E.RecordEnd
@@ -264,16 +275,16 @@ chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr
264275chompExprEnd start (State ops expr args end) =
265276 oneOfWithFallback
266277 [ -- argument
267− do Space.checkIndent end E.IndentMoreExpr
278+ do Space.checkIndent end E.Start
268279 arg <- term
269280 newEnd <- getPosition
270281 Space.chomp E.Space
271282 chompExprEnd start (State ops expr (arg:args) newEnd)
272283
273284 , -- operator
274− do Space.checkIndent end E.IndentMoreExpr
285+ do Space.checkIndent end E.Start
275286 op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
276− Space.chompAndCheckIndent E.Space E.IndentOperatorRight
287+ Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
277288 newStart <- getPosition
278289 if "-" == opName && end /= opStart && opEnd == newStart
279290 then
@@ -284,7 +295,8 @@ chompExprEnd start (State ops expr args end) =
284295 let arg = A.at opStart newEnd (Src.Negate negatedExpr)
285296 chompExprEnd start (State ops expr (arg:args) newEnd)
286297 else
287− oneOf E.OperatorRight
298+ let err = E.OperatorRight opName in
299+ oneOf err
288300 [ -- term
289301 do newExpr <- possiblyNegativeTerm newStart
290302 newEnd <- getPosition
@@ -294,7 +306,7 @@ chompExprEnd start (State ops expr args end) =
294306
295307 , -- final term
296308 do (newLast, newEnd) <-
297− oneOf E.OperatorRight
309+ oneOf err
298310 [ let_ newStart
299311 , case_ newStart
300312 , if_ newStart
@@ -531,19 +543,19 @@ chompDefArgsAndBody start name tipe revArgs =
531543chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
532544chompMatchingName expectedName =
533545 let
534− (P.Parser parserL) = Var.lower (E.DefNameRepeat expectedName)
546+ (P.Parser parserL) = Var.lower E.DefNameRepeat
535547 in
536− P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
548+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
537549 let
538− cokL name newState@(P.State _ _ _ er ec) =
550+ cokL name newState@(P.State _ _ _ _ er ec) =
539551 if expectedName == name
540552 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
541− else cerr sr sc (E.DefNameMatch expectedName name)
553+ else cerr sr sc (E.DefNameMatch name)
542554
543− eokL name newState@(P.State _ _ _ er ec) =
555+ eokL name newState@(P.State _ _ _ _ er ec) =
544556 if expectedName == name
545557 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
546− else eerr sr sc (E.DefNameMatch expectedName name)
558+ else eerr sr sc (E.DefNameMatch name)
547559 in
548560 parserL state cokL eokL cerr eerr
549561
compiler/src/Parse/Keyword.hs+16−16
@@ -120,7 +120,7 @@ command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx
120120
121121subscription_ :: (Row -> Col -> x) -> Parser x ()
122122subscription_ toError =
123− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
123+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
124124 let !pos12 = plusPtr pos 12 in
125125 if pos12 <= end
126126 && P.unsafeIndex ( pos ) == 0x73
@@ -137,7 +137,7 @@ subscription_ toError =
137137 && P.unsafeIndex (plusPtr pos 11) == 0x6E
138138 && Var.getInnerWidth pos12 end == 0
139139 then
140− let !s = P.State pos12 end indent row (col + 12) in cok () s
140+ let !s = P.State src pos12 end indent row (col + 12) in cok () s
141141 else
142142 eerr row col toError
143143
@@ -148,21 +148,21 @@ subscription_ toError =
148148
149149k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
150150k2 w1 w2 toError =
151− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
151+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
152152 let !pos2 = plusPtr pos 2 in
153153 if pos2 <= end
154154 && P.unsafeIndex ( pos ) == w1
155155 && P.unsafeIndex (plusPtr pos 1) == w2
156156 && Var.getInnerWidth pos2 end == 0
157157 then
158− let !s = P.State pos2 end indent row (col + 2) in cok () s
158+ let !s = P.State src pos2 end indent row (col + 2) in cok () s
159159 else
160160 eerr row col toError
161161
162162
163163k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
164164k3 w1 w2 w3 toError =
165− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
165+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
166166 let !pos3 = plusPtr pos 3 in
167167 if pos3 <= end
168168 && P.unsafeIndex ( pos ) == w1
@@ -170,14 +170,14 @@ k3 w1 w2 w3 toError =
170170 && P.unsafeIndex (plusPtr pos 2) == w3
171171 && Var.getInnerWidth pos3 end == 0
172172 then
173− let !s = P.State pos3 end indent row (col + 3) in cok () s
173+ let !s = P.State src pos3 end indent row (col + 3) in cok () s
174174 else
175175 eerr row col toError
176176
177177
178178k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
179179k4 w1 w2 w3 w4 toError =
180− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
180+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
181181 let !pos4 = plusPtr pos 4 in
182182 if pos4 <= end
183183 && P.unsafeIndex ( pos ) == w1
@@ -186,14 +186,14 @@ k4 w1 w2 w3 w4 toError =
186186 && P.unsafeIndex (plusPtr pos 3) == w4
187187 && Var.getInnerWidth pos4 end == 0
188188 then
189− let !s = P.State pos4 end indent row (col + 4) in cok () s
189+ let !s = P.State src pos4 end indent row (col + 4) in cok () s
190190 else
191191 eerr row col toError
192192
193193
194194k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
195195k5 w1 w2 w3 w4 w5 toError =
196− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
196+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
197197 let !pos5 = plusPtr pos 5 in
198198 if pos5 <= end
199199 && P.unsafeIndex ( pos ) == w1
@@ -203,14 +203,14 @@ k5 w1 w2 w3 w4 w5 toError =
203203 && P.unsafeIndex (plusPtr pos 4) == w5
204204 && Var.getInnerWidth pos5 end == 0
205205 then
206− let !s = P.State pos5 end indent row (col + 5) in cok () s
206+ let !s = P.State src pos5 end indent row (col + 5) in cok () s
207207 else
208208 eerr row col toError
209209
210210
211211k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
212212k6 w1 w2 w3 w4 w5 w6 toError =
213− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
213+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
214214 let !pos6 = plusPtr pos 6 in
215215 if pos6 <= end
216216 && P.unsafeIndex ( pos ) == w1
@@ -221,14 +221,14 @@ k6 w1 w2 w3 w4 w5 w6 toError =
221221 && P.unsafeIndex (plusPtr pos 5) == w6
222222 && Var.getInnerWidth pos6 end == 0
223223 then
224− let !s = P.State pos6 end indent row (col + 6) in cok () s
224+ let !s = P.State src pos6 end indent row (col + 6) in cok () s
225225 else
226226 eerr row col toError
227227
228228
229229k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
230230k7 w1 w2 w3 w4 w5 w6 w7 toError =
231− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
231+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
232232 let !pos7 = plusPtr pos 7 in
233233 if pos7 <= end
234234 && P.unsafeIndex ( pos ) == w1
@@ -240,14 +240,14 @@ k7 w1 w2 w3 w4 w5 w6 w7 toError =
240240 && P.unsafeIndex (plusPtr pos 6) == w7
241241 && Var.getInnerWidth pos7 end == 0
242242 then
243− let !s = P.State pos7 end indent row (col + 7) in cok () s
243+ let !s = P.State src pos7 end indent row (col + 7) in cok () s
244244 else
245245 eerr row col toError
246246
247247
248248k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
249249k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
250− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
250+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
251251 let !pos8 = plusPtr pos 8 in
252252 if pos8 <= end
253253 && P.unsafeIndex ( pos ) == w1
@@ -260,6 +260,6 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
260260 && P.unsafeIndex (plusPtr pos 7) == w8
261261 && Var.getInnerWidth pos8 end == 0
262262 then
263− let !s = P.State pos8 end indent row (col + 8) in cok () s
263+ let !s = P.State src pos8 end indent row (col + 8) in cok () s
264264 else
265265 eerr row col toError
compiler/src/Parse/Module.hs+238−187
@@ -2,9 +2,10 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Parse.Module
44 ( fromByteString
5− , Header(..)
6− , Effects(..)
5+ , ProjectType(..)
6+ , isKernel
77 , chompImports
8+ , chompImport
89 )
910 where
1011
@@ -30,102 +31,111 @@ import qualified Reporting.Error.Syntax as E
3031-- FROM BYTE STRING
3132
3233
33−fromByteString :: Pkg.Name -> BS.ByteString -> Either E.Error Src.Module
34−fromByteString pkg source =
35− let
36− parser
37− | pkg == Pkg.core = core
38− | Pkg.isKernel pkg = platform
39− | otherwise = normal
40− in
41− case P.fromByteString parser source of
42− P.Ok outcome _ ->
43− case outcome of
44− Right modul -> Right modul
45− Left err -> Left err
34+fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module
35+fromByteString projectType source =
36+ case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of
37+ Right modul -> checkModule projectType modul
38+ Left err -> Left (E.ParseError err)
4639
47− P.Err err ->
48− Left (E.ParseError err)
4940
5041
42+-- PROJECT TYPE
5143
52−-- MODULE
5344
45+data ProjectType
46+ = Package Pkg.Name
47+ | Application
5448
55−normal :: Parser E.Module (Either E.Error Src.Module)
56−normal =
57− do freshLine E.FreshLineModuleStart
58− header <- chompHeader
59− comment <- chompModuleDocComment
60− imports <- chompImports []
61− decls <- specialize E.Declarations $ chompDecls []
62− endOfFile
63− return (checkModule header comment (Imports.addDefaults imports) [] decls)
6449
50+isCore :: ProjectType -> Bool
51+isCore projectType =
52+ case projectType of
53+ Package pkg -> pkg == Pkg.core
54+ Application -> False
6555
66−core :: Parser E.Module (Either E.Error Src.Module)
67−core =
68− do freshLine E.FreshLineModuleStart
69− header <- chompHeader
70− comment <- chompModuleDocComment
71− imports <- chompImports []
72− binops <- chompBinops []
73− decls <- specialize E.Declarations $ chompDecls []
74− endOfFile
75− return (checkModule header comment imports binops decls)
56+
57+isKernel :: ProjectType -> Bool
58+isKernel projectType =
59+ case projectType of
60+ Package pkg -> Pkg.isKernel pkg
61+ Application -> False
7662
7763
78−platform :: Parser E.Module (Either E.Error Src.Module)
79−platform =
80− do freshLine E.FreshLineModuleStart
81− header <- chompHeader
82− comment <- chompModuleDocComment
83− imports <- chompImports []
84− binops <- chompBinops []
64+
65+-- MODULE
66+
67+
68+data Module =
69+ Module
70+ { _header :: Maybe Header
71+ , _imports :: [Src.Import]
72+ , _infixes :: [A.Located Src.Infix]
73+ , _decls :: [Decl.Decl]
74+ }
75+
76+
77+chompModule :: ProjectType -> Parser E.Module Module
78+chompModule projectType =
79+ do header <- chompHeader
80+ imports <- chompImports (if isCore projectType then [] else Imports.defaults)
81+ infixes <- if isKernel projectType then chompInfixes [] else return []
8582 decls <- specialize E.Declarations $ chompDecls []
86− endOfFile
87− return (checkModule header comment (Imports.addDefaults imports) binops decls)
83+ return (Module header imports infixes decls)
8884
8985
9086
9187-- CHECK MODULE
9288
9389
94−checkModule :: Maybe Header -> Maybe Space.DocComment -> [Src.Import] -> [A.Located Src.Binop] -> [Decl.Decl] -> Either E.Error Src.Module
95−checkModule maybeHeader _maybeDocs imports binops decls =
90+checkModule :: ProjectType -> Module -> Either E.Error Src.Module
91+checkModule projectType (Module maybeHeader imports infixes decls) =
9692 let
9793 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
9894 in
9995 case maybeHeader of
100− Just (Header name effects exports) ->
101− Src.Module (Just name) exports imports values unions aliases binops
102− <$> checkEffects ports effects
96+ Just (Header name effects exports docs) ->
97+ Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
98+ <$> checkEffects projectType ports effects
10399
104100 Nothing ->
105101 Right $
106− Src.Module Nothing (A.At A.one Src.Open) imports values unions aliases binops $
102+ Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $
107103 case ports of
108104 [] -> Src.NoEffects
109105 _:_ -> Src.Ports ports
110106
111107
112−checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects
113−checkEffects ports effects =
108+checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
109+checkEffects projectType ports effects =
114110 case effects of
115111 NoEffects region ->
116112 case ports of
117− [] -> Right Src.NoEffects
118− _:_ -> Left (E.UnexpectedPort region)
113+ [] ->
114+ Right Src.NoEffects
115+
116+ Src.Port name _ : _ ->
117+ case projectType of
118+ Package _ -> Left (E.NoPortsInPackage name)
119+ Application -> Left (E.UnexpectedPort region)
119120
120121 Ports region ->
121− case ports of
122− [] -> Left (E.NoPorts region)
123− _:_ -> Right (Src.Ports ports)
122+ case projectType of
123+ Package _ ->
124+ Left (E.NoPortModulesInPackage region)
125+
126+ Application ->
127+ case ports of
128+ [] -> Left (E.NoPorts region)
129+ _:_ -> Right (Src.Ports ports)
124130
125131 Manager region manager ->
126− case ports of
127− [] -> Right (Src.Manager region manager)
128− _:_ -> Left (E.UnexpectedPort region)
132+ if isKernel projectType then
133+ case ports of
134+ [] -> Right (Src.Manager region manager)
135+ _:_ -> Left (E.UnexpectedPort region)
136+ else
137+ Left (E.NoEffectsOutsideKernel region)
138+
129139
130140
131141categorizeDecls :: [A.Located Src.Value] -> [A.Located Src.Union] -> [A.Located Src.Alias] -> [Src.Port] -> [Decl.Decl] -> ( [A.Located Src.Value], [A.Located Src.Union], [A.Located Src.Alias], [Src.Port] )
@@ -143,6 +153,41 @@ categorizeDecls values unions aliases ports decls =
143153
144154
145155
156+-- TO DOCS
157+
158+
159+toDocs :: Either A.Region Src.Comment -> [Decl.Decl] -> Src.Docs
160+toDocs comment decls =
161+ case comment of
162+ Right overview ->
163+ Src.YesDocs overview (getComments decls [])
164+
165+ Left region ->
166+ Src.NoDocs region
167+
168+
169+getComments :: [Decl.Decl] -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]
170+getComments decls comments =
171+ case decls of
172+ [] ->
173+ comments
174+
175+ decl:otherDecls ->
176+ case decl of
177+ Decl.Value c (A.At _ (Src.Value n _ _ _)) -> getComments otherDecls (addComment c n comments)
178+ Decl.Union c (A.At _ (Src.Union n _ _ )) -> getComments otherDecls (addComment c n comments)
179+ Decl.Alias c (A.At _ (Src.Alias n _ _ )) -> getComments otherDecls (addComment c n comments)
180+ Decl.Port c (Src.Port n _ ) -> getComments otherDecls (addComment c n comments)
181+
182+
183+addComment :: Maybe Src.Comment -> A.Located Name.Name -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]
184+addComment maybeComment (A.At _ name) comments =
185+ case maybeComment of
186+ Just comment -> (name, comment) : comments
187+ Nothing -> comments
188+
189+
190+
146191-- FRESH LINES
147192
148193
@@ -152,15 +197,6 @@ freshLine toFreshLineError =
152197 Space.checkFreshLine toFreshLineError
153198
154199
155−endOfFile :: Parser E.Module ()
156−endOfFile =
157− P.Parser $ \state@(P.State pos end _ row col) _ eok _ eerr ->
158− if pos < end then
159− eerr row col E.ModuleEndOfFile
160− else
161− eok () state
162−
163−
164200
165201-- CHOMP DECLARATIONS
166202
@@ -169,35 +205,36 @@ chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]
169205chompDecls decls =
170206 do (decl, _) <- Decl.declaration
171207 oneOfWithFallback
172− [ do Space.checkFreshLine E.DeclFreshLineStart
208+ [ do Space.checkFreshLine E.DeclStart
173209 chompDecls (decl:decls)
174210 ]
175211 (reverse (decl:decls))
176212
177213
178−chompBinops :: [A.Located Src.Binop] -> Parser E.Module [A.Located Src.Binop]
179−chompBinops binops =
214+chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]
215+chompInfixes infixes =
180216 oneOfWithFallback
181217 [ do binop <- Decl.infix_
182− chompBinops (binop:binops)
218+ chompInfixes (binop:infixes)
183219 ]
184− binops
220+ infixes
185221
186222
187223
188224-- MODULE DOC COMMENT
189225
190226
191−chompModuleDocComment :: Parser E.Module (Maybe Space.DocComment)
192−chompModuleDocComment =
193− oneOfWithFallback
194− [
195− do docComment <- Space.docComment E.ImportStart E.ModuleSpace
196− Space.chomp E.ModuleSpace
197− Space.checkFreshLine E.FreshLineAfterDocComment
198− return (Just docComment)
199− ]
200− Nothing
227+chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.Comment)
228+chompModuleDocCommentSpace =
229+ do (A.At region ()) <- addLocation (freshLine E.FreshLine)
230+ oneOfWithFallback
231+ [
232+ do docComment <- Space.docComment E.ImportStart E.ModuleSpace
233+ Space.chomp E.ModuleSpace
234+ Space.checkFreshLine E.FreshLine
235+ return (Right docComment)
236+ ]
237+ (Left region)
201238
202239
203240
@@ -205,7 +242,7 @@ chompModuleDocComment =
205242
206243
207244data Header =
208− Header (A.Located Name.Name) Effects (A.Located Src.Exposing)
245+ Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.Comment)
209246
210247
211248data Effects
@@ -216,52 +253,56 @@ data Effects
216253
217254chompHeader :: Parser E.Module (Maybe Header)
218255chompHeader =
219− do start <- getPosition
256+ do freshLine E.FreshLine
257+ start <- getPosition
220258 oneOfWithFallback
221259 [
222260 -- module MyThing exposing (..)
223− do Keyword.module_ E.Module
224− end <- getPosition
225− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentName
261+ do Keyword.module_ E.ModuleProblem
262+ effectEnd <- getPosition
263+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
226264 name <- addLocation (Var.moduleName E.ModuleName)
227− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
228− Keyword.exposing_ E.ModuleExposing
229− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
230− exports <- addLocation (specialize E.ModuleExposingList exposing)
231− freshLine E.FreshLineAfterModuleLine
232− return (Just (Header name (NoEffects (A.Region start end)) exports))
265+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
266+ Keyword.exposing_ E.ModuleProblem
267+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
268+ exports <- addLocation (specialize E.ModuleExposing exposing)
269+ comment <- chompModuleDocCommentSpace
270+ return $ Just $
271+ Header name (NoEffects (A.Region start effectEnd)) exports comment
233272 ,
234273 -- port module MyThing exposing (..)
235− do Keyword.port_ E.Module
236− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentPortModule
237− Keyword.module_ E.ModulePortModule
238− end <- getPosition
239− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentName
240− name <- addLocation (Var.moduleName E.ModuleName)
241− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
242− Keyword.exposing_ E.ModuleExposing
243− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
244− exports <- addLocation (specialize E.ModuleExposingList exposing)
245− freshLine E.FreshLineAfterModuleLine
246− return (Just (Header name (Ports (A.Region start end)) exports))
274+ do Keyword.port_ E.PortModuleProblem
275+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
276+ Keyword.module_ E.PortModuleProblem
277+ effectEnd <- getPosition
278+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
279+ name <- addLocation (Var.moduleName E.PortModuleName)
280+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
281+ Keyword.exposing_ E.PortModuleProblem
282+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
283+ exports <- addLocation (specialize E.PortModuleExposing exposing)
284+ comment <- chompModuleDocCommentSpace
285+ return $ Just $
286+ Header name (Ports (A.Region start effectEnd)) exports comment
247287 ,
248288 -- effect module MyThing where { command = MyCmd } exposing (..)
249− do Keyword.effect_ E.Module
250− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
251− Keyword.module_ E.ModuleEffect
252− end <- getPosition
253− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
289+ do Keyword.effect_ E.Effect
290+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
291+ Keyword.module_ E.Effect
292+ effectEnd <- getPosition
293+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
254294 name <- addLocation (Var.moduleName E.ModuleName)
255− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
256− Keyword.where_ E.ModuleEffect
257− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
295+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
296+ Keyword.where_ E.Effect
297+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
258298 manager <- chompManager
259− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
260− Keyword.exposing_ E.ModuleExposing
261− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
262− exports <- addLocation (specialize E.ModuleExposingList exposing)
263− freshLine E.FreshLineAfterModuleLine
264− return (Just (Header name (Manager (A.Region start end) manager) exports))
299+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
300+ Keyword.exposing_ E.Effect
301+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
302+ exports <- addLocation (specialize (const E.Effect) exposing)
303+ comment <- chompModuleDocCommentSpace
304+ return $ Just $
305+ Header name (Manager (A.Region start effectEnd) manager) exports comment
265306 ]
266307 -- default header
267308 Nothing
@@ -269,34 +310,34 @@ chompHeader =
269310
270311chompManager :: Parser E.Module Src.Manager
271312chompManager =
272− do word1 0x7B {- { -} E.ModuleEffect
313+ do word1 0x7B {- { -} E.Effect
273314 spaces_em
274− oneOf E.ModuleEffect
315+ oneOf E.Effect
275316 [ do cmd <- chompCommand
276317 spaces_em
277− oneOf E.ModuleEffect
278− [ do word1 0x7D {-}-} E.ModuleEffect
318+ oneOf E.Effect
319+ [ do word1 0x7D {-}-} E.Effect
279320 spaces_em
280321 return (Src.Cmd cmd)
281− , do word1 0x2C {-,-} E.ModuleEffect
322+ , do word1 0x2C {-,-} E.Effect
282323 spaces_em
283324 sub <- chompSubscription
284325 spaces_em
285− word1 0x7D {-}-} E.ModuleEffect
326+ word1 0x7D {-}-} E.Effect
286327 spaces_em
287328 return (Src.Fx cmd sub)
288329 ]
289330 , do sub <- chompSubscription
290331 spaces_em
291− oneOf E.ModuleEffect
292− [ do word1 0x7D {-}-} E.ModuleEffect
332+ oneOf E.Effect
333+ [ do word1 0x7D {-}-} E.Effect
293334 spaces_em
294335 return (Src.Sub sub)
295− , do word1 0x2C {-,-} E.ModuleEffect
336+ , do word1 0x2C {-,-} E.Effect
296337 spaces_em
297338 cmd <- chompCommand
298339 spaces_em
299− word1 0x7D {-}-} E.ModuleEffect
340+ word1 0x7D {-}-} E.Effect
300341 spaces_em
301342 return (Src.Fx cmd sub)
302343 ]
@@ -305,25 +346,25 @@ chompManager =
305346
306347chompCommand :: Parser E.Module (A.Located Name.Name)
307348chompCommand =
308− do Keyword.command_ E.ModuleEffect
349+ do Keyword.command_ E.Effect
309350 spaces_em
310− word1 0x3D {-=-} E.ModuleEffect
351+ word1 0x3D {-=-} E.Effect
311352 spaces_em
312− addLocation (Var.upper E.ModuleEffect)
353+ addLocation (Var.upper E.Effect)
313354
314355
315356chompSubscription :: Parser E.Module (A.Located Name.Name)
316357chompSubscription =
317− do Keyword.subscription_ E.ModuleEffect
358+ do Keyword.subscription_ E.Effect
318359 spaces_em
319− word1 0x3D {-=-} E.ModuleEffect
360+ word1 0x3D {-=-} E.Effect
320361 spaces_em
321− addLocation (Var.upper E.ModuleEffect)
362+ addLocation (Var.upper E.Effect)
322363
323364
324365spaces_em :: Parser E.Module ()
325366spaces_em =
326− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
367+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
327368
328369
329370
@@ -331,28 +372,33 @@ spaces_em =
331372
332373
333374chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
334−chompImports imports =
375+chompImports is =
335376 oneOfWithFallback
336− [ do Keyword.import_ E.ImportStart
337− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
338− name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
339− Space.chomp E.ModuleSpace
340− oneOf E.ImportEnd
341− [ do Space.checkFreshLine E.ImportEnd
342− chompImports $
343− Src.Import name Nothing (Src.Explicit []) : imports
344− , do Space.checkIndent end E.ImportIndentAs
345− oneOf E.ImportAs
346− [ chompAs name imports
347− , chompExposing name Nothing imports
348− ]
349− ]
377+ [ do i <- chompImport
378+ chompImports (i:is)
350379 ]
351− (reverse imports)
380+ (reverse is)
352381
353382
354−chompAs :: A.Located Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
355−chompAs name imports =
383+chompImport :: Parser E.Module Src.Import
384+chompImport =
385+ do Keyword.import_ E.ImportStart
386+ Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
387+ name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
388+ Space.chomp E.ModuleSpace
389+ oneOf E.ImportEnd
390+ [ do Space.checkFreshLine E.ImportEnd
391+ return $ Src.Import name Nothing (Src.Explicit [])
392+ , do Space.checkIndent end E.ImportEnd
393+ oneOf E.ImportAs
394+ [ chompAs name
395+ , chompExposing name Nothing
396+ ]
397+ ]
398+
399+
400+chompAs :: A.Located Name.Name -> Parser E.Module Src.Import
401+chompAs name =
356402 do Keyword.as_ E.ImportAs
357403 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
358404 alias <- Var.upper E.ImportAlias
@@ -360,21 +406,19 @@ chompAs name imports =
360406 Space.chomp E.ModuleSpace
361407 oneOf E.ImportEnd
362408 [ do Space.checkFreshLine E.ImportEnd
363− chompImports $
364− Src.Import name (Just alias) (Src.Explicit []) : imports
365− , do Space.checkIndent end E.ImportIndentExposing
366− chompExposing name (Just alias) imports
409+ return $ Src.Import name (Just alias) (Src.Explicit [])
410+ , do Space.checkIndent end E.ImportEnd
411+ chompExposing name (Just alias)
367412 ]
368413
369414
370−chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
371−chompExposing name maybeAlias imports =
415+chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import
416+chompExposing name maybeAlias =
372417 do Keyword.exposing_ E.ImportExposing
373418 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
374419 exposed <- specialize E.ImportExposingList exposing
375420 freshLine E.ImportEnd
376− chompImports $
377− Src.Import name maybeAlias exposed : imports
421+ return $ Src.Import name maybeAlias exposed
378422
379423
380424
@@ -385,24 +429,24 @@ exposing :: Parser E.Exposing Src.Exposing
385429exposing =
386430 do word1 0x28 {-(-} E.ExposingStart
387431 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
388− oneOf E.ExposingIndentValue
389− [ do word2 0x2E 0x2E {-..-} E.ExposingIndentValue
432+ oneOf E.ExposingValue
433+ [ do word2 0x2E 0x2E {-..-} E.ExposingValue
390434 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
391435 word1 0x29 {-)-} E.ExposingEnd
392436 return Src.Open
393− , do exposed <- addLocation chompExposed
437+ , do exposed <- chompExposed
394438 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
395439 exposingHelp [exposed]
396440 ]
397441
398442
399−exposingHelp :: [A.Located Src.Exposed] -> Parser E.Exposing Src.Exposing
443+exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing
400444exposingHelp revExposed =
401445 oneOf E.ExposingEnd
402446 [ do word1 0x2C {-,-} E.ExposingEnd
403447 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
404− exposed <- addLocation chompExposed
405− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValueEnd
448+ exposed <- chompExposed
449+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
406450 exposingHelp (exposed:revExposed)
407451 , do word1 0x29 {-)-} E.ExposingEnd
408452 return (Src.Explicit (reverse revExposed))
@@ -411,26 +455,33 @@ exposingHelp revExposed =
411455
412456chompExposed :: Parser E.Exposing Src.Exposed
413457chompExposed =
414− oneOf E.ExposingValue
415− [ Src.Lower <$> Var.lower E.ExposingValue
416− , do word1 0x28 {-(-} E.ExposingValue
417− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
418− word1 0x29 {-)-} E.ExposingOperatorRightParen
419− return (Src.Operator op)
420− , do name <- Var.upper E.ExposingValue
421− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacy
422− Src.Upper name <$> privacy
423− ]
458+ do start <- getPosition
459+ oneOf E.ExposingValue
460+ [ do name <- Var.lower E.ExposingValue
461+ end <- getPosition
462+ return $ Src.Lower $ A.at start end name
463+ , do word1 0x28 {-(-} E.ExposingValue
464+ op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
465+ word1 0x29 {-)-} E.ExposingOperatorRightParen
466+ end <- getPosition
467+ return $ Src.Operator (A.Region start end) op
468+ , do name <- Var.upper E.ExposingValue
469+ end <- getPosition
470+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
471+ Src.Upper (A.at start end name) <$> privacy
472+ ]
424473
425474
426475privacy :: Parser E.Exposing Src.Privacy
427476privacy =
428477 oneOfWithFallback
429478 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
430− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyDots
431− word2 0x2E 0x2E {-..-} E.ExposingTypePrivacyDots
432− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyEnd
433− word1 0x29 {-)-} E.ExposingTypePrivacyEnd
434− return Src.Public
479+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
480+ start <- getPosition
481+ word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
482+ end <- getPosition
483+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
484+ word1 0x29 {-)-} E.ExposingTypePrivacy
485+ return $ Src.Public (A.Region start end)
435486 ]
436487 Src.Private
compiler/src/Parse/Number.hs+16−13
@@ -11,11 +11,11 @@ module Parse.Number
1111 where
1212
1313
14−import qualified Data.Utf8 as Utf8
1514import Data.Word (Word8)
1615import Foreign.Ptr (Ptr, plusPtr, minusPtr)
1716
1817import qualified AST.Utils.Binop as Binop
18+import qualified Elm.Float as EF
1919import Parse.Primitives (Parser, Row, Col)
2020import qualified Parse.Variable as Var
2121import qualified Parse.Primitives as P
@@ -43,12 +43,12 @@ isDecimalDigit word =
4343
4444data Number
4545 = Int Int
46− | Float (Utf8.Under256 Float)
46+ | Float EF.Float
4747
4848
4949number :: (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> Parser x Number
5050number toExpectation toError =
51− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
51+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
5252 if pos >= end then
5353 eerr row col toExpectation
5454
@@ -76,16 +76,16 @@ number toExpectation toError =
7676 let
7777 !newCol = col + fromIntegral (minusPtr newPos pos)
7878 !integer = Int n
79− !newState = P.State newPos end indent row newCol
79+ !newState = P.State src newPos end indent row newCol
8080 in
8181 cok integer newState
8282
8383 OkFloat newPos ->
8484 let
8585 !newCol = col + fromIntegral (minusPtr newPos pos)
86− !copy = Utf8.fromPtr pos newPos
86+ !copy = EF.fromPtr pos newPos
8787 !float = Float copy
88− !newState = P.State newPos end indent row newCol
88+ !newState = P.State src newPos end indent row newCol
8989 in
9090 cok float newState
9191
@@ -121,7 +121,7 @@ chompInt !pos end !n =
121121 chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-}))
122122
123123 else if word == 0x2E {-.-} then
124− chompFraction (plusPtr pos 1) end n
124+ chompFraction pos end n
125125
126126 else if word == 0x65 {-e-} || word == 0x45 {-E-} then
127127 chompExponent (plusPtr pos 1) end
@@ -139,11 +139,14 @@ chompInt !pos end !n =
139139
140140chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome
141141chompFraction pos end n =
142− if pos >= end then
142+ let
143+ !pos1 = plusPtr pos 1
144+ in
145+ if pos1 >= end then
143146 Err pos (E.NumberDot n)
144147
145− else if isDecimalDigit (P.unsafeIndex pos) then
146− chompFractionHelp (plusPtr pos 1) end
148+ else if isDecimalDigit (P.unsafeIndex pos1) then
149+ chompFractionHelp (plusPtr pos1 1) end
147150
148151 else
149152 Err pos (E.NumberDot n)
@@ -222,7 +225,7 @@ chompZero pos end =
222225 chompHexInt (plusPtr pos 1) end
223226
224227 else if word == 0x2E {-.-} then
225− chompFraction (plusPtr pos 1) end 0
228+ chompFraction pos end 0
226229
227230 else if isDecimalDigit word then
228231 Err pos E.NumberNoLeadingZero
@@ -287,7 +290,7 @@ stepHex pos end word acc
287290
288291precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence
289292precedence toExpectation =
290− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
293+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
291294 if pos >= end then
292295 eerr row col toExpectation
293296
@@ -296,7 +299,7 @@ precedence toExpectation =
296299 if isDecimalDigit word then
297300 cok
298301 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
299− (P.State (plusPtr pos 1) end indent row (col + 1))
302+ (P.State src (plusPtr pos 1) end indent row (col + 1))
300303
301304 else
302305 eerr row col toExpectation
compiler/src/Parse/Pattern.hs+46−21
@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
33module Parse.Pattern
44 ( term
55 , expression
@@ -10,13 +10,13 @@ module Parse.Pattern
1010import qualified Data.List as List
1111import qualified Data.Name as Name
1212import qualified Data.Utf8 as Utf8
13+import Foreign.Ptr (plusPtr)
1314
1415import qualified AST.Source as Src
1516import qualified Parse.Keyword as Keyword
1617import qualified Parse.Number as Number
1718import qualified Parse.Space as Space
18−import qualified Parse.Symbol as Symbol
19−import qualified Parse.Utf8 as Utf8
19+import qualified Parse.String as String
2020import qualified Parse.Variable as Var
2121import qualified Parse.Primitives as P
2222import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2)
@@ -43,7 +43,7 @@ termHelp :: A.Position -> Parser E.Pattern Src.Pattern
4343termHelp start =
4444 oneOf E.PStart
4545 [
46− do Symbol.wildcard
46+ do wildcard
4747 addEnd start Src.PAnything
4848 ,
4949 do name <- Var.lower E.PStart
@@ -67,18 +67,43 @@ termHelp start =
6767 return (A.at start end (Src.PInt int))
6868
6969 Number.Float float ->
70− P.Parser $ \(P.State _ _ _ row col) _ _ cerr _ ->
71− cerr row col (E.PFloat (Utf8.size float))
70+ P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ ->
71+ let
72+ width = fromIntegral (Utf8.size float)
73+ in
74+ cerr row (col - width) (E.PFloat width)
7275 ,
73− do str <- Utf8.string E.PStart E.PString
76+ do str <- String.string E.PStart E.PString
7477 addEnd start (Src.PStr str)
7578 ,
76− do chr <- Utf8.character E.PStart E.PChar
79+ do chr <- String.character E.PStart E.PChar
7780 addEnd start (Src.PChr chr)
7881 ]
7982
8083
8184
85+-- WILDCARD
86+
87+
88+wildcard :: Parser E.Pattern ()
89+wildcard =
90+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
91+ if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
92+ eerr row col E.PStart
93+ else
94+ let
95+ !newPos = plusPtr pos 1
96+ !newCol = col + 1
97+ in
98+ if Var.getInnerWidth newPos end > 0 then
99+ let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in
100+ cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col)))
101+ else
102+ let !newState = P.State src newPos end indent row newCol in
103+ cok () newState
104+
105+
106+
82107-- RECORDS
83108
84109
@@ -104,7 +129,7 @@ recordHelp start vars =
104129 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
105130 recordHelp start (var:vars)
106131 , do word1 0x7D {-}-} E.PRecordEnd
107− addEnd start (Src.PRecord vars)
132+ addEnd start (Src.PRecord (reverse vars))
108133 ]
109134
110135
@@ -115,7 +140,7 @@ recordHelp start vars =
115140tuple :: A.Position -> Parser E.Pattern Src.Pattern
116141tuple start =
117142 inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
118− do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentOpen
143+ do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1
119144 oneOf E.PTupleOpen
120145 [ do (pattern, end) <- P.specialize E.PTupleExpr expression
121146 Space.checkIndent end E.PTupleIndentEnd
@@ -129,7 +154,7 @@ tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.P
129154tupleHelp start firstPattern revPatterns =
130155 oneOf E.PTupleEnd
131156 [ do word1 0x2C {-,-} E.PTupleEnd
132− Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr
157+ Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN
133158 (pattern, end) <- P.specialize E.PTupleExpr expression
134159 Space.checkIndent end E.PTupleIndentEnd
135160 tupleHelp start firstPattern (pattern : revPatterns)
@@ -180,18 +205,18 @@ listHelp start patterns =
180205expression :: Space.Parser E.Pattern Src.Pattern
181206expression =
182207 do start <- getPosition
183− cTerm <- exprTerm
184− exprHelp start [] cTerm
208+ ePart <- exprPart
209+ exprHelp start [] ePart
185210
186211
187212exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
188−exprHelp start patterns (pattern, end) =
213+exprHelp start revPatterns (pattern, end) =
189214 oneOfWithFallback
190215 [ do Space.checkIndent end E.PIndentStart
191216 word2 0x3A 0x3A {-::-} E.PStart
192217 Space.chompAndCheckIndent E.PSpace E.PIndentStart
193− cTerm <- exprTerm
194− exprHelp start (pattern:patterns) cTerm
218+ ePart <- exprPart
219+ exprHelp start (pattern:revPatterns) ePart
195220 , do Space.checkIndent end E.PIndentStart
196221 Keyword.as_ E.PStart
197222 Space.chompAndCheckIndent E.PSpace E.PIndentAlias
@@ -201,11 +226,11 @@ exprHelp start patterns (pattern, end) =
201226 Space.chomp E.PSpace
202227 let alias = A.at nameStart newEnd name
203228 return
204− ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern patterns) alias)
229+ ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias)
205230 , newEnd
206231 )
207232 ]
208− ( List.foldl' cons pattern patterns
233+ ( List.foldl' cons pattern revPatterns
209234 , end
210235 )
211236
@@ -216,11 +241,11 @@ cons tl hd =
216241
217242
218243
219−-- EXPRESSION TERM
244+-- EXPRESSION PART
220245
221246
222−exprTerm :: Space.Parser E.Pattern Src.Pattern
223−exprTerm =
247+exprPart :: Space.Parser E.Pattern Src.Pattern
248+exprPart =
224249 oneOf E.PStart
225250 [
226251 do start <- getPosition
compiler/src/Parse/Primitives.hs+95−47
@@ -1,8 +1,7 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
33module Parse.Primitives
4− ( Result(..)
5− , fromByteString
4+ ( fromByteString
65 , Parser(..)
76 , State(..)
87 , Row
@@ -13,18 +12,20 @@ module Parse.Primitives
1312 , getIndent, setIndent, withIndent, withBacksetIndent
1413 , word1, word2
1514 , unsafeIndex, isWord, getCharWidth
15+ , Snippet(..)
16+ , fromSnippet
1617 )
1718 where
1819
1920
2021import Prelude hiding (length)
2122import qualified Control.Applicative as Applicative (Applicative(..))
22−import Control.Monad
2323import qualified Data.ByteString.Internal as B
2424import Data.Word (Word8, Word16)
2525import Foreign.Ptr (Ptr, plusPtr)
2626import Foreign.Storable (peek)
27−import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)
27+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
28+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
2829
2930import qualified Reporting.Annotation as A
3031
@@ -45,9 +46,10 @@ newtype Parser x a =
4546 )
4647
4748
48−data State = -- TODO try adding UNPACK to everything
49+data State = -- PERF try taking some out to avoid allocation
4950 State
50− { _pos :: !(Ptr Word8)
51+ { _src :: ForeignPtr Word8
52+ , _pos :: !(Ptr Word8)
5153 , _end :: !(Ptr Word8)
5254 , _indent :: !Word16
5355 , _row :: !Row
@@ -83,7 +85,23 @@ instance Applicative.Applicative (Parser x) where
8385 pure = return
8486
8587 {-# INLINE (<*>) #-}
86− (<*>) = ap
88+ (<*>) (Parser parserFunc) (Parser parserArg) =
89+ Parser $ \state cok eok cerr eerr ->
90+ let
91+ cokF func s1 =
92+ let
93+ cokA arg s2 = cok (func arg) s2
94+ in
95+ parserArg s1 cokA cokA cerr cerr
96+
97+ eokF func s1 =
98+ let
99+ cokA arg s2 = cok (func arg) s2
100+ eokA arg s2 = eok (func arg) s2
101+ in
102+ parserArg s1 cokA eokA cerr eerr
103+ in
104+ parserFunc state cokF eokF cerr eerr
87105
88106
89107
@@ -117,7 +135,7 @@ oneOfHelp state cok eok cerr eerr toError parsers =
117135
118136 [] ->
119137 let
120− (State _ _ _ row col) = state
138+ (State _ _ _ _ row col) = state
121139 in
122140 eerr row col toError
123141
@@ -127,7 +145,7 @@ oneOfHelp state cok eok cerr eerr toError parsers =
127145
128146
129147{-# INLINE oneOfWithFallback #-}
130−oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- TODO is this function okay? Worried about allocation/laziness with fallback values.
148+oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values.
131149oneOfWithFallback parsers fallback =
132150 Parser $ \state cok eok cerr _ ->
133151 oowfHelp state cok eok cerr parsers fallback
@@ -183,26 +201,56 @@ instance Monad (Parser x) where
183201-- FROM BYTESTRING
184202
185203
186−data Result x a
187− = Ok !a State
188− | Err x
189−
190−
191−fromByteString :: Parser x a -> B.ByteString -> Result x a
192−fromByteString (Parser parser) (B.PS fp offset length) =
204+fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a
205+fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) =
193206 B.accursedUnutterablePerformIO $
194207 let
195− !pos = plusPtr (unsafeForeignPtrToPtr fp) offset
208+ toOk' = toOk toBadEnd
209+ !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset
196210 !end = plusPtr pos length
197− !result = parser (State pos end 0 1 1) Ok Ok toErr toErr
211+ !result = parser (State fptr pos end 0 1 1) toOk' toOk' toErr toErr
198212 in
199− do touchForeignPtr fp
213+ do touchForeignPtr fptr
200214 return result
201215
202216
203−toErr :: Row -> Col -> (Row -> Col -> x) -> Result x a
217+toOk :: (Row -> Col -> x) -> a -> State -> Either x a
218+toOk toBadEnd !a (State _ pos end _ row col) =
219+ if pos == end
220+ then Right a
221+ else Left (toBadEnd row col)
222+
223+
224+toErr :: Row -> Col -> (Row -> Col -> x) -> Either x a
204225toErr row col toError =
205− Err (toError row col)
226+ Left (toError row col)
227+
228+
229+
230+-- FROM SNIPPET
231+
232+
233+data Snippet =
234+ Snippet
235+ { _fptr :: ForeignPtr Word8
236+ , _offset :: Int
237+ , _length :: Int
238+ , _offRow :: Row
239+ , _offCol :: Col
240+ }
241+
242+
243+fromSnippet :: Parser x a -> (Row -> Col -> x) -> Snippet -> Either x a
244+fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =
245+ B.accursedUnutterablePerformIO $
246+ let
247+ toOk' = toOk toBadEnd
248+ !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset
249+ !end = plusPtr pos length
250+ !result = parser (State fptr pos end 0 row col) toOk' toOk' toErr toErr
251+ in
252+ do touchForeignPtr fptr
253+ return result
206254
207255
208256
@@ -211,30 +259,30 @@ toErr row col toError =
211259
212260getCol :: Parser x Word16
213261getCol =
214− Parser $ \state@(State _ _ _ _ col) _ eok _ _ ->
262+ Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ ->
215263 eok col state
216264
217265
218266{-# INLINE getPosition #-}
219267getPosition :: Parser x A.Position
220268getPosition =
221− Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
269+ Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
222270 eok (A.Position row col) state
223271
224272
225273addLocation :: Parser x a -> Parser x (A.Located a)
226274addLocation (Parser parser) =
227− Parser $ \state@(State _ _ _ sr sc) cok eok cerr eerr ->
275+ Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr ->
228276 let
229− cok' a s@(State _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
230− eok' a s@(State _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
277+ cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
278+ eok' a s@(State _ _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
231279 in
232280 parser state cok' eok' cerr eerr
233281
234282
235283addEnd :: A.Position -> a -> Parser x (A.Located a)
236284addEnd start value =
237− Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
285+ Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
238286 eok (A.at start (A.Position row col) value) state
239287
240288
@@ -244,37 +292,37 @@ addEnd start value =
244292
245293getIndent :: Parser x Word16
246294getIndent =
247− Parser $ \state@(State _ _ indent _ _) _ eok _ _ ->
295+ Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ ->
248296 eok indent state
249297
250298
251299setIndent :: Word16 -> Parser x ()
252300setIndent indent =
253− Parser $ \(State pos end _ row col) _ eok _ _ ->
301+ Parser $ \(State src pos end _ row col) _ eok _ _ ->
254302 let
255− !newState = State pos end indent row col
303+ !newState = State src pos end indent row col
256304 in
257305 eok () newState
258306
259307
260308withIndent :: Parser x a -> Parser x a
261309withIndent (Parser parser) =
262− Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
310+ Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
263311 let
264− cok' a (State p e _ r c) = cok a (State p e oldIndent r c)
265− eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
312+ cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
313+ eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)
266314 in
267− parser (State pos end col row col) cok' eok' cerr eerr
315+ parser (State src pos end col row col) cok' eok' cerr eerr
268316
269317
270318withBacksetIndent :: Word16 -> Parser x a -> Parser x a
271319withBacksetIndent backset (Parser parser) =
272− Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
320+ Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
273321 let
274− cok' a (State p e _ r c) = cok a (State p e oldIndent r c)
275− eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
322+ cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
323+ eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)
276324 in
277− parser (State pos end (col - backset) row col) cok' eok' cerr eerr
325+ parser (State src pos end (col - backset) row col) cok' eok' cerr eerr
278326
279327
280328
@@ -283,7 +331,7 @@ withBacksetIndent backset (Parser parser) =
283331
284332inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a
285333inContext addContext (Parser parserStart) (Parser parserA) =
286− Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
334+ Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
287335 let
288336 cerrA r c tx = cerr row col (addContext (tx r c))
289337 eerrA r c tx = eerr row col (addContext (tx r c))
@@ -296,7 +344,7 @@ inContext addContext (Parser parserStart) (Parser parserA) =
296344
297345specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a
298346specialize addContext (Parser parser) =
299− Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
347+ Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
300348 let
301349 cerr' r c tx = cerr row col (addContext (tx r c))
302350 eerr' r c tx = eerr row col (addContext (tx r c))
@@ -310,9 +358,9 @@ specialize addContext (Parser parser) =
310358
311359word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()
312360word1 word toError =
313− Parser $ \(State pos end indent row col) cok _ _ eerr ->
361+ Parser $ \(State src pos end indent row col) cok _ _ eerr ->
314362 if pos < end && unsafeIndex pos == word then
315− let !newState = State (plusPtr pos 1) end indent row (col + 1) in
363+ let !newState = State src (plusPtr pos 1) end indent row (col + 1) in
316364 cok () newState
317365 else
318366 eerr row col toError
@@ -320,12 +368,12 @@ word1 word toError =
320368
321369word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
322370word2 w1 w2 toError =
323− Parser $ \(State pos end indent row col) cok _ _ eerr ->
371+ Parser $ \(State src pos end indent row col) cok _ _ eerr ->
324372 let
325373 !pos1 = plusPtr pos 1
326374 in
327375 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
328− let !newState = State (plusPtr pos 2) end indent row (col + 2) in
376+ let !newState = State src (plusPtr pos 2) end indent row (col + 2) in
329377 cok () newState
330378 else
331379 eerr row col toError
@@ -346,8 +394,8 @@ isWord pos end word =
346394 pos < end && unsafeIndex pos == word
347395
348396
349−getCharWidth :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
350−getCharWidth _pos _end word
397+getCharWidth :: Word8 -> Int
398+getCharWidth word
351399 | word < 0x80 = 1
352400 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
353401 | word < 0xe0 = 2
compiler/src/Parse/Repl.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Parse.Repl
4− ( Entry(..)
5− , parseEntry
6− )
7− where
8−
9−
10−import qualified Data.ByteString.UTF8 as BS_UTF8
11−import Data.Name (Name)
12−
13−import qualified AST.Source as Src
14−import qualified Parse.Primitives as P
15−import Parse.Utils
16−
17−
18−
19−-- ENTRY
20−
21−
22−data Entry
23− = Import Name (Maybe Name) Src.Exposing String
24− | Type Name String
25− | Def (Maybe Name) String
26− | Other String
27− | Annotation
28− | Port
29−
30−
31−
32−-- PARSE
33−
34−
35−parseEntry :: String -> Entry
36−parseEntry source =
37− case P.fromByteString parser (BS_UTF8.fromString source) of
38− P.Ok entry _ ->
39− entry
40−
41− P.Err _ _ _ _ ->
42− Other source
43−
44−
45−parser :: Parser Entry
46−parser =
47− error "TODO parse the REPL stuff"
48−
49−{-
50− oneOf
51− [
52− do Keyword.import_
53− spaces
54− name <- Var.moduleName
55− alias <- tryAlias
56− exposing <-
57− oneOf
58− [ do spaces
59− Keyword.exposing_
60− spaces
61− Module.exposing
62− , return (Src.Explicit [])
63− ]
64− return (Import name alias exposing source)
65− ,
66− do Keyword.port_
67− return Port
68− ,
69− do Keyword.type_
70− spaces
71− oneOf
72− [ do Keyword.alias_
73− spaces
74− , return ()
75− ]
76− name <- Var.upper
77− return (Type name source)
78− ,
79− do root <- Pattern.term
80− spaces
81− case A.toValue root of
82− Src.PVar name ->
83− oneOf
84− [ do word1 0x3A {-:-} E.XXX
85− return Annotation
86− , do chompArgs
87− return (Def (Just name) source)
88− ]
89−
90− _ ->
91− do word1 0x3D {-=-} E.XXX
92− return (Def Nothing source)
93− ]
94−
95−
96−chompArgs :: Parser ()
97−chompArgs =
98− oneOf
99− [ do Pattern.term
100− spaces
101− chompArgs
102− , do word1 0x3D {-=-} E.XXX
103− return ()
104− ]
105−
106−
107−tryAlias :: Parser (Maybe Name)
108−tryAlias =
109− oneOf
110− [ try $
111− do spaces
112− Keyword.as_
113− spaces
114− Just <$> Var.upper
115− , return Nothing
116− ]
117−-}
compiler/src/Parse/Shader.hs+20−19
@@ -6,12 +6,13 @@ module Parse.Shader
66 where
77
88
9−import qualified Data.List as List
9+import qualified Data.ByteString.Internal as B
10+import qualified Data.ByteString.UTF8 as BS_UTF8
1011import qualified Data.Map as Map
1112import qualified Data.Name as Name
12−import qualified Data.Utf8 as Utf8
1313import Data.Word (Word8)
14−import Foreign.Ptr (Ptr, plusPtr)
14+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
15+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
1516import qualified Language.GLSL.Parser as GLP
1617import qualified Language.GLSL.Syntax as GLS
1718import qualified Text.Parsec as Parsec
@@ -34,17 +35,16 @@ shader start@(A.Position row col) =
3435 do block <- parseBlock
3536 shdr <- parseGlsl row col block
3637 end <- P.getPosition
37− let src = List.intercalate "\\n" (lines block)
38− return (A.at start end (Src.Shader (Utf8.fromChars src) shdr))
38+ return (A.at start end (Src.Shader (Shader.fromChars block) shdr))
3939
4040
4141
4242-- BLOCK
4343
4444
45−parseBlock :: Parser E.Expr String
45+parseBlock :: Parser E.Expr [Char]
4646parseBlock =
47− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
47+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
4848 let
4949 !pos6 = plusPtr pos 6
5050 in
@@ -58,16 +58,17 @@ parseBlock =
5858 then
5959 let
6060 (# status, newPos, newRow, newCol #) =
61− eatShader pos6 end row col
61+ eatShader pos6 end row (col + 6)
6262 in
6363 case status of
6464 Good ->
6565 let
66− !block = Utf8.fromPtr pos newPos
67− !source = Utf8.toChars block
68− !newState = P.State (plusPtr newPos 2) end indent newRow newCol
66+ !off = minusPtr pos6 (unsafeForeignPtrToPtr src)
67+ !len = minusPtr newPos pos6
68+ !block = BS_UTF8.toString (B.PS src off len)
69+ !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)
6970 in
70− cok source newState
71+ cok block newState
7172
7273 Unending ->
7374 cerr row col E.EndlessShader
@@ -89,13 +90,13 @@ eatShader pos end row col =
8990 else
9091 let !word = P.unsafeIndex pos in
9192 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
92− (# Good, pos, row, col + 2 #)
93+ (# Good, pos, row, col #)
9394
9495 else if word == 0x0A {- \n -} then
9596 eatShader (plusPtr pos 1) end (row + 1) 1
9697
9798 else
98− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
99+ let !newPos = plusPtr pos (P.getCharWidth word) in
99100 eatShader newPos end row (col + 1)
100101
101102
@@ -103,7 +104,7 @@ eatShader pos end row col =
103104-- GLSL
104105
105106
106−parseGlsl :: Row -> Col -> String -> Parser E.Expr Shader.Types
107+parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types
107108parseGlsl startRow startCol src =
108109 case GLP.parse src of
109110 Right (GLS.TranslationUnit decls) ->
@@ -128,9 +129,9 @@ parseGlsl startRow startCol src =
128129 else failure (startRow + row - 1) col msg
129130
130131
131−failure :: Row -> Col -> String -> Parser E.Expr a
132+failure :: Row -> Col -> [Char] -> Parser E.Expr a
132133failure row col msg =
133− P.Parser $ \(P.State _ _ _ _ _) _ _ cerr _ ->
134+ P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->
134135 cerr row col (E.ShaderProblem msg)
135136
136137
@@ -143,7 +144,7 @@ emptyTypes =
143144 Shader.Types Map.empty Map.empty Map.empty
144145
145146
146−addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types
147+addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types
147148addInput (qual, tipe, name) glDecls =
148149 case qual of
149150 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
@@ -152,7 +153,7 @@ addInput (qual, tipe, name) glDecls =
152153 _ -> error "Should never happen due to `extractInputs` function"
153154
154155
155−extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)]
156+extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]
156157extractInputs decl =
157158 case decl of
158159 GLS.Declaration
compiler/src/Parse/Space.hs+25−29
@@ -10,15 +10,16 @@ module Parse.Space
1010 , checkAligned
1111 , checkFreshLine
1212 --
13− , DocComment(..)
1413 , docComment
1514 )
1615 where
1716
1817
1918import Data.Word (Word8, Word16)
20−import Foreign.Ptr (Ptr, plusPtr)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
2121
22+import qualified AST.Source as Src
2223import Parse.Primitives (Row, Col)
2324import qualified Parse.Primitives as P
2425import qualified Reporting.Annotation as A
@@ -39,20 +40,19 @@ type Parser x a =
3940
4041chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()
4142chomp toError =
42− P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
43+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
4344 let
4445 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
4546 in
4647 case status of
4748 Good ->
4849 let
49− !newState = P.State newPos end indent newRow newCol
50+ !newState = P.State src newPos end indent newRow newCol
5051 in
5152 cok () newState
5253
5354 HasTab -> cerr newRow newCol (toError E.HasTab)
5455 EndlessMultiComment -> cerr newRow newCol (toError E.EndlessMultiComment)
55− UnexpectedDocComment -> cerr newRow newCol (toError E.UnexpectedDocComment)
5656
5757
5858
@@ -61,7 +61,7 @@ chomp toError =
6161
6262checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x ()
6363checkIndent (A.Position endRow endCol) toError =
64− P.Parser $ \state@(P.State _ _ indent _ col) _ eok _ eerr ->
64+ P.Parser $ \state@(P.State _ _ _ indent _ col) _ eok _ eerr ->
6565 if col > indent && col > 1
6666 then eok () state
6767 else eerr endRow endCol toError
@@ -69,7 +69,7 @@ checkIndent (A.Position endRow endCol) toError =
6969
7070checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x ()
7171checkAligned toError =
72− P.Parser $ \state@(P.State _ _ indent row col) _ eok _ eerr ->
72+ P.Parser $ \state@(P.State _ _ _ indent row col) _ eok _ eerr ->
7373 if col == indent
7474 then eok () state
7575 else eerr row col (toError indent)
@@ -77,7 +77,7 @@ checkAligned toError =
7777
7878checkFreshLine :: (Row -> Col -> x) -> P.Parser x ()
7979checkFreshLine toError =
80− P.Parser $ \state@(P.State _ _ _ row col) _ eok _ eerr ->
80+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
8181 if col == 1
8282 then eok () state
8383 else eerr row col toError
@@ -89,7 +89,7 @@ checkFreshLine toError =
8989
9090chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x ()
9191chompAndCheckIndent toSpaceError toIndentError =
92− P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
92+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
9393 let
9494 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
9595 in
@@ -99,7 +99,7 @@ chompAndCheckIndent toSpaceError toIndentError =
9999 then
100100
101101 let
102− !newState = P.State newPos end indent newRow newCol
102+ !newState = P.State src newPos end indent newRow newCol
103103 in
104104 cok () newState
105105
@@ -108,7 +108,6 @@ chompAndCheckIndent toSpaceError toIndentError =
108108
109109 HasTab -> cerr newRow newCol (toSpaceError E.HasTab)
110110 EndlessMultiComment -> cerr newRow newCol (toSpaceError E.EndlessMultiComment)
111− UnexpectedDocComment -> cerr newRow newCol (toSpaceError E.UnexpectedDocComment)
112111
113112
114113
@@ -119,7 +118,6 @@ data Status
119118 = Good
120119 | HasTab
121120 | EndlessMultiComment
122− | UnexpectedDocComment
123121
124122
125123eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
@@ -159,7 +157,7 @@ eatSpaces pos end row col =
159157-- LINE COMMENTS
160158
161159
162−eatLineComment :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
160+eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
163161eatLineComment pos end row col =
164162 if pos >= end then
165163 (# Good, pos, row, col #)
@@ -169,7 +167,7 @@ eatLineComment pos end row col =
169167 if word == 0x0A {- \n -} then
170168 eatSpaces (plusPtr pos 1) end (row + 1) 1
171169 else
172− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
170+ let !newPos = plusPtr pos (P.getCharWidth word) in
173171 eatLineComment newPos end row (col + 1)
174172
175173
@@ -189,7 +187,7 @@ eatMultiComment pos end row col =
189187 else if P.unsafeIndex pos1 == 0x2D {- - -} then
190188
191189 if P.unsafeIndex pos2 == 0x7C {- | -} then
192− (# UnexpectedDocComment, pos, row, col #)
190+ (# Good, pos, row, col #)
193191 else
194192 let
195193 (# status, newPos, newRow, newCol #) =
@@ -210,7 +208,7 @@ data MultiStatus
210208 | MultiEndless
211209
212210
213−eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Word16, Word16 #)
211+eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)
214212eatMultiCommentHelp pos end row col openComments =
215213 if pos >= end then
216214 (# MultiEndless, pos, row, col #)
@@ -233,7 +231,7 @@ eatMultiCommentHelp pos end row col openComments =
233231 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
234232
235233 else
236− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
234+ let !newPos = plusPtr pos (P.getCharWidth word) in
237235 eatMultiCommentHelp newPos end row (col + 1) openComments
238236
239237
@@ -241,16 +239,9 @@ eatMultiCommentHelp pos end row col openComments =
241239-- DOCUMENTATION COMMENT
242240
243241
244−data DocComment =
245− DocComment
246− { _start :: Ptr Word8
247− , _end :: Ptr Word8
248− }
249−
250−
251−docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x DocComment
242+docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment
252243docComment toExpectation toSpaceError =
253− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
244+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
254245 let
255246 !pos3 = plusPtr pos 3
256247 in
@@ -260,14 +251,19 @@ docComment toExpectation toSpaceError =
260251 && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
261252 then
262253 let
254+ !col3 = col + 3
255+
263256 (# status, newPos, newRow, newCol #) =
264− eatMultiCommentHelp pos3 end row (col + 3) 1
257+ eatMultiCommentHelp pos3 end row col3 1
265258 in
266259 case status of
267260 MultiGood ->
268261 let
269− !comment = DocComment pos3 (plusPtr newPos (-2))
270− !newState = P.State newPos end indent newRow newCol
262+ !off = minusPtr pos3 (unsafeForeignPtrToPtr src)
263+ !len = minusPtr newPos pos3 - 2
264+ !snippet = P.Snippet src off len row col3
265+ !comment = Src.Comment snippet
266+ !newState = P.State src newPos end indent newRow newCol
271267 in
272268 cok comment newState
273269
compiler/src/Parse/Utf8.hs → compiler/src/Parse/String.hsrenamed+64−66
@@ -1,6 +1,6 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
22{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3−module Parse.Utf8
3+module Parse.String
44 ( string
55 , character
66 )
@@ -11,6 +11,7 @@ import qualified Data.Utf8 as Utf8
1111import Data.Word (Word8, Word16)
1212import Foreign.Ptr (Ptr, plusPtr, minusPtr)
1313
14+import qualified Elm.String as ES
1415import Parse.Primitives (Parser, Row, Col)
1516import qualified Parse.Number as Number
1617import qualified Parse.Primitives as P
@@ -21,39 +22,39 @@ import qualified Reporting.Error.Syntax as E
2122-- CHARACTER
2223
2324
24−character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x Utf8.String
25+character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x ES.String
2526character toExpectation toError =
26− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
27+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
2728 if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then
2829 eerr row col toExpectation
2930
3031 else
31− case chompChar (plusPtr pos 1) end (col + 1) 0 placeholder of
32+ case chompChar (plusPtr pos 1) end row (col + 1) 0 placeholder of
3233 Good newPos newCol numChars mostRecent ->
3334 if numChars /= 1 then
3435 cerr row col (toError (E.CharNotString (fromIntegral (newCol - col))))
3536 else
3637 let
37− !newState = P.State newPos end indent row newCol
38− !char = Utf8.fromChunks [mostRecent]
38+ !newState = P.State src newPos end indent row newCol
39+ !char = ES.fromChunks [mostRecent]
3940 in
4041 cok char newState
4142
4243 CharEndless newCol ->
4344 cerr row newCol (toError E.CharEndless)
4445
45− CharEscape newCol escape ->
46− cerr row newCol (toError (E.CharEscape escape))
46+ CharEscape r c escape ->
47+ cerr r c (toError (E.CharEscape escape))
4748
4849
4950data CharResult
50− = Good (Ptr Word8) Col Word16 Utf8.Chunk
51+ = Good (Ptr Word8) Col Word16 ES.Chunk
5152 | CharEndless Col
52− | CharEscape Col E.Escape
53+ | CharEscape Row Col E.Escape
5354
5455
55−chompChar :: Ptr Word8 -> Ptr Word8 -> Col -> Word16 -> Utf8.Chunk -> CharResult
56−chompChar pos end col numChars mostRecent =
56+chompChar :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> ES.Chunk -> CharResult
57+chompChar pos end row col numChars mostRecent =
5758 if pos >= end then
5859 CharEndless col
5960
@@ -68,37 +69,37 @@ chompChar pos end col numChars mostRecent =
6869 CharEndless col
6970
7071 else if word == 0x22 {- " -} then
71− chompChar (plusPtr pos 1) end (col + 1) (numChars + 1) doubleQuote
72+ chompChar (plusPtr pos 1) end row (col + 1) (numChars + 1) doubleQuote
7273
7374 else if word == 0x5C {- \ -} then
74− case eatEscape (plusPtr pos 1) end col of
75+ case eatEscape (plusPtr pos 1) end row col of
7576 EscapeNormal ->
76− chompChar (plusPtr pos 2) end (col + 2) (numChars + 1) (Utf8.Slice pos 2)
77+ chompChar (plusPtr pos 2) end row (col + 2) (numChars + 1) (ES.Slice pos 2)
7778
7879 EscapeUnicode delta code ->
79− chompChar (plusPtr pos delta) end (col + fromIntegral delta) (numChars + 1) (Utf8.CodePoint code)
80+ chompChar (plusPtr pos delta) end row (col + fromIntegral delta) (numChars + 1) (ES.CodePoint code)
8081
81− EscapeProblem badEscape ->
82− CharEscape col badEscape
82+ EscapeProblem r c badEscape ->
83+ CharEscape r c badEscape
8384
8485 EscapeEndOfFile ->
8586 CharEndless col
8687
8788 else
8889 let
89− !width = P.getCharWidth pos end word
90+ !width = P.getCharWidth word
9091 !newPos = plusPtr pos width
9192 in
92− chompChar newPos end (col + 1) (numChars + 1) (Utf8.Slice pos width)
93+ chompChar newPos end row (col + 1) (numChars + 1) (ES.Slice pos width)
9394
9495
9596
9697-- STRINGS
9798
9899
99−string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x Utf8.String
100+string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x ES.String
100101string toExpectation toError =
101− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
102+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
102103 if isDoubleQuote pos end then
103104
104105 let
@@ -121,7 +122,7 @@ string toExpectation toError =
121122 Ok newPos newRow newCol utf8 ->
122123 let
123124 !newState =
124− P.State newPos end indent newRow newCol
125+ P.State src newPos end indent newRow newCol
125126 in
126127 cok utf8 newState
127128
@@ -139,32 +140,32 @@ isDoubleQuote pos end =
139140
140141
141142data StringResult
142− = Ok (Ptr Word8) Row Col !Utf8.String
143+ = Ok (Ptr Word8) Row Col !ES.String
143144 | Err Row Col E.String
144145
145146
146−finalize :: Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> Utf8.String
147+finalize :: Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> ES.String
147148finalize start end revChunks =
148− Utf8.fromChunks $ reverse $
149+ ES.fromChunks $ reverse $
149150 if start == end then
150151 revChunks
151152 else
152− Utf8.Slice start (minusPtr end start) : revChunks
153+ ES.Slice start (minusPtr end start) : revChunks
153154
154155
155−addEscape :: Utf8.Chunk -> Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> [Utf8.Chunk]
156+addEscape :: ES.Chunk -> Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> [ES.Chunk]
156157addEscape chunk start end revChunks =
157158 if start == end then
158159 chunk : revChunks
159160 else
160− chunk : Utf8.Slice start (minusPtr end start) : revChunks
161+ chunk : ES.Slice start (minusPtr end start) : revChunks
161162
162163
163164
164165-- SINGLE STRINGS
165166
166167
167−singleString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Utf8.Chunk] -> StringResult
168+singleString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [ES.Chunk] -> StringResult
168169singleString pos end row col initialPos revChunks =
169170 if pos >= end then
170171 Err row col E.StringEndless_Single
@@ -186,23 +187,23 @@ singleString pos end row col initialPos revChunks =
186187 addEscape singleQuote initialPos pos revChunks
187188
188189 else if word == 0x5C {- \ -} then
189− case eatEscape (plusPtr pos 1) end col of
190+ case eatEscape (plusPtr pos 1) end row col of
190191 EscapeNormal ->
191192 singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks
192193
193194 EscapeUnicode delta code ->
194195 let !newPos = plusPtr pos delta in
195196 singleString newPos end row (col + fromIntegral delta) newPos $
196− addEscape (Utf8.CodePoint code) initialPos pos revChunks
197+ addEscape (ES.CodePoint code) initialPos pos revChunks
197198
198− EscapeProblem x ->
199− Err row col (E.StringEscape x)
199+ EscapeProblem r c x ->
200+ Err r c (E.StringEscape x)
200201
201202 EscapeEndOfFile ->
202203 Err row (col + 1) E.StringEndless_Single
203204
204205 else
205− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
206+ let !newPos = plusPtr pos (P.getCharWidth word) in
206207 singleString newPos end row (col + 1) initialPos revChunks
207208
208209
@@ -210,7 +211,7 @@ singleString pos end row col initialPos revChunks =
210211-- MULTI STRINGS
211212
212213
213−multiString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> Word16 -> Word16 -> [Utf8.Chunk] -> StringResult
214+multiString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> Row -> Col -> [ES.Chunk] -> StringResult
214215multiString pos end row col initialPos sr sc revChunks =
215216 if pos >= end then
216217 Err sr sc E.StringEndless_Multi
@@ -237,23 +238,23 @@ multiString pos end row col initialPos sr sc revChunks =
237238 addEscape carriageReturn initialPos pos revChunks
238239
239240 else if word == 0x5C {- \ -} then
240− case eatEscape (plusPtr pos 1) end col of
241+ case eatEscape (plusPtr pos 1) end row col of
241242 EscapeNormal ->
242243 multiString (plusPtr pos 2) end row (col + 2) initialPos sr sc revChunks
243244
244245 EscapeUnicode delta code ->
245246 let !newPos = plusPtr pos delta in
246247 multiString newPos end row (col + fromIntegral delta) newPos sr sc $
247− addEscape (Utf8.CodePoint code) initialPos pos revChunks
248+ addEscape (ES.CodePoint code) initialPos pos revChunks
248249
249− EscapeProblem x ->
250− Err row col (E.StringEscape x)
250+ EscapeProblem r c x ->
251+ Err r c (E.StringEscape x)
251252
252253 EscapeEndOfFile ->
253254 Err sr sc E.StringEndless_Multi
254255
255256 else
256− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
257+ let !newPos = plusPtr pos (P.getCharWidth word) in
257258 multiString newPos end row (col + 1) initialPos sr sc revChunks
258259
259260
@@ -265,11 +266,11 @@ data Escape
265266 = EscapeNormal
266267 | EscapeUnicode !Int !Int
267268 | EscapeEndOfFile
268− | EscapeProblem E.Escape
269+ | EscapeProblem Row Col E.Escape
269270
270271
271−eatEscape :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
272−eatEscape pos end startCol =
272+eatEscape :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
273+eatEscape pos end row col =
273274 if pos >= end then
274275 EscapeEndOfFile
275276
@@ -281,14 +282,14 @@ eatEscape pos end startCol =
281282 0x22 {- " -} -> EscapeNormal
282283 0x27 {- ' -} -> EscapeNormal
283284 0x5C {- \ -} -> EscapeNormal
284− 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end startCol
285− _ -> EscapeProblem (E.EscapeUnknown startCol (startCol + 1))
285+ 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end row col
286+ _ -> EscapeProblem row col E.EscapeUnknown
286287
287288
288−eatUnicode :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
289−eatUnicode pos end startCol =
289+eatUnicode :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
290+eatUnicode pos end row col =
290291 if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then
291− EscapeProblem $ E.BadUnicodeFormat startCol (startCol + 1)
292+ EscapeProblem row col (E.BadUnicodeFormat 2)
292293 else
293294 let
294295 !digitPos = plusPtr pos 1
@@ -296,18 +297,15 @@ eatUnicode pos end startCol =
296297 !numDigits = minusPtr newPos digitPos
297298 in
298299 if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then
299− EscapeProblem $ E.BadUnicodeFormat startCol $
300− startCol + fromIntegral (minusPtr newPos pos)
300+ EscapeProblem row col $ E.BadUnicodeFormat (2 + fromIntegral (minusPtr newPos pos))
301301
302302 else if code < 0 || 0x10FFFF < code then
303− EscapeProblem $ E.BadUnicodeCode startCol $
304− startCol + fromIntegral (minusPtr newPos pos) + 1
303+ EscapeProblem row col $ E.BadUnicodeCode (3 + fromIntegral (minusPtr newPos pos))
305304
306305 else if numDigits < 4 || 6 < numDigits then
307− EscapeProblem $
306+ EscapeProblem row col $
308307 E.BadUnicodeLength
309− startCol
310− (startCol + fromIntegral (minusPtr newPos pos) + 1)
308+ (3 + fromIntegral (minusPtr newPos pos))
311309 numDigits
312310 code
313311
@@ -316,30 +314,30 @@ eatUnicode pos end startCol =
316314
317315
318316{-# NOINLINE singleQuote #-}
319−singleQuote :: Utf8.Chunk
317+singleQuote :: ES.Chunk
320318singleQuote =
321− Utf8.Escape 0x27 {- ' -}
319+ ES.Escape 0x27 {-'-}
322320
323321
324322{-# NOINLINE doubleQuote #-}
325−doubleQuote :: Utf8.Chunk
323+doubleQuote :: ES.Chunk
326324doubleQuote =
327− Utf8.Escape 0x22 {- " -}
325+ ES.Escape 0x22 {-"-}
328326
329327
330328{-# NOINLINE newline #-}
331−newline :: Utf8.Chunk
329+newline :: ES.Chunk
332330newline =
333− Utf8.Escape 0x6E {- n -}
331+ ES.Escape 0x6E {-n-}
334332
335333
336334{-# NOINLINE carriageReturn #-}
337−carriageReturn :: Utf8.Chunk
335+carriageReturn :: ES.Chunk
338336carriageReturn =
339− Utf8.Escape 0x72 {- \r -}
337+ ES.Escape 0x72 {-r-}
340338
341339
342340{-# NOINLINE placeholder #-}
343−placeholder :: Utf8.Chunk
341+placeholder :: ES.Chunk
344342placeholder =
345− Utf8.CodePoint 0xFFFD {- replacement character -}
343+ ES.CodePoint 0xFFFD {-replacement character-}
compiler/src/Parse/Symbol.hs+19−34
@@ -1,8 +1,9 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
33module Parse.Symbol
4− ( wildcard
5− , operator
4+ ( operator
5+ , BadOperator(..)
6+ , binopCharSet
67 )
78 where
89
@@ -15,55 +16,39 @@ import Foreign.Ptr (Ptr, plusPtr, minusPtr)
1516import GHC.Word (Word8)
1617
1718import Parse.Primitives (Parser, Row, Col)
18−import qualified Parse.Variable as Var
1919import qualified Parse.Primitives as P
20−import qualified Reporting.Error.Syntax as E
2120
2221
2322
24−-- UNDERSCORE
25−
26−
27−wildcard :: Parser E.Pattern ()
28−wildcard =
29− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
30− if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
31− eerr row col E.PStart
32− else
33− let
34− !newPos = plusPtr pos 1
35− !newCol = col + 1
36− in
37− if Var.getInnerWidth newPos end > 0 then
38− let (# _, badCol #) = Var.chompInnerChars newPos end newCol in
39− cerr row col (E.PWildcardNotVar (fromIntegral (badCol - col)))
40− else
41− let !newState = P.State newPos end indent row newCol in
42− cok () newState
43−
23+-- OPERATOR
4424
4525
46−-- OPERATOR
26+data BadOperator
27+ = BadDot
28+ | BadPipe
29+ | BadArrow
30+ | BadEquals
31+ | BadHasType
4732
4833
49−operator :: (Row -> Col -> x) -> (E.Operator -> Row -> Col -> x) -> Parser x Name.Name
34+operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name
5035operator toExpectation toError =
51− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
36+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
5237 let !newPos = chompOps pos end in
5338 if pos == newPos then
5439 eerr row col toExpectation
5540
5641 else
5742 case Name.fromPtr pos newPos of
58− "." -> cerr row col (toError E.OpDot)
59− "|" -> cerr row col (toError E.OpPipe)
60− "->" -> cerr row col (toError E.OpArrow)
61− "=" -> cerr row col (toError E.OpEquals)
62− ":" -> cerr row col (toError E.OpHasType)
43+ "." -> eerr row col (toError BadDot)
44+ "|" -> cerr row col (toError BadPipe)
45+ "->" -> cerr row col (toError BadArrow)
46+ "=" -> cerr row col (toError BadEquals)
47+ ":" -> cerr row col (toError BadHasType)
6348 op ->
6449 let
6550 !newCol = col + fromIntegral (minusPtr newPos pos)
66− !newState = P.State newPos end indent row newCol
51+ !newState = P.State src newPos end indent row newCol
6752 in
6853 cok op newState
6954
compiler/src/Parse/Type.hs+3−3
@@ -47,7 +47,7 @@ term =
4747 oneOf E.TTupleOpen
4848 [ do word1 0x29 {-)-} E.TTupleOpen
4949 addEnd start Src.TUnit
50− , do Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType
50+ , do Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType1
5151 (tipe, end) <- specialize E.TTupleType expression
5252 Space.checkIndent end E.TTupleIndentEnd
5353 chompTupleEnd start tipe []
@@ -95,7 +95,7 @@ expression =
9595 ]
9696 oneOfWithFallback
9797 [ do Space.checkIndent end1 E.TIndentStart -- should never trigger
98− word2 0x2D 0x3E {-->-} E.TArrow
98+ word2 0x2D 0x3E {-->-} E.TStart -- could just be another type instead
9999 Space.chompAndCheckIndent E.TSpace E.TIndentStart
100100 (tipe2, end2) <- expression
101101 let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
@@ -147,7 +147,7 @@ chompTupleEnd :: A.Position -> Src.Type -> [Src.Type] -> Parser E.TTuple Src.Typ
147147chompTupleEnd start firstType revTypes =
148148 oneOf E.TTupleEnd
149149 [ do word1 0x2C {-,-} E.TTupleEnd
150− Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType
150+ Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentTypeN
151151 (tipe, end) <- specialize E.TTupleType expression
152152 Space.checkIndent end E.TTupleIndentEnd
153153 chompTupleEnd start firstType (tipe : revTypes)
compiler/src/Parse/Variable.hs+30−23
@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
33module Parse.Variable
44 ( lower
55 , upper
@@ -8,8 +8,10 @@ module Parse.Variable
88 , foreignUpper
99 , foreignAlpha
1010 , chompInnerChars
11+ , getUpperWidth
1112 , getInnerWidth
1213 , getInnerWidthHelp
14+ , reservedWords
1315 )
1416 where
1517
@@ -33,13 +35,13 @@ import qualified Parse.Primitives as P
3335
3436upper :: (Row -> Col -> x) -> Parser x Name.Name
3537upper toError =
36− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
38+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
3739 let (# newPos, newCol #) = chompUpper pos end col in
3840 if pos == newPos then
3941 eerr row col toError
4042 else
4143 let !name = Name.fromPtr pos newPos in
42− cok name (P.State newPos end indent row newCol)
44+ cok name (P.State src newPos end indent row newCol)
4345
4446
4547
@@ -48,7 +50,7 @@ upper toError =
4850
4951lower :: (Row -> Col -> x) -> Parser x Name.Name
5052lower toError =
51− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
53+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
5254 let (# newPos, newCol #) = chompLower pos end col in
5355 if pos == newPos then
5456 eerr row col toError
@@ -59,13 +61,13 @@ lower toError =
5961 else
6062 let
6163 !newState =
62− P.State newPos end indent row newCol
64+ P.State src newPos end indent row newCol
6365 in
6466 cok name newState
6567
6668
6769{-# NOINLINE reservedWords #-}
68−reservedWords :: Set.Set Name.Name -- TODO try using a trie instead
70+reservedWords :: Set.Set Name.Name -- PERF try using a trie instead
6971reservedWords =
7072 Set.fromList
7173 [ "if", "then", "else"
@@ -85,21 +87,26 @@ reservedWords =
8587
8688moduleName :: (Row -> Col -> x) -> Parser x Name.Name
8789moduleName toError =
88− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
90+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
8991 let
9092 (# pos1, col1 #) = chompUpper pos end col
91− (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
9293 in
93− case status of
94− Good ->
95− let
96− !name = Name.fromPtr pos newPos
97− !newState = P.State newPos end indent row newCol
98− in
99− cok name newState
94+ if pos == pos1 then
95+ eerr row col toError
96+ else
97+ let
98+ (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
99+ in
100+ case status of
101+ Good ->
102+ let
103+ !name = Name.fromPtr pos newPos
104+ !newState = P.State src newPos end indent row newCol
105+ in
106+ cok name newState
100107
101− Bad ->
102− eerr row newCol toError
108+ Bad ->
109+ cerr row newCol toError
103110
104111
105112data ModuleNameStatus
@@ -134,22 +141,22 @@ data Upper
134141
135142foreignUpper :: (Row -> Col -> x) -> Parser x Upper
136143foreignUpper toError =
137− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
144+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
138145 let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
139146 if upperStart == upperEnd then
140147 eerr row newCol toError
141148 else
142149 let
143− !newState = P.State upperEnd end indent row newCol
150+ !newState = P.State src upperEnd end indent row newCol
144151 !name = Name.fromPtr upperStart upperEnd
145− !foreign =
152+ !upperName =
146153 if upperStart == pos then
147154 Unqualified name
148155 else
149156 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
150157 Qualified home name
151158 in
152− cok foreign newState
159+ cok upperName newState
153160
154161
155162foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
@@ -173,13 +180,13 @@ foreignUpperHelp pos end col =
173180
174181foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_
175182foreignAlpha toError =
176− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
183+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
177184 let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
178185 if alphaStart == alphaEnd then
179186 eerr row newCol toError
180187 else
181188 let
182− !newState = P.State alphaEnd end indent row newCol
189+ !newState = P.State src alphaEnd end indent row newCol
183190 !name = Name.fromPtr alphaStart alphaEnd
184191 in
185192 if alphaStart == pos then
compiler/src/Reporting/Annotation.hs+1−1
@@ -26,7 +26,7 @@ import Data.Word (Word16)
2626
2727
2828data Located a =
29− At Region a -- TODO see if unpacking region is helpful
29+ At Region a -- PERF see if unpacking region is helpful
3030
3131
3232instance Functor Located where
compiler/src/Reporting/Doc.hs+79−47
@@ -7,16 +7,38 @@ module Reporting.Doc
77 , P.hcat, P.hsep, P.indent, P.sep, P.vcat
88 , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow
99 , P.dullred, P.dullcyan, P.dullyellow
10−
11− , fromChars, fromName, fromInt, fromUtf8
12− , toAnsi, toString, toLine
10+ --
11+ , fromChars
12+ , fromName
13+ , fromVersion
14+ , fromPackage
15+ , fromInt
16+ --
17+ , toAnsi
18+ , toString
19+ , toLine
20+ --
1321 , encode
14−
15− , stack, reflow, commaSep
16− , toSimpleNote, toSimpleHint, toFancyHint
17− , link, fancyLink, reflowLink, makeLink, makeNakedLink
18− , args, moreArgs
19− , ordinal, intToOrdinal
22+ --
23+ , stack
24+ , reflow
25+ , commaSep
26+ --
27+ , toSimpleNote
28+ , toFancyNote
29+ , toSimpleHint
30+ , toFancyHint
31+ --
32+ , link
33+ , fancyLink
34+ , reflowLink
35+ , makeLink
36+ , makeNakedLink
37+ --
38+ , args
39+ , moreArgs
40+ , ordinal
41+ , intToOrdinal
2042 , cycle
2143 )
2244 where
@@ -26,14 +48,17 @@ import Prelude hiding (cycle)
2648import qualified Data.List as List
2749import Data.Monoid ((<>))
2850import qualified Data.Name as Name
29−import qualified Data.Utf8 as Utf8
3051import qualified System.Console.ANSI.Types as Ansi
3152import qualified System.Info as Info
3253import System.IO (Handle)
3354import qualified Text.PrettyPrint.ANSI.Leijen as P
3455
3556import qualified Data.Index as Index
57+import qualified Elm.Package as Pkg
58+import qualified Elm.Version as V
59+import Json.Encode ((==>))
3660import qualified Json.Encode as E
61+import qualified Json.String as Json
3762
3863
3964
@@ -50,16 +75,21 @@ fromName name =
5075 P.text (Name.toChars name)
5176
5277
78+fromVersion :: V.Version -> P.Doc
79+fromVersion vsn =
80+ P.text (V.toChars vsn)
81+
82+
83+fromPackage :: Pkg.Name -> P.Doc
84+fromPackage pkg =
85+ P.text (Pkg.toChars pkg)
86+
87+
5388fromInt :: Int -> P.Doc
5489fromInt n =
5590 P.text (show n)
5691
5792
58−fromUtf8 :: Utf8.String -> P.Doc
59−fromUtf8 utf8 =
60− P.text (Utf8.toChars utf8)
61−
62−
6393
6494-- TO STRING
6595
@@ -111,12 +141,21 @@ commaSep conjunction addStyle names =
111141
112142
113143
114−-- HINTS
144+-- NOTES
115145
116146
117147toSimpleNote :: String -> P.Doc
118148toSimpleNote message =
119− P.fillSep ((P.underline "Note" <> ":") : map P.text (words message))
149+ toFancyNote (map P.text (words message))
150+
151+
152+toFancyNote :: [P.Doc] -> P.Doc
153+toFancyNote chunks =
154+ P.fillSep (P.underline "Note" <> ":" : chunks)
155+
156+
157+
158+-- HINTS
120159
121160
122161toSimpleHint :: String -> P.Doc
@@ -133,32 +172,32 @@ toFancyHint chunks =
133172-- LINKS
134173
135174
136−link :: P.Doc -> String -> String -> String -> P.Doc
175+link :: String -> String -> String -> String -> P.Doc
137176link word before fileName after =
138177 P.fillSep $
139− (P.underline word <> ":")
178+ (P.underline (P.text word) <> ":")
140179 : map P.text (words before)
141180 ++ P.text (makeLink fileName)
142181 : map P.text (words after)
143182
144183
145−fancyLink :: P.Doc -> [P.Doc] -> String -> [P.Doc] -> P.Doc
184+fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
146185fancyLink word before fileName after =
147186 P.fillSep $
148− (P.underline word <> ":") : before ++ P.text (makeLink fileName) : after
187+ (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after
149188
150189
151−makeLink :: String -> String
190+makeLink :: [Char] -> [Char]
152191makeLink fileName =
153− "<https://elm-lang.org/" <> error "TODO V.toString V.compiler" <> "/" <> fileName <> ">"
192+ "<https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName <> ">"
154193
155194
156−makeNakedLink :: String -> String
195+makeNakedLink :: [Char] -> [Char]
157196makeNakedLink fileName =
158− "https://elm-lang.org/" <> error "TODO V.toString V.compiler" <> "/" <> fileName
197+ "https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName
159198
160199
161−reflowLink :: String -> String -> String -> P.Doc
200+reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc
162201reflowLink before fileName after =
163202 P.fillSep $
164203 map P.text (words before)
@@ -267,10 +306,8 @@ data Color
267306 | WHITE
268307
269308
270−toJsonHelp :: Style -> [a] -> P.SimpleDoc -> [E.Value]
309+toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value]
271310toJsonHelp style revChunks simpleDoc =
272− error "TODO generate json on errors" style revChunks simpleDoc sgrToStyle encodeColor
273−{-
274311 case simpleDoc of
275312 P.SFail ->
276313 error $
@@ -281,23 +318,18 @@ toJsonHelp style revChunks simpleDoc =
281318 [ encodeChunks style revChunks ]
282319
283320 P.SChar char rest ->
284− toJsonHelp style (TB.singleton char : revChunks) rest
321+ toJsonHelp style ([char] : revChunks) rest
285322
286323 P.SText _ string rest ->
287− toJsonHelp style (TB.fromString string : revChunks) rest
324+ toJsonHelp style (string : revChunks) rest
288325
289326 P.SLine indent rest ->
290− toJsonHelp style (spaces indent : "\n" : revChunks) rest
327+ toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest
291328
292329 P.SSGR sgrs rest ->
293330 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
294331
295332
296−spaces :: Int -> TB.Builder
297−spaces n =
298− TB.fromText (Text.replicate n " ")
299−-}
300−
301333sgrToStyle :: [Ansi.SGR] -> Style -> Style
302334sgrToStyle sgrs style@(Style bold underline color) =
303335 case sgrs of
@@ -358,28 +390,28 @@ toColor layer intensity color =
358390 Ansi.White -> pick White WHITE
359391 Ansi.Black -> pick Black BLACK
360392
361−{-
362−encodeChunks :: Style -> [TB.Builder] -> E.Value
393+
394+encodeChunks :: Style -> [String] -> E.Value
363395encodeChunks (Style bold underline color) revChunks =
364396 let
365− !str = Utf8.concat (reverse revChunks)
397+ chars = concat (reverse revChunks)
366398 in
367399 case color of
368400 Nothing | not bold && not underline ->
369− E.string str
401+ E.chars chars
370402
371403 _ ->
372404 E.object
373− [ ("bold", E.bool bold)
374− , ("underline", E.bool underline)
375− , ("color", maybe E.null encodeColor color)
376− , ("string", E.string str)
405+ [ "bold" ==> E.bool bold
406+ , "underline" ==> E.bool underline
407+ , "color" ==> maybe E.null encodeColor color
408+ , "string" ==> E.chars chars
377409 ]
378−-}
410+
379411
380412encodeColor :: Color -> E.Value
381413encodeColor color =
382− E.string $
414+ E.string $ Json.fromChars $
383415 case color of
384416 Red -> "red"
385417 RED -> "RED"
compiler/src/Reporting/Error.hs+36−33
@@ -10,10 +10,9 @@ module Reporting.Error
1010
1111
1212import qualified Data.ByteString as B
13−import qualified Data.Name as Name
1413import qualified Data.NonEmptyList as NE
1514import qualified Data.OneOrMore as OneOrMore
16−import qualified Data.Utf8 as Utf8
15+import qualified System.FilePath as FP
1716
1817import qualified Elm.ModuleName as ModuleName
1918import qualified File
@@ -22,6 +21,7 @@ import Json.Encode ((==>))
2221import qualified Reporting.Annotation as A
2322import qualified Reporting.Doc as D
2423import qualified Reporting.Error.Canonicalize as Canonicalize
24+import qualified Reporting.Error.Docs as Docs
2525import qualified Reporting.Error.Import as Import
2626import qualified Reporting.Error.Main as Main
2727import qualified Reporting.Error.Pattern as Pattern
@@ -39,8 +39,8 @@ import qualified Reporting.Report as Report
3939data Module =
4040 Module
4141 { _name :: ModuleName.Raw
42− , _path :: FilePath
43− , _time :: File.Time
42+ , _absolutePath :: FilePath
43+ , _modificationTime :: File.Time
4444 , _source :: B.ByteString
4545 , _error :: Error
4646 }
@@ -57,6 +57,7 @@ data Error
5757 | BadTypes L.Localizer (NE.List Type.Error)
5858 | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error)
5959 | BadPatterns (NE.List Pattern.Error)
60+ | BadDocs Docs.Error
6061
6162
6263
@@ -84,30 +85,34 @@ toReports source err =
8485 BadPatterns errs ->
8586 fmap (Pattern.toReport source) errs
8687
88+ BadDocs docsErr ->
89+ Docs.toReports source docsErr
90+
8791
8892
8993-- TO DOC
9094
9195
92−toDoc :: NE.List Module -> D.Doc
93−toDoc modules =
96+toDoc :: FilePath -> Module -> [Module] -> D.Doc
97+toDoc root err errs =
9498 let
95− timeCompare m1 m2 = compare (_time m1) (_time m2)
96− (NE.List m ms) = NE.sortBy timeCompare modules
99+ (NE.List m ms) = NE.sortBy _modificationTime (NE.List err errs)
97100 in
98− D.vcat (toDocHelp m ms)
101+ D.vcat (toDocHelp root m ms)
99102
100103
101−toDocHelp :: Module -> [Module] -> [D.Doc]
102−toDocHelp module1 modules =
104+toDocHelp :: FilePath -> Module -> [Module] -> [D.Doc]
105+toDocHelp root module1 modules =
103106 case modules of
104107 [] ->
105− [moduleToDoc module1]
108+ [moduleToDoc root module1
109+ ,""
110+ ]
106111
107112 module2 : otherModules ->
108− moduleToDoc module1
113+ moduleToDoc root module1
109114 : toSeparator module1 module2
110− : toDocHelp module2 otherModules
115+ : toDocHelp root module2 otherModules
111116
112117
113118toSeparator :: Module -> Module -> D.Doc
@@ -129,19 +134,22 @@ toSeparator beforeModule afterModule =
129134-- MODULE TO DOC
130135
131136
132−moduleToDoc :: Module -> D.Doc
133−moduleToDoc (Module _ path _ source err) =
137+moduleToDoc :: FilePath -> Module -> D.Doc
138+moduleToDoc root (Module _ absolutePath _ source err) =
134139 let
135140 reports =
136141 toReports (Code.toSource source) err
142+
143+ relativePath =
144+ FP.makeRelative root absolutePath
137145 in
138− D.vcat $ map (reportToDoc path) (NE.toList reports)
146+ D.vcat $ map (reportToDoc relativePath) (NE.toList reports)
139147
140148
141149reportToDoc :: FilePath -> Report.Report -> D.Doc
142−reportToDoc path (Report.Report title _ _ message) =
150+reportToDoc relativePath (Report.Report title _ _ message) =
143151 D.vcat
144− [ toMessageBar title path
152+ [ toMessageBar title relativePath
145153 , ""
146154 , message
147155 , ""
@@ -164,20 +172,15 @@ toMessageBar title filePath =
164172-- TO JSON
165173
166174
167−toJson :: NE.List Module -> E.Value
168−toJson modules =
169− E.array (map moduleToJson (NE.toList modules))
170−
171−
172−moduleToJson :: Module -> E.Value
173−moduleToJson (Module name path _ source err) =
175+toJson :: Module -> E.Value
176+toJson (Module name path _ source err) =
174177 let
175178 reports =
176179 toReports (Code.toSource source) err
177180 in
178181 E.object
179− [ "path" ==> E.string (Utf8.fromChars path)
180− , "name" ==> E.string (Name.toUtf8 name)
182+ [ "path" ==> E.chars path
183+ , "name" ==> E.name name
181184 , "problems" ==> E.array (map reportToJson (NE.toList reports))
182185 ]
183186
@@ -185,7 +188,7 @@ moduleToJson (Module name path _ source err) =
185188reportToJson :: Report.Report -> E.Value
186189reportToJson (Report.Report title region _sgstns message) =
187190 E.object
188− [ "title" ==> E.string (Utf8.fromChars title)
191+ [ "title" ==> E.chars title
189192 , "region" ==> encodeRegion region
190193 , "message" ==> D.encode message
191194 ]
@@ -196,12 +199,12 @@ encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
196199 E.object
197200 [ "start" ==>
198201 E.object
199− [ ("line", E.int (fromIntegral sr))
200− , ("column", E.int (fromIntegral sc))
202+ [ "line" ==> E.int (fromIntegral sr)
203+ , "column" ==> E.int (fromIntegral sc)
201204 ]
202205 , "end" ==>
203206 E.object
204− [ ("line", E.int (fromIntegral er))
205− , ("column", E.int (fromIntegral ec))
207+ [ "line" ==> E.int (fromIntegral er)
208+ , "column" ==> E.int (fromIntegral ec)
206209 ]
207210 ]
compiler/src/Reporting/Error/Canonicalize.hs+74−73
@@ -14,8 +14,10 @@ module Reporting.Error.Canonicalize
1414
1515
1616import qualified Data.Char as Char
17+import qualified Data.List as List
1718import qualified Data.Map as Map
1819import qualified Data.Name as Name
20+import qualified Data.OneOrMore as OneOrMore
1921import qualified Data.Set as Set
2022
2123import qualified AST.Canonical as Can
@@ -37,10 +39,10 @@ import qualified Reporting.Suggest as Suggest
3739
3840data Error
3941 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
40− | AmbiguousVar A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
41− | AmbiguousType A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
42− | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
43− | AmbiguousBinop A.Region Name.Name [ModuleName.Canonical]
42+ | AmbiguousVar A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
43+ | AmbiguousType A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
44+ | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
45+ | AmbiguousBinop A.Region Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
4446 | BadArity A.Region BadArityContext Name.Name Int Int
4547 | Binop A.Region Name.Name Name.Name
4648 | DuplicateDecl Name.Name A.Region A.Region
@@ -151,7 +153,7 @@ toReport source err =
151153 numDefArgs = numTypeArgs + leftovers
152154 in
153155 Report.Report "BAD TYPE ANNOTATION" region [] $
154− Report.toCodeSnippet source region Nothing
156+ Code.toSnippet source region Nothing
155157 (
156158 D.reflow $
157159 "The type annotation for `" <> Name.toChars name <> "` says it can accept "
@@ -164,17 +166,17 @@ toReport source err =
164166 <> " be deleted? Maybe some parentheses are missing?"
165167 )
166168
167− AmbiguousVar region maybePrefix name possibleHomes ->
168− ambiguousName source region maybePrefix name possibleHomes "variable"
169+ AmbiguousVar region maybePrefix name h hs ->
170+ ambiguousName source region maybePrefix name h hs "variable"
169171
170− AmbiguousType region maybePrefix name possibleHomes ->
171− ambiguousName source region maybePrefix name possibleHomes "type"
172+ AmbiguousType region maybePrefix name h hs ->
173+ ambiguousName source region maybePrefix name h hs "type"
172174
173− AmbiguousVariant region maybePrefix name possibleHomes ->
174− ambiguousName source region maybePrefix name possibleHomes "variant"
175+ AmbiguousVariant region maybePrefix name h hs ->
176+ ambiguousName source region maybePrefix name h hs "variant"
175177
176− AmbiguousBinop region name possibleHomes ->
177− ambiguousName source region Nothing name possibleHomes "operator"
178+ AmbiguousBinop region name h hs ->
179+ ambiguousName source region Nothing name h hs "operator"
178180
179181 BadArity region badArityContext name expected actual ->
180182 let
@@ -185,7 +187,7 @@ toReport source err =
185187 in
186188 if actual < expected then
187189 Report.Report "TOO FEW ARGS" region [] $
188− Report.toCodeSnippet source region Nothing
190+ Code.toSnippet source region Nothing
189191 (
190192 D.reflow $
191193 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
@@ -197,7 +199,7 @@ toReport source err =
197199
198200 else
199201 Report.Report "TOO MANY ARGS" region [] $
200− Report.toCodeSnippet source region Nothing
202+ Code.toSnippet source region Nothing
201203 (
202204 D.reflow $
203205 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
@@ -211,7 +213,7 @@ toReport source err =
211213
212214 Binop region op1 op2 ->
213215 Report.Report "INFIX PROBLEM" region [] $
214− Report.toCodeSnippet source region Nothing
216+ Code.toSnippet source region Nothing
215217 (
216218 D.reflow $
217219 "You cannot mix (" <> Name.toChars op1 <> ") and (" <> Name.toChars op2 <> ") without parentheses."
@@ -242,11 +244,11 @@ toReport source err =
242244
243245 DuplicateAliasArg typeName name r1 r2 ->
244246 nameClash source r1 r2 $
245− "The `" <> Name.toChars typeName <> "` type alias has multilpe `" <> Name.toChars name <> "` type variables."
247+ "The `" <> Name.toChars typeName <> "` type alias has multiple `" <> Name.toChars name <> "` type variables."
246248
247249 DuplicateUnionArg typeName name r1 r2 ->
248250 nameClash source r1 r2 $
249− "The `" <> Name.toChars typeName <> "` type has multilpe `" <> Name.toChars name <> "` type variables."
251+ "The `" <> Name.toChars typeName <> "` type has multiple `" <> Name.toChars name <> "` type variables."
250252
251253 DuplicatePattern context name r1 r2 ->
252254 nameClash source r1 r2 $
@@ -268,18 +270,18 @@ toReport source err =
268270
269271 EffectNotFound region name ->
270272 Report.Report "EFFECT PROBLEM" region [] $
271− Report.toCodeSnippet source region Nothing
273+ Code.toSnippet source region Nothing
272274 (
273275 D.reflow $
274276 "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
275277 ,
276278 D.reflow $
277− "But I cannot find a union type named `" ++ Name.toChars name ++ "` in this file!"
279+ "But I cannot find a custom type named `" ++ Name.toChars name ++ "` in this file!"
278280 )
279281
280282 EffectFunctionNotFound region name ->
281283 Report.Report "EFFECT PROBLEM" region [] $
282− Report.toCodeSnippet source region Nothing
284+ Code.toSnippet source region Nothing
283285 (
284286 D.reflow $
285287 "This kind of effect module must define a `" ++ Name.toChars name ++ "` function."
@@ -295,7 +297,7 @@ toReport source err =
295297 "You are trying to expose `" <> Name.toChars name <> "` multiple times!"
296298 in
297299 Report.Report "REDUNDANT EXPORT" r2 [] $
298− Report.toCodePair source r1 r2
300+ Code.toPair source r1 r2
299301 (
300302 D.reflow messageThatEndsWithPunctuation
301303 ,
@@ -339,10 +341,10 @@ toReport source err =
339341
340342 ExportOpenAlias region name ->
341343 Report.Report "BAD EXPORT" region [] $
342− Report.toCodeSnippet source region Nothing
344+ Code.toSnippet source region Nothing
343345 (
344346 D.reflow $
345− "The (..) syntax is for exposing union type constructors. It cannot be used with a type alias like `"
347+ "The (..) syntax is for exposing variants of a custom type. It cannot be used with a type alias like `"
346348 ++ Name.toChars name ++ "` though."
347349 ,
348350 D.reflow $
@@ -351,16 +353,16 @@ toReport source err =
351353
352354 ImportCtorByName region ctor tipe ->
353355 Report.Report "BAD IMPORT" region [] $
354− Report.toCodeSnippet source region Nothing
356+ Code.toSnippet source region Nothing
355357 (
356358 D.reflow $
357359 "You are trying to import the `" <> Name.toChars ctor
358− <> "` type constructor by name:"
360+ <> "` variant by name:"
359361 ,
360362 D.fillSep
361363 ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
362364 ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
363− ,"all","its","constructors”","so","it","gives","you","access","to"
365+ ,"all","its","variants","so","it","gives","you","access","to"
364366 , D.fromName ctor <> "."
365367 ]
366368 )
@@ -371,7 +373,7 @@ toReport source err =
371373 -- So this error should never actually get printed out.
372374 --
373375 Report.Report "UNKNOWN IMPORT" region [] $
374− Report.toCodeSnippet source region Nothing
376+ Code.toSnippet source region Nothing
375377 (
376378 D.reflow $
377379 "I could not find a `" <> Name.toChars name <> "` module to import!"
@@ -381,18 +383,13 @@ toReport source err =
381383
382384 ImportOpenAlias region name ->
383385 Report.Report "BAD IMPORT" region [] $
384− Report.toCodeSnippet source region Nothing
386+ Code.toSnippet source region Nothing
385387 (
386388 D.reflow $
387389 "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
388390 ,
389− D.stack
390− [ "Remove the (..) and it should work."
391− , D.link "Hint"
392− "The distinction between `type` and `type alias` is important here. Read"
393− "types-vs-type-aliases"
394− "to learn more."
395− ]
391+ D.reflow $
392+ "Remove the (..) and it should work."
396393 )
397394
398395 ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
@@ -402,7 +399,7 @@ toReport source err =
402399 Suggest.sort (Name.toChars home) Name.toChars possibleNames
403400 in
404401 Report.Report "BAD IMPORT" region suggestions $
405− Report.toCodeSnippet source region Nothing
402+ Code.toSnippet source region Nothing
406403 (
407404 D.reflow $
408405 "The `" <> Name.toChars home
@@ -435,7 +432,7 @@ toReport source err =
435432 NotFoundBinop region op locals ->
436433 if op == "===" then
437434 Report.Report "UNKNOWN OPERATOR" region ["=="] $
438− Report.toCodeSnippet source region Nothing
435+ Code.toSnippet source region Nothing
439436 (
440437 "Elm does not have a (===) operator like JavaScript."
441438 ,
@@ -444,7 +441,7 @@ toReport source err =
444441
445442 else if op == "!=" || op == "!==" then
446443 Report.Report "UNKNOWN OPERATOR" region ["/="] $
447− Report.toCodeSnippet source region Nothing
444+ Code.toSnippet source region Nothing
448445 (
449446 D.reflow $
450447 "Elm uses a different name for the “not equal” operator:"
@@ -459,7 +456,7 @@ toReport source err =
459456
460457 else if op == "**" then
461458 Report.Report "UNKNOWN OPERATOR" region ["^","*"] $
462− Report.toCodeSnippet source region Nothing
459+ Code.toSnippet source region Nothing
463460 (
464461 D.reflow $
465462 "I do not recognize the (**) operator:"
@@ -470,7 +467,7 @@ toReport source err =
470467
471468 else if op == "%" then
472469 Report.Report "UNKNOWN OPERATOR" region [] $
473− Report.toCodeSnippet source region Nothing
470+ Code.toSnippet source region Nothing
474471 (
475472 D.reflow $
476473 "Elm does not use (%) as the remainder operator:"
@@ -497,7 +494,7 @@ toReport source err =
497494 D.green $ "(" <> altOp <> ")"
498495 in
499496 Report.Report "UNKNOWN OPERATOR" region suggestions $
500− Report.toCodeSnippet source region Nothing
497+ Code.toSnippet source region Nothing
501498 (
502499 D.reflow $
503500 "I do not recognize the (" ++ Name.toChars op ++ ") operator."
@@ -515,21 +512,21 @@ toReport source err =
515512
516513 PatternHasRecordCtor region name ->
517514 Report.Report "BAD PATTERN" region [] $
518− Report.toCodeSnippet source region Nothing
515+ Code.toSnippet source region Nothing
519516 (
520517 D.reflow $
521518 "You can construct records by using `" <> Name.toChars name
522519 <> "` as a function, but it is not available in pattern matching like this:"
523520 ,
524521 D.reflow $
525− "I recommend matching matching the record as a variable and unpacking it later."
522+ "I recommend matching the record as a variable and unpacking it later."
526523 )
527524
528525 PortPayloadInvalid region portName _badType invalidPayload ->
529526 let
530527 formatDetails (aBadKindOfThing, elaboration) =
531528 Report.Report "PORT ERROR" region [] $
532− Report.toCodeSnippet source region Nothing
529+ Code.toSnippet source region Nothing
533530 (
534531 D.reflow $
535532 "The `" <> Name.toChars portName <> "` port is trying to transmit " <> aBadKindOfThing <> ":"
@@ -595,7 +592,7 @@ toReport source err =
595592 let
596593 formatDetails (before, after) =
597594 Report.Report "BAD PORT" region [] $
598− Report.toCodeSnippet source region Nothing $
595+ Code.toSnippet source region Nothing $
599596 (
600597 D.reflow before
601598 ,
@@ -674,7 +671,7 @@ toReport source err =
674671 D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details)
675672 in
676673 Report.Report "CYCLIC DEFINITION" region [] $
677− Report.toCodeSnippet source region Nothing $
674+ Code.toSnippet source region Nothing $
678675 case names of
679676 [] ->
680677 (
@@ -682,7 +679,7 @@ toReport source err =
682679 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
683680 ,
684681 D.stack
685− [ makeTheory "Are you are trying to mutate a variable?" $
682+ [ makeTheory "Are you trying to mutate a variable?" $
686683 "Elm does not have mutation, so when I see " ++ Name.toChars name
687684 ++ " defined in terms of " ++ Name.toChars name
688685 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -716,7 +713,7 @@ toReport source err =
716713
717714 RecursiveLet (A.At region name) names ->
718715 Report.Report "CYCLIC VALUE" region [] $
719− Report.toCodeSnippet source region Nothing $
716+ Code.toSnippet source region Nothing $
720717 case names of
721718 [] ->
722719 let
@@ -728,7 +725,7 @@ toReport source err =
728725 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
729726 ,
730727 D.stack
731− [ makeTheory "Are you are trying to mutate a variable?" $
728+ [ makeTheory "Are you trying to mutate a variable?" $
732729 "Elm does not have mutation, so when I see " ++ Name.toChars name
733730 ++ " defined in terms of " ++ Name.toChars name
734731 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -762,7 +759,7 @@ toReport source err =
762759
763760 Shadowing name r1 r2 ->
764761 Report.Report "SHADOWING" r2 [] $
765− Report.toCodePair source r1 r2
762+ Code.toPair source r1 r2
766763 ( "These variables cannot have the same name:"
767764 , advice
768765 )
@@ -783,7 +780,7 @@ toReport source err =
783780
784781 TupleLargerThanThree region ->
785782 Report.Report "BAD TUPLE" region [] $
786− Report.toCodeSnippet source region Nothing
783+ Code.toSnippet source region Nothing
787784 (
788785 "I only accept tuples with two or three items. This has too many:"
789786 ,
@@ -832,7 +829,7 @@ toReport source err =
832829 )
833830 in
834831 Report.Report title aliasRegion [] $
835− Report.toCodeSnippet source aliasRegion subRegion
832+ Code.toSnippet source aliasRegion subRegion
836833 (
837834 D.fillSep overview
838835 ,
@@ -885,7 +882,7 @@ toReport source err =
885882
886883 in
887884 Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] $
888− Report.toCodeSnippet source aliasRegion Nothing
885+ Code.toSnippet source aliasRegion Nothing
889886 (
890887 D.reflow $
891888 "Type alias `" <> Name.toChars typeName <> "` has some type variable problems."
@@ -932,7 +929,7 @@ unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion)
932929 )
933930 in
934931 Report.Report title declRegion [] $
935− Report.toCodeSnippet source declRegion subRegion
932+ Code.toSnippet source declRegion subRegion
936933 (
937934 D.fillSep overview
938935 ,
@@ -960,7 +957,7 @@ unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion)
960957nameClash :: Code.Source -> A.Region -> A.Region -> String -> Report.Report
961958nameClash source r1 r2 messageThatEndsWithPunctuation =
962959 Report.Report "NAME CLASH" r2 [] $
963− Report.toCodePair source r1 r2
960+ Code.toPair source r1 r2
964961 (
965962 D.reflow messageThatEndsWithPunctuation
966963 ,
@@ -979,28 +976,32 @@ nameClash source r1 r2 messageThatEndsWithPunctuation =
979976-- AMBIGUOUS NAME
980977
981978
982−ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> [ModuleName.Canonical] -> String -> Report.Report
983−ambiguousName source region maybePrefix name possibleHomes thing =
979+ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> ModuleName.Canonical -> OneOrMore.OneOrMore ModuleName.Canonical -> String -> Report.Report
980+ambiguousName source region maybePrefix name h hs thing =
981+ let
982+ possibleHomes = List.sort (h : OneOrMore.destruct (:) hs)
983+ in
984984 Report.Report "AMBIGUOUS NAME" region [] $
985− Report.toCodeSnippet source region Nothing $
985+ Code.toSnippet source region Nothing $
986986 case maybePrefix of
987987 Nothing ->
988988 let
989989 homeToYellowDoc (ModuleName.Canonical _ home) =
990− D.dullyellow (D.fromName home)
991−
992− bothOrAll =
993− if length possibleHomes == 2 then "both" else "all"
990+ D.dullyellow (D.fromName home <> "." <> D.fromName name)
994991 in
995992 (
996− D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous."
993+ D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous:"
997994 ,
998995 D.stack
999996 [ D.reflow $
1000− "Check your imports. The following modules " ++ bothOrAll
1001− ++ " expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ":"
997+ "This name is exposed by " ++ show (length possibleHomes) ++ " of your imports, so I am not\
998+ \ sure which one to use:"
1002999 , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
1003− , D.reflowLink "Read" "imports" "to learn how to clarify which one you want."
1000+ , D.reflow $
1001+ "I recommend using qualified names for imported values. I also recommend having\
1002+ \ at most one `exposing (..)` per file to make name clashes like this less common\
1003+ \ in the long run."
1004+ , D.link "Note" "Check out" "imports" "for more info on the import syntax."
10041005 ]
10051006 )
10061007
@@ -1008,9 +1009,9 @@ ambiguousName source region maybePrefix name possibleHomes thing =
10081009 let
10091010 homeToYellowDoc (ModuleName.Canonical _ home) =
10101011 if prefix == home then
1011− D.blue "import" <+> D.dullyellow (D.fromName home)
1012+ D.cyan "import" <+> D.fromName home
10121013 else
1013− D.blue "import" <+> D.dullyellow (D.fromName home) <+> D.blue "as" <+> D.dullyellow (D.fromName prefix)
1014+ D.cyan "import" <+> D.fromName home <+> D.cyan "as" <+> D.fromName prefix
10141015
10151016 eitherOrAny =
10161017 if length possibleHomes == 2 then "either" else "any"
@@ -1065,7 +1066,7 @@ notFound source region maybePrefix name thing (PossibleNames locals quals) =
10651066
10661067 in
10671068 Report.Report "NAMING ERROR" region nearbyNames $
1068− Report.toCodeSnippet source region Nothing
1069+ Code.toSnippet source region Nothing
10691070 (
10701071 D.reflow $
10711072 "I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":"
@@ -1195,7 +1196,7 @@ _argMismatchReport source region kind name expected actual =
11951196 <> " arguments"
11961197 in
11971198 Report.Report (map Char.toUpper numArgs) region [] $
1198− Report.toCodeSnippet source region Nothing
1199+ Code.toSnippet source region Nothing
11991200 (
12001201 D.reflow $
12011202 kind <> " " <> Name.toChars name <> " has " <> numArgs <> "."
@@ -1214,7 +1215,7 @@ aliasRecursionReport source region name args tipe others =
12141215 case others of
12151216 [] ->
12161217 Report.Report "ALIAS PROBLEM" region [] $
1217− Report.toCodeSnippet source region Nothing
1218+ Code.toSnippet source region Nothing
12181219 (
12191220 "This type alias is recursive, forming an infinite type!"
12201221 ,
@@ -1233,7 +1234,7 @@ aliasRecursionReport source region name args tipe others =
12331234
12341235 _ ->
12351236 Report.Report "ALIAS PROBLEM" region [] $
1236− Report.toCodeSnippet source region Nothing
1237+ Code.toSnippet source region Nothing
12371238 (
12381239 "This type alias is part of a mutually recursive set of type aliases."
12391240 ,
compiler/src/Reporting/Error/Docs.hs+132−23
@@ -2,17 +2,24 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Reporting.Error.Docs
44 ( Error(..)
5− , toReport
5+ , SyntaxProblem(..)
6+ , NameProblem(..)
7+ , DefProblem(..)
8+ , toReports
69 )
710 where
811
912
1013import qualified Data.Name as Name
14+import qualified Data.NonEmptyList as NE
1115
16+import Parse.Primitives (Row, Col)
17+import Parse.Symbol (BadOperator(..))
1218import qualified Reporting.Annotation as A
1319import Reporting.Doc ((<>))
1420import qualified Reporting.Doc as D
1521import qualified Reporting.Render.Code as Code
22+import qualified Reporting.Error.Syntax as E
1623import qualified Reporting.Report as Report
1724
1825
@@ -20,36 +27,56 @@ import qualified Reporting.Report as Report
2027data Error
2128 = NoDocs A.Region
2229 | ImplicitExposing A.Region
23− | Duplicate Name.Name A.Region A.Region
24− | OnlyInDocs Name.Name A.Region
25− | OnlyInExports Name.Name A.Region
26− | NoComment Name.Name A.Region
30+ | SyntaxProblem SyntaxProblem
31+ | NameProblems (NE.List NameProblem)
32+ | DefProblems (NE.List DefProblem)
33+
34+
35+data SyntaxProblem
36+ = Op Row Col
37+ | OpBad BadOperator Row Col
38+ | Name Row Col
39+ | Space E.Space Row Col
40+ | Comma Row Col
41+ | BadEnd Row Col
42+
43+
44+data NameProblem
45+ = NameDuplicate Name.Name A.Region A.Region
46+ | NameOnlyInDocs Name.Name A.Region
47+ | NameOnlyInExports Name.Name A.Region
48+
49+
50+data DefProblem
51+ = NoComment Name.Name A.Region
2752 | NoAnnotation Name.Name A.Region
2853
2954
3055
31−-- TO REPORT
56+-- TO REPORTS
3257
3358
34−toReport :: Code.Source -> Error -> Report.Report
35−toReport source err =
59+toReports :: Code.Source -> Error -> NE.List Report.Report
60+toReports source err =
3661 case err of
3762 NoDocs region ->
63+ NE.singleton $
3864 Report.Report "NO DOCS" region [] $
39− D.stack
40− [
65+ Code.toSnippet source region Nothing
66+ (
4167 D.reflow $
4268 "You must have a documentation comment between the module\
4369 \ declaration and the imports."
4470 ,
4571 D.reflow
46− "Learn more at <http://package.elm-lang.org/help/documentation-format>"
47− ]
72+ "Learn more at <https://package.elm-lang.org/help/documentation-format>"
73+ )
4874
4975 ImplicitExposing region ->
76+ NE.singleton $
5077 Report.Report "IMPLICIT EXPOSING" region [] $
51− D.stack
52− [
78+ Code.toSnippet source region Nothing
79+ (
5380 D.reflow $
5481 "I need you to be explicit about what this module exposes:"
5582 ,
@@ -59,11 +86,85 @@ toReport source err =
5986 \ to be explicit about this is a way of adding another quality check before\
6087 \ code gets published. So as you write out the public API, ask yourself if\
6188 \ it will be easy to understand as people read the documentation!"
62− ]
89+ )
90+
91+ SyntaxProblem problem ->
92+ NE.singleton $
93+ toSyntaxProblemReport source problem
94+
95+ NameProblems problems ->
96+ fmap (toNameProblemReport source) problems
97+
98+ DefProblems problems ->
99+ fmap (toDefProblemReport source) problems
100+
63101
64− Duplicate name r1 r2 ->
102+
103+-- SYNTAX PROBLEM
104+
105+
106+toSyntaxProblemReport :: Code.Source -> SyntaxProblem -> Report.Report
107+toSyntaxProblemReport source problem =
108+ let
109+ toSyntaxReport row col details =
110+ let
111+ region = toRegion row col
112+ in
113+ Report.Report "PROBLEM IN DOCS" region [] $
114+ Code.toSnippet source region Nothing
115+ ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:"
116+ , D.stack $
117+ [ D.reflow details
118+ , D.toSimpleHint $
119+ "Read through <https://package.elm-lang.org/help/documentation-format> for\
120+ \ tips on how to write module documentation!"
121+ ]
122+ )
123+ in
124+ case problem of
125+ Op row col ->
126+ toSyntaxReport row col $
127+ "I am trying to parse an operator like (+) or (*) but something is going wrong."
128+
129+ OpBad _ row col ->
130+ toSyntaxReport row col $
131+ "I am trying to parse an operator like (+) or (*) but it looks like you are using\
132+ \ a reserved symbol in this case."
133+
134+ Name row col ->
135+ toSyntaxReport row col $
136+ "I was expecting to see the name of another exposed value from this module."
137+
138+ Space space row col ->
139+ E.toSpaceReport source space row col
140+
141+ Comma row col ->
142+ toSyntaxReport row col $
143+ "I was expecting to see a comma next."
144+
145+ BadEnd row col ->
146+ toSyntaxReport row col $
147+ "I am not really sure what I am getting stuck on though."
148+
149+
150+toRegion :: Row -> Col -> A.Region
151+toRegion row col =
152+ let
153+ pos = A.Position row col
154+ in
155+ A.Region pos pos
156+
157+
158+
159+-- NAME PROBLEM
160+
161+
162+toNameProblemReport :: Code.Source -> NameProblem -> Report.Report
163+toNameProblemReport source problem =
164+ case problem of
165+ NameDuplicate name r1 r2 ->
65166 Report.Report "DUPLICATE DOCS" r2 [] $
66− Report.toCodePair source r1 r2
167+ Code.toPair source r1 r2
67168 (
68169 D.reflow $
69170 "There can only be one `" <> Name.toChars name
@@ -81,9 +182,9 @@ toReport source err =
81182 "Remove one of them!"
82183 )
83184
84− OnlyInDocs name region ->
185+ NameOnlyInDocs name region ->
85186 Report.Report "DOCS MISTAKE" region [] $
86− Report.toCodeSnippet source region Nothing
187+ Code.toSnippet source region Nothing
87188 (
88189 D.reflow $
89190 "I do not see `" <> Name.toChars name
@@ -94,9 +195,9 @@ toReport source err =
94195 <> Name.toChars name <> "` and forgot to delete it here?"
95196 )
96197
97− OnlyInExports name region ->
198+ NameOnlyInExports name region ->
98199 Report.Report "DOCS MISTAKE" region [] $
99− Report.toCodeSnippet source region Nothing
200+ Code.toSnippet source region Nothing
100201 (
101202 D.reflow $
102203 "I do not see `" <> Name.toChars name
@@ -110,9 +211,17 @@ toReport source err =
110211 ]
111212 )
112213
214+
215+
216+-- DEF PROBLEM
217+
218+
219+toDefProblemReport :: Code.Source -> DefProblem -> Report.Report
220+toDefProblemReport source problem =
221+ case problem of
113222 NoComment name region ->
114223 Report.Report "NO DOCS" region [] $
115− Report.toCodeSnippet source region Nothing
224+ Code.toSnippet source region Nothing
116225 (
117226 D.reflow $
118227 "The `" <> Name.toChars name <> "` definition does not have a documentation comment."
@@ -126,7 +235,7 @@ toReport source err =
126235
127236 NoAnnotation name region ->
128237 Report.Report "NO TYPE ANNOTATION" region [] $
129− Report.toCodeSnippet source region Nothing
238+ Code.toSnippet source region Nothing
130239 (
131240 D.reflow $
132241 "The `" <> Name.toChars name <> "` definition does not have a type annotation."
compiler/src/Reporting/Error/Import.hs+113−9
@@ -7,6 +7,7 @@ module Reporting.Error.Import
77 where
88
99
10+import qualified Data.Map as Map
1011import qualified Data.Set as Set
1112
1213import qualified Elm.ModuleName as ModuleName
@@ -14,6 +15,7 @@ import qualified Elm.Package as Pkg
1415import qualified Reporting.Doc as D
1516import qualified Reporting.Render.Code as Code
1617import qualified Reporting.Report as Report
18+import qualified Reporting.Suggest as Suggest
1719import qualified Reporting.Annotation as A
1820
1921
@@ -22,7 +24,12 @@ import qualified Reporting.Annotation as A
2224
2325
2426data Error =
25− Error A.Region ModuleName.Raw (Set.Set ModuleName.Raw) Problem
27+ Error
28+ { _region :: A.Region
29+ , _import :: ModuleName.Raw
30+ , _unimported :: Set.Set ModuleName.Raw
31+ , _problem :: Problem
32+ }
2633
2734
2835data Problem
@@ -37,22 +44,119 @@ data Problem
3744
3845
3946toReport :: Code.Source -> Error -> Report.Report
40−toReport source (Error region name knownModules problem) =
47+toReport source (Error region name unimportedModules problem) =
4148 case problem of
4249 NotFound ->
4350 Report.Report "MODULE NOT FOUND" region [] $
44− Report.toCodeSnippet source region Nothing
51+ Code.toSnippet source region Nothing
4552 (
46− "You are trying to import a `" <> D.fromName name <> "` module:"
53+ D.reflow $
54+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
4755 ,
48− error "TODO But I cannot find `Whatever` in your project or packages." knownModules
56+ D.stack
57+ [
58+ D.reflow $
59+ "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json,\
60+ \ but I cannot find it! Maybe it is a typo for one of these names?"
61+ ,
62+ D.dullyellow $ D.indent 4 $ D.vcat $
63+ map D.fromName (toSuggestions name unimportedModules)
64+ ,
65+ case Map.lookup name Pkg.suggestions of
66+ Nothing ->
67+ D.toSimpleHint $
68+ "If it is not a typo, check the \"dependencies\" and \"source-directories\"\
69+ \ of your elm.json to make sure all the packages you need are listed there!"
70+
71+ Just dependency ->
72+ D.toFancyHint
73+ ["Maybe","you","want","the"
74+ ,"`" <> D.fromName name <> "`"
75+ ,"module","defined","in","the"
76+ ,D.fromChars (Pkg.toChars dependency)
77+ ,"package?","Running"
78+ ,D.green (D.fromChars ("elm install " ++ Pkg.toChars dependency))
79+ ,"should","make","it","available!"
80+ ]
81+ ]
4982 )
5083
51− Ambiguous path paths pkg pkgs ->
52− error "TODO Ambiguous" path paths pkg pkgs
84+ Ambiguous path _ pkg _ ->
85+ Report.Report "AMBIGUOUS IMPORT" region [] $
86+ Code.toSnippet source region Nothing
87+ (
88+ D.reflow $
89+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
90+ ,
91+ D.stack
92+ [
93+ D.fillSep $
94+ ["But","I","found","multiple","modules","with","that","name.","One","in","the"
95+ ,D.dullyellow (D.fromChars (Pkg.toChars pkg))
96+ ,"package,","and","another","defined","locally","in","the"
97+ ,D.dullyellow (D.fromChars path)
98+ ,"file.","I","do","not","have","a","way","to","choose","between","them."
99+ ]
100+ ,
101+ D.reflow $
102+ "Try changing the name of the locally defined module to clear up the ambiguity?"
103+ ]
104+ )
53105
54106 AmbiguousLocal path1 path2 paths ->
55− error "TODO AmbiguousLocal" path1 path2 paths
107+ Report.Report "AMBIGUOUS IMPORT" region [] $
108+ Code.toSnippet source region Nothing
109+ (
110+ D.reflow $
111+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
112+ ,
113+ D.stack
114+ [
115+ D.reflow $
116+ "But I found multiple files in your \"source-directories\" with that name:"
117+ ,
118+ D.dullyellow $ D.indent 4 $ D.vcat $
119+ map D.fromChars (path1:path2:paths)
120+ ,
121+ D.reflow $
122+ "Change the module names to be distinct!"
123+ ]
124+ )
56125
57126 AmbiguousForeign pkg1 pkg2 pkgs ->
58− error "TODO AmbiguousForeign" pkg1 pkg2 pkgs
127+ Report.Report "AMBIGUOUS IMPORT" region [] $
128+ Code.toSnippet source region Nothing
129+ (
130+ D.reflow $
131+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
132+ ,
133+ D.stack
134+ [
135+ D.reflow $
136+ "But multiple packages in your \"dependencies\" that expose a module that name:"
137+ ,
138+ D.dullyellow $ D.indent 4 $ D.vcat $
139+ map (D.fromChars . Pkg.toChars) (pkg1:pkg2:pkgs)
140+ ,
141+ D.reflow $
142+ "There is no way to disambiguate in cases like this right now. Of the known name\
143+ \ clashes, they are usually for packages with similar purposes, so the current\
144+ \ recommendation is to pick just one of them."
145+ , D.toSimpleNote $
146+ "It seems possible to resolve this with new syntax in imports, but that is\
147+ \ more complicated than it sounds. Right now, our module names are tied to GitHub\
148+ \ repos, but we may want to get rid of that dependency for a variety of reasons.\
149+ \ That would in turn have implications for our package infrastructure, hosting\
150+ \ costs, and possibly on how package names are specified. The particular syntax\
151+ \ chosen seems like it would interact with all these factors in ways that are\
152+ \ difficult to predict, potentially leading to harder problems later on. So more\
153+ \ design work and planning is needed on these topics."
154+ ]
155+ )
156+
157+
158+
159+toSuggestions :: ModuleName.Raw -> Set.Set ModuleName.Raw -> [ModuleName.Raw]
160+toSuggestions name unimportedModules =
161+ take 4 $
162+ Suggest.sort (ModuleName.toChars name) ModuleName.toChars (Set.toList unimportedModules)
compiler/src/Reporting/Error/Json.hs+281−269
@@ -1,332 +1,344 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Reporting.Error.Json
4− ( Error(..)
5− , Problem(..)
6− , DecodeExpectation(..)
7− , ParseError(..)
8− , toReport
4+ ( toReport
5+ , FailureToReport(..)
6+ , Context(..)
7+ , Reason(..)
98 )
109 where
1110
1211
13−import qualified Data.Utf8 as Utf8
14−import Data.Word (Word16)
12+import qualified Data.ByteString as BS
13+import qualified Data.ByteString.UTF8 as BS_UTF8
14+import qualified Data.NonEmptyList as NE
1515
16−import qualified Reporting.Report as Report
17−
18−
19−
20−-- ERROR
21−
22−
23−data Error e
24− = DecodeProblem (Problem e)
25− | ParseProblem ParseError
26−
27−
28−
29−-- DECODE PROBLEMS
30−
31−
32−data Problem e
33− = Field Utf8.String (Problem e)
34− | Index Int (Problem e)
35− | OneOf (Problem e) [Problem e]
36− | Failure e
37− | Expecting DecodeExpectation
38−
39−
40−data DecodeExpectation
41− = TObject
42− | TArray
43− | TString
44− | TBool
45− | TInt
46− | TObjectWith Utf8.String
47− | TArrayPair Int
48−
49−
50−
51−-- PARSE ERROR
52−
53−
54−data ParseError
55− = PIndex Int ParseError Row Col
56− | PField Utf8.String ParseError Row Col
57− | ObjectStart Row Col
58− | ObjectMore Row Col
59− | ObjectEnd Row Col
60− | ArrayStart Row Col
61− | ArrayMore Row Col
62− | ArrayEnd Row Col
63− | StringStart Row Col
64− | StringEnd Row Col
65− | IntStart Row Col
66− | NoLeadingZeros Row Col
67− | NoFloats Row Col
68− | Bool Row Col
69− | Null Row Col
70− | Value Row Col
71− | Colon Row Col
72− | EndOfFile Row Col
73−
74−
75−type Row = Word16
76−type Col = Word16
16+import Json.Decode (Error(..), Problem(..), DecodeExpectation(..), ParseError(..), StringProblem(..))
17+import qualified Reporting.Annotation as A
18+import qualified Reporting.Doc as D
19+import qualified Reporting.Exit.Help as Help
20+import qualified Reporting.Render.Code as Code
7721
7822
7923
8024-- TO REPORT
8125
8226
83−toReport :: Error e -> Report.Report
84−toReport err =
85− error "TODO Reporting.Error.Json.toReport" err
86−
87−
88−{-
89−
90−-- ERROR
27+toReport :: FilePath -> FailureToReport x -> Error x -> Reason -> Help.Report
28+toReport path ftr err reason =
29+ case err of
30+ DecodeProblem bytes problem ->
31+ problemToReport path ftr (Code.toSource bytes) CRoot problem reason
9132
33+ ParseProblem bytes parseError ->
34+ parseErrorToReport path (Code.toSource bytes) parseError reason
9235
93−data Error e
94− = BadJson Syntax.Error
95− | BadContent (Json.Error e)
9636
37+newtype Reason =
38+ ExplicitReason String
9739
9840
99−-- TO DOC
41+because :: Reason -> String -> String
42+because (ExplicitReason iNeedThings) problem =
43+ iNeedThings ++ " " ++ problem
10044
10145
102−toDoc :: String -> Code.Source -> (e -> [D.Doc]) -> Error e -> D.Doc
103−toDoc rootName source userErrorToDocs err =
104− case err of
105− BadJson syntaxError ->
106− case Syntax.toReport source syntaxError of
107− Report.Report _ _ _ doc ->
108− doc
109−
110− BadContent jsonError ->
111− case flatten jsonError of
112− [] ->
113− D.reflow
114− "I am not sure what is wrong with this JSON. Please create an <http://sscce.org>\
115− \ and share it at <https://github.com/elm/compiler/issues> so I can\
116− \ provide a helpful hint here!"
117−
118− [flatError] ->
119− flatErrorToDoc rootName [] userErrorToDocs flatError
120−
121− flatErrors ->
122− let
123− toNumberedDoc index flatErr =
124− D.dullcyan ("(" <> D.fromInt index <> ")") <+> flatErrorToDoc rootName [] userErrorToDocs flatErr
125− in
126− D.stack $
127− [ D.reflow $
128− "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"
129− ]
130− ++ zipWith toNumberedDoc [1..] flatErrors
13146
47+-- PARSE ERROR TO REPORT
13248
13349
134−-- FLAT ERROR TO DOC
135−
136−
137−flatErrorToDoc :: String -> [D.Doc] -> (e -> [D.Doc]) -> FlatError e -> D.Doc
138−flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =
139− case theories of
140− [] ->
50+parseErrorToReport :: FilePath -> Code.Source -> ParseError -> Reason -> Help.Report
51+parseErrorToReport path source parseError reason =
52+ let
53+ toSnippet title row col (problem, details) =
14154 let
142− explanation =
143− case theory of
144− Failure userError ->
145− userErrorToDocs userError
146−
147− Expecting tipe ->
148− ["I","was","expecting"] ++ anExpectedThing tipe
55+ pos = A.Position row col
56+ surroundings = A.Region (A.Position (max 1 (row - 2)) 1) pos
57+ region = A.Region pos pos
14958 in
150− case accesses of
151− [] ->
152− D.fillSep (starter ++ explanation)
153−
154− _ ->
59+ Help.jsonReport title (Just path) $
60+ Code.toSnippet source surroundings (Just region)
61+ ( D.reflow (because reason problem)
62+ , details
63+ )
64+ in
65+ case parseError of
66+ Start row col ->
67+ toSnippet "EXPECTING A VALUE" row col
68+ (
69+ "I was expecting to see a JSON value next:"
70+ ,
15571 D.stack
156− [ D.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]
157− , D.fillSep explanation
72+ [ D.fillSep
73+ ["Try","something","like",D.dullyellow "\"this\"","or"
74+ ,D.dullyellow "42","to","move","on","to","better","hints!"
75+ ]
76+ , D.toSimpleNote $
77+ "The JSON specification does not allow trailing commas, so you can sometimes\
78+ \ get this error in arrays that have an extra comma at the end. In that case,\
79+ \ remove that last comma or add another array entry after it!"
15880 ]
81+ )
15982
160− _:_ ->
161− let
162− introduction =
163− case accesses of
164− [] ->
165− ["I","am","having","trouble","with","the"]
166− ++ actualThing json
167− ++ ["here","because:"]
168−
169− _ ->
170− ["I","am","having","trouble","with","the"]
171− ++ actualThing json
172− ++ ["at",accessToDoc rootName accesses,"because:"]
173− in
174− D.stack
175− [ D.fillSep (starter ++ introduction)
176− , D.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)
177− , D.reflow "I accept any of these things."
178− ]
83+ ObjectField row col ->
84+ toSnippet "EXTRA COMMA" row col
85+ (
86+ "I was partway through parsing a JSON object when I got stuck here:"
87+ ,
88+ D.stack
89+ [ D.fillSep
90+ ["I","saw","a","comma","right","before","I","got","stuck","here,"
91+ ,"so","I","was","expecting","to","see","a","field","name","like"
92+ ,D.dullyellow "\"type\"","or",D.dullyellow "\"dependencies\"","next."
93+ ]
94+ , D.reflow $
95+ "This error is commonly caused by trailing commas in JSON objects. Those are\
96+ \ actually disallowed by <https://json.org> so check the previous line for a\
97+ \ trailing comma that may need to be deleted."
98+ , objectNote
99+ ]
100+ )
179101
102+ ObjectColon row col ->
103+ toSnippet "EXPECTING COLON" row col
104+ (
105+ "I was partway through parsing a JSON object when I got stuck here:"
106+ ,
107+ D.stack
108+ [ D.reflow $ "I was expecting to see a colon next."
109+ , objectNote
110+ ]
111+ )
180112
181−accessToDoc :: String -> [String] -> D.Doc
182−accessToDoc rootName accesses =
183− D.dullyellow (D.fromString (rootName ++ concat accesses))
113+ ObjectEnd row col ->
114+ toSnippet "UNFINISHED OBJECT" row col
115+ (
116+ "I was partway through parsing a JSON object when I got stuck here:"
117+ ,
118+ D.stack
119+ [ D.reflow $
120+ "I was expecting to see a comma or a closing curly brace next."
121+ , D.reflow $
122+ "Is a comma missing on the previous line? Is an array missing a closing square\
123+ \ bracket? It is often something tricky like that!"
124+ , objectNote
125+ ]
126+ )
184127
128+ ArrayEnd row col ->
129+ toSnippet "UNFINISHED ARRAY" row col
130+ (
131+ "I was partway through parsing a JSON array when I got stuck here:"
132+ ,
133+ D.stack
134+ [ D.reflow $ "I was expecting to see a comma or a closing square bracket next."
135+ , D.reflow $
136+ "Is a comma missing on the previous line? It is often something like that!"
137+ ]
138+ )
139+
140+ StringProblem stringProblem row col ->
141+ case stringProblem of
142+ BadStringEnd ->
143+ toSnippet "ENDLESS STRING" row col
144+ (
145+ "I got to the end of the line without seeing the closing double quote:"
146+ ,
147+ D.fillSep $
148+ ["Strings","look","like",D.green "\"this\"","with","double"
149+ ,"quotes","on","each","end.","Is","the","closing","double"
150+ ,"quote","missing","in","your","code?"
151+ ]
152+ )
153+
154+ BadStringControlChar ->
155+ toSnippet "UNEXPECTED CONTROL CHARACTER" row col
156+ (
157+ "I ran into a control character unexpectedly:"
158+ ,
159+ D.reflow $
160+ "These are characters that represent tabs, backspaces, newlines, and\
161+ \ a bunch of other invisible characters. They all come before 20 in the\
162+ \ ASCII range, and they are disallowed by the JSON specificaiton. Maybe\
163+ \ a copy/paste added one of these invisible characters to your JSON?"
164+ )
165+
166+ BadStringEscapeChar ->
167+ toSnippet "UNKNOWN ESCAPE" row col
168+ (
169+ "Backslashes always start escaped characters, but I do not recognize this one:"
170+ ,
171+ D.stack
172+ [ D.reflow $
173+ "Valid escape characters include:"
174+ , D.dullyellow $ D.indent 4 $ D.vcat $
175+ ["\\\"","\\\\","\\/","\\b","\\f","\\n","\\r","\\t","\\u003D"]
176+ , D.reflow $
177+ "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?"
178+ ]
179+ )
180+
181+ BadStringEscapeHex ->
182+ toSnippet "BAD HEX ESCAPE" row col
183+ (
184+ "This is not a valid hex escape:"
185+ ,
186+ D.fillSep $
187+ ["Valid","hex","escapes","in","JSON","are","between"
188+ ,D.green "\\u0000","and",D.green "\\uFFFF"
189+ ,"and","always","have","exactly","four","digits."
190+ ]
191+ )
192+
193+ NoLeadingZeros row col ->
194+ toSnippet "BAD NUMBER" row col
195+ (
196+ "Numbers cannot start with zeros like this:"
197+ ,
198+ D.reflow $ "Try deleting the leading zeros?"
199+ )
200+
201+ NoFloats row col ->
202+ toSnippet "UNEXPECTED NUMBER" row col
203+ (
204+ "I got stuck while trying to parse this number:"
205+ ,
206+ D.reflow $
207+ "I do not accept floating point numbers like 3.1415 right now. That kind\
208+ \ of JSON value is not needed for any of the uses that Elm has for now."
209+ )
210+
211+ BadEnd row col ->
212+ toSnippet "JSON PROBLEM" row col
213+ (
214+ "I was partway through parsing some JSON when I got stuck here:"
215+ ,
216+ D.reflow $
217+ "I am not really sure what is wrong. This sometimes means there is extra\
218+ \ stuff after a valid JSON value?"
219+ )
220+
221+
222+objectNote :: D.Doc
223+objectNote =
224+ D.stack
225+ [ D.toSimpleNote $ "Here is an example of a valid JSON object for reference:"
226+ , D.vcat
227+ [ D.indent 4 $ "{"
228+ , D.indent 6 $ D.dullyellow "\"name\"" <> ": " <> D.dullyellow "\"Tom\"" <> ","
229+ , D.indent 6 $ D.dullyellow "\"age\"" <> ": " <> D.dullyellow "42"
230+ , D.indent 4 $ "}"
231+ ]
232+ , D.reflow $
233+ "Notice that (1) the field names are in double quotes and (2) there is no\
234+ \ trailing comma after the last entry. Both are strict requirements in JSON!"
235+ ]
185236
186−actualThing :: E.Value -> [D.Doc]
187−actualThing json =
188− case json of
189− E.Array _ -> [D.red "array"]
190− E.Object _ -> [D.red "object"]
191− E.String _ -> [D.red "string"]
192− E.Boolean b -> [D.red (if b then "true" else "false"),"value"]
193− E.Integer n -> ["number",D.red (D.fromInt n)]
194− E.Number _ -> [D.red "number"]
195− E.Null -> [D.red "null","value"]
196237
197238
198−anExpectedThing :: Json.Type -> [D.Doc]
199−anExpectedThing tipe =
200− case tipe of
201− Json.TObject -> ["an", D.green "OBJECT" <> "."]
202− Json.TArray -> ["an", D.green "ARRAY" <> "."]
203− Json.TString -> ["a", D.green "STRING" <> "."]
204− Json.TBool -> ["a", D.green "BOOLEAN" <> "."]
205− Json.TInt -> ["an", D.green "INT" <> "."]
206− Json.TObjectWith field -> ["an",D.green "OBJECT","with","a",D.green ("\"" <> D.fromString (Text.unpack field) <> "\""),"field."]
207− Json.TArrayPair len ->
208− ["an",D.green "ARRAY","with",D.green "TWO","entries."
209− ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
210− ]
239+-- PROBLEM TO REPORT
211240
212241
213−toBullet :: [D.Doc] -> (e -> [D.Doc]) -> Theory e -> D.Doc
214−toBullet intro userErrorToDocs theory =
215− D.indent 4 $ D.fillSep $ (++) intro $
216− case theory of
217− Failure userError ->
218− userErrorToDocs userError
242+data Context
243+ = CRoot
244+ | CField BS.ByteString Context
245+ | CIndex Int Context
219246
220− Expecting tipe ->
221− ["I","was","expecting"] ++ anExpectedThing tipe
222247
248+problemToReport :: FilePath -> FailureToReport x -> Code.Source -> Context -> Problem x -> Reason -> Help.Report
249+problemToReport path ftr source context problem reason =
250+ case problem of
251+ Field field prob ->
252+ problemToReport path ftr source (CField field context) prob reason
223253
254+ Index index prob ->
255+ problemToReport path ftr source (CIndex index context) prob reason
224256
225−-- TO FLAT ERRORS
257+ OneOf p ps ->
258+ -- NOTE: only displays the deepest problem. This works well for the kind
259+ -- of JSON used by Elm, but probably would not work well in general.
260+ let
261+ (NE.List prob _) = NE.sortBy (negate . getMaxDepth) (NE.List p ps)
262+ in
263+ problemToReport path ftr source context prob reason
226264
265+ Failure region x ->
266+ _failureToReport ftr path source context region x
227267
228−data FlatError e =
229− FlatError [String] E.Value (Theory e) [Theory e]
268+ Expecting region expectation ->
269+ expectationToReport path source context region expectation reason
230270
231271
232−data Theory e
233− = Failure e
234− | Expecting Json.Type
272+getMaxDepth :: Problem x -> Int
273+getMaxDepth problem =
274+ case problem of
275+ Field _ prob -> 1 + getMaxDepth prob
276+ Index _ prob -> 1 + getMaxDepth prob
277+ OneOf p ps -> maximum (getMaxDepth p : map getMaxDepth ps)
278+ Failure _ _ -> 0
279+ Expecting _ _ -> 0
235280
236281
237−flatten :: Json.Error e -> [FlatError e]
238−flatten jsonError =
239− let
240− depth (FlatError accesses _ _ _) =
241− length accesses
242− in
243− List.sortOn depth $ flattenTree (toErrorTree jsonError)
282+newtype FailureToReport x =
283+ FailureToReport { _failureToReport :: FilePath -> Code.Source -> Context -> A.Region -> x -> Help.Report }
244284
245285
246−flattenTree :: ErrorTree e -> [FlatError e]
247−flattenTree (ErrorTree theories subTrees) =
286+expectationToReport :: FilePath -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Reason -> Help.Report
287+expectationToReport path source context (A.Region start end) expectation reason =
248288 let
249− addAccess access (FlatError accesses json t ts) =
250− FlatError (access:accesses) json t ts
289+ (A.Position sr _) = start
290+ (A.Position er _) = end
251291
252− toFlats (name, tree) =
253− map (addAccess name) (flattenTree tree)
254−
255− subErrors =
256− concatMap toFlats (Map.toList subTrees)
257− in
258− case theories of
259− [] ->
260− subErrors
292+ region =
293+ if sr == er then region else A.Region start start
261294
262− (json, theory) : rest ->
263− FlatError [] json theory (map snd rest) : subErrors
295+ introduction =
296+ case context of
297+ CRoot ->
298+ "I ran into some trouble here:"
264299
300+ CField field _ ->
301+ "I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:"
265302
303+ CIndex index (CField field _) ->
304+ "When looking at the \"" ++ BS_UTF8.toString field ++ "\" field, I ran into trouble with the "
305+ ++ D.intToOrdinal index ++ " entry:"
266306
267−-- TO ERROR TREE
307+ CIndex index _ ->
308+ "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:"
268309
269−
270−data ErrorTree e =
271− ErrorTree
272− { _theories :: [(E.Value, Theory e)]
273− , _subErrors :: Map.Map String (ErrorTree e)
274− }
275−
276−
277−toErrorTree :: Json.Error e -> ErrorTree e
278−toErrorTree jsonError =
279− add jsonError empty
280−
281−
282−empty :: ErrorTree e
283−empty =
284− ErrorTree [] Map.empty
285−
286−
287−add :: Json.Error e -> ErrorTree e -> ErrorTree e
288−add jsonError tree@(ErrorTree theories subErrors) =
289− case jsonError of
290− Json.Field field subErr ->
291− ErrorTree theories (addName (fieldToName field) subErr subErrors)
292−
293− Json.Index index subErr ->
294− ErrorTree theories (addName (indexToName index) subErr subErrors)
295−
296− Json.OneOf errors ->
297− foldr add tree errors
298−
299− Json.Expecting json tipe ->
300− ErrorTree ((json, Expecting tipe) : theories) subErrors
301−
302− Json.Failure json err ->
303− ErrorTree ((json, Failure err) : theories) subErrors
304−
305−
306−addName :: String -> Json.Error e -> Map.Map String (ErrorTree e) -> Map.Map String (ErrorTree e)
307−addName name err subErrors =
308− let
309− subAdd maybeCrush =
310− Just (add err (maybe empty id maybeCrush))
310+ toSnippet title aThing =
311+ Help.jsonReport title (Just path) $
312+ Code.toSnippet source region Nothing
313+ ( D.reflow (because reason introduction)
314+ , D.fillSep $ ["I","was","expecting","to","run","into"] ++ aThing
315+ )
311316 in
312− Map.alter subAdd name subErrors
317+ case expectation of
318+ TObject ->
319+ toSnippet "EXPECTING OBJECT" ["an", D.green "OBJECT" <> "."]
313320
321+ TArray ->
322+ toSnippet "EXPECTING ARRAY" ["an", D.green "ARRAY" <> "."]
314323
315−fieldToName :: Text.Text -> String
316−fieldToName field =
317− case Text.unpack field of
318− [] ->
319− "['']"
324+ TString ->
325+ toSnippet "EXPECTING STRING" ["a", D.green "STRING" <> "."]
320326
321− string@(char : rest) ->
322− if Char.isAlpha char && all Char.isAlphaNum rest then
323− '.' : string
324− else
325− "['" ++ string ++ "']"
327+ TBool ->
328+ toSnippet "EXPECTING BOOL" ["a", D.green "BOOLEAN" <> "."]
326329
330+ TInt ->
331+ toSnippet "EXPECTING INT" ["an", D.green "INT" <> "."]
327332
328−indexToName :: Int -> String
329−indexToName index =
330− "[" ++ show index ++ "]"
333+ TObjectWith field ->
334+ toSnippet "MISSING FIELD"
335+ ["an",D.green "OBJECT","with","a"
336+ ,D.green ("\"" <> D.fromChars (BS_UTF8.toString field) <> "\"")
337+ ,"field."
338+ ]
331339
332−-}
340+ TArrayPair len ->
341+ toSnippet "EXPECTING PAIR"
342+ ["an",D.green "ARRAY","with",D.green "TWO","entries."
343+ ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
344+ ]
compiler/src/Reporting/Error/Main.hs+3−3
@@ -38,7 +38,7 @@ toReport localizer source err =
3838 case err of
3939 BadType region tipe ->
4040 Report.Report "BAD MAIN TYPE" region [] $
41− Report.toCodeSnippet source region Nothing
41+ Code.toSnippet source region Nothing
4242 (
4343 "I cannot handle this type of `main` value:"
4444 ,
@@ -53,7 +53,7 @@ toReport localizer source err =
5353
5454 BadCycle region name names ->
5555 Report.Report "BAD MAIN" region [] $
56− Report.toCodeSnippet source region Nothing
56+ Code.toSnippet source region Nothing
5757 (
5858 "A `main` definition cannot be defined in terms of itself."
5959 ,
@@ -69,7 +69,7 @@ toReport localizer source err =
6969 let
7070 formatDetails (aBadKindOfThing, butThatIsNoGood) =
7171 Report.Report "BAD FLAGS" region [] $
72− Report.toCodeSnippet source region Nothing
72+ Code.toSnippet source region Nothing
7373 (
7474 D.reflow $
7575 "Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript."
compiler/src/Reporting/Error/Pattern.hs+9−8
@@ -8,6 +8,7 @@ module Reporting.Error.Pattern
88
99import qualified Data.List as List
1010
11+import qualified Elm.String as ES
1112import qualified Nitpick.PatternMatches as P
1213import Reporting.Doc ((<>))
1314import qualified Reporting.Doc as D
@@ -24,7 +25,7 @@ toReport source err =
2425 case err of
2526 P.Redundant caseRegion patternRegion index ->
2627 Report.Report "REDUNDANT PATTERN" patternRegion [] $
27− Report.toCodeSnippet source caseRegion (Just patternRegion)
28+ Code.toSnippet source caseRegion (Just patternRegion)
2829 (
2930 D.reflow $
3031 "The " <> D.intToOrdinal index <> " pattern is redundant:"
@@ -38,9 +39,9 @@ toReport source err =
3839 case context of
3940 P.BadArg ->
4041 Report.Report "UNSAFE PATTERN" region [] $
41− Report.toCodeSnippet source region Nothing
42+ Code.toSnippet source region Nothing
4243 (
43− "This pattern does not cover all possiblities:"
44+ "This pattern does not cover all possibilities:"
4445 ,
4546 D.stack
4647 [ "Other possibilities include:"
@@ -54,7 +55,7 @@ toReport source err =
5455
5556 P.BadDestruct ->
5657 Report.Report "UNSAFE PATTERN" region [] $
57− Report.toCodeSnippet source region Nothing
58+ Code.toSnippet source region Nothing
5859 (
5960 "This pattern does not cover all possible values:"
6061 ,
@@ -63,7 +64,7 @@ toReport source err =
6364 , unhandledPatternsToDocBlock unhandled
6465 , D.reflow $
6566 "I would have to crash if I saw one of those! You can use\
66− \ `let` to deconstruct values only if there is ONE possiblity.\
67+ \ `let` to deconstruct values only if there is ONE possibility.\
6768 \ Switch to a `case` expression to account for all possibilities."
6869 , D.toSimpleHint $
6970 "Are you calling a function that definitely returns values\
@@ -74,7 +75,7 @@ toReport source err =
7475
7576 P.BadCase ->
7677 Report.Report "MISSING PATTERNS" region [] $
77− Report.toCodeSnippet source region Nothing
78+ Code.toSnippet source region Nothing
7879 (
7980 "This `case` does not have branches for all possibilities:"
8081 ,
@@ -117,10 +118,10 @@ patternToDoc context pattern =
117118 NonList (P.Literal literal) ->
118119 case literal of
119120 P.Chr chr ->
120− "'" <> D.fromUtf8 chr <> "'"
121+ "'" <> D.fromChars (ES.toChars chr) <> "'"
121122
122123 P.Str str ->
123− "\"" <> D.fromUtf8 str <> "\""
124+ "\"" <> D.fromChars (ES.toChars str) <> "\""
124125
125126 P.Int int ->
126127 D.fromInt int
compiler/src/Reporting/Error/Syntax.hs+5183−909

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hs+150−8

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+6−26

This diff is too big to show here.

compiler/src/Reporting/Report.hs−40

This diff is too big to show here.

compiler/src/Reporting/Result.hs+10

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Type/Solve.hs+7

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

This diff is too big to show here.

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

The content is the same.

elm.cabal+34−16

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.mdnew file+42

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.mdnew file+139

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.mdnew file+162

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.mdnew file+60

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.xml+5−3

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/background.pngdeleted

Binary file not shown.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/PUBLISHING.md+29−141

This diff is too big to show here.

installers/npm/README.md+30−23

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/index.jsdeleted−21

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.json+13−15

This diff is too big to show here.

installers/npm/troubleshooting.mdnew file+76

This diff is too big to show here.

installers/win/Nsisfile.nsi+16−16

This diff is too big to show here.

installers/win/README.md+18−3

This diff is too big to show here.

installers/win/file.icodeleted

Binary file not shown.

installers/win/inst.dat+1−2

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+1−2

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifdeleted

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+20−15

This diff is too big to show here.

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

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Bump.hs+158−8

This diff is too big to show here.

terminal/src/Develop.hs+70−77

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Diff.hs+348−6

This diff is too big to show here.

terminal/src/Init.hs+2−1

This diff is too big to show here.

terminal/src/Install.hs+16−31

This diff is too big to show here.

terminal/src/Main.hs+32−36

This diff is too big to show here.

terminal/src/Make.hs+113−268

This diff is too big to show here.

terminal/src/Publish.hs+529−8

This diff is too big to show here.

terminal/src/Repl.hs+522−197

This diff is too big to show here.

terminal/src/Terminal/Args/Helpers.hsdeleted−125

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.