on master help sign in
190 files changed+16703−8492
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+531−294 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+193−96 builder/src/Elm/Diff.hs−284 builder/src/Elm/Outline.hs+146−117 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+1628−387 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+9−10 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+10−9 compiler/src/AST/Optimized.hs+14−13 compiler/src/AST/Source.hs+21−32 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+5−5 compiler/src/Canonicalize/Expression.hs+6−7 compiler/src/Canonicalize/Module.hs+7−7 compiler/src/Canonicalize/Pattern.hs+3−2 compiler/src/Data/Name.hs+166−177 compiler/src/Data/NonEmptyList.hs+12−2 compiler/src/Data/Utf8.hs+157−300 compiler/src/Elm/Compiler/Imports.hs+3−3 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+3−3 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+203−93 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+3−3 compiler/src/Optimize/DecisionTree.hs+5−5 compiler/src/Optimize/Module.hs+3−3 compiler/src/Optimize/Port.hs+3−3 compiler/src/Parse/Declaration.hs+4−4 compiler/src/Parse/Docs.hs−275 compiler/src/Parse/Expression.hs+51−43 compiler/src/Parse/Keyword.hs+16−16 compiler/src/Parse/Module.hs+164−115 compiler/src/Parse/Number.hs+8−8 compiler/src/Parse/Pattern.hs+25−22 compiler/src/Parse/Primitives.hs+95−47 compiler/src/Parse/Repl.hs−117 compiler/src/Parse/Shader.hs+18−17 compiler/src/Parse/Space.hs+22−16 compiler/src/Parse/Utf8.hs → compiler/src/Parse/String.hs+37−36 compiler/src/Parse/Symbol.hs+3−3 compiler/src/Parse/Type.hs+3−3 compiler/src/Parse/Variable.hs+15−14 compiler/src/Reporting/Annotation.hs+1−1 compiler/src/Reporting/Doc.hs+79−47 compiler/src/Reporting/Error.hs+32−26 compiler/src/Reporting/Error/Canonicalize.hs+41−40 compiler/src/Reporting/Error/Docs.hs+127−18 compiler/src/Reporting/Error/Import.hs+1−1 compiler/src/Reporting/Error/Json.hs+281−269 compiler/src/Reporting/Error/Pattern.hs+5−4 compiler/src/Reporting/Error/Syntax.hs+4388−1325 compiler/src/Reporting/Error/Type.hs+44−23 compiler/src/Reporting/Render/Code.hs+70−43 compiler/src/Reporting/Render/Type/Localizer.hs+5−25 compiler/src/Reporting/Result.hs+10 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+31−12 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+42−16 installers/npm/download.js+68−67 installers/npm/install.js+1−7 installers/npm/package.json+6−7 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+25−3 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+36−241
.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+531−294
@@ -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 (NE.toList 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 exposed@(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 exposed@(NE.List e es) =
121160 putMVar rmvar resultMVars
122161 results <- traverse readMVar resultMVars
123162 writeDetails root details results
124− return (detectExposedProblems exposed 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 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,19 +302,18 @@ 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
@@ -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,29 +388,25 @@ 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
391+ case Parse.fromByteString projectType source of
342392 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
343393 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
@@ -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,18 +491,14 @@ 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
@@ -448,7 +506,7 @@ checkDepsHelp root results deps new same cached importProblems isBlocked =
448506
449507
450508toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
451−toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
509+toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
452510 let
453511 knownModules =
454512 Set.unions
@@ -470,18 +528,23 @@ toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
470528
471529
472530
473−-- CACHED INTERFACE
531+-- LOAD CACHED INTERFACES
474532
475533
476−checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
477−checkCachedInterfaces root deps =
478− do loading <- traverse (fork . checkCache root) deps
479− loaded <- traverse readMVar loading
480− 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)
481544
482545
483−checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
484−checkCache root (name, ciMvar) =
546+loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
547+loadInterface root (name, ciMvar) =
485548 do cachedInterface <- takeMVar ciMvar
486549 case cachedInterface of
487550 Corrupted ->
@@ -508,8 +571,8 @@ checkCache root (name, ciMvar) =
508571-- CHECK PROJECT
509572
510573
511−checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
512−checkExposedMidpoint dmvar statuses =
574+checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575+checkMidpoint dmvar statuses =
513576 case checkForCycles statuses of
514577 Nothing ->
515578 do maybeForeigns <- readMVar dmvar
@@ -522,11 +585,11 @@ checkExposedMidpoint dmvar statuses =
522585 return (Left (Exit.BP_Cycle name names))
523586
524587
525−checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
526−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 =
527590 case checkForCycles statuses of
528591 Nothing ->
529− case checkUniqueMains statuses smains of
592+ case checkUniqueRoots statuses sroots of
530593 Nothing ->
531594 do maybeForeigns <- readMVar dmvar
532595 case maybeForeigns of
@@ -577,25 +640,25 @@ addToGraph name status graph =
577640 let
578641 dependencies =
579642 case status of
580− SCached (Details.Local _ _ deps _) -> deps
581− SChanged (Details.Local _ _ deps _) _ _ -> deps
582− SBadImport _ -> []
583− SBadSyntax _ _ _ _ -> []
584− SForeign _ -> []
585− SKernel -> []
643+ SCached (Details.Local _ _ deps _ _ _) -> deps
644+ SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
645+ SBadImport _ -> []
646+ SBadSyntax _ _ _ _ -> []
647+ SForeign _ -> []
648+ SKernel -> []
586649 in
587650 (name, name, dependencies) : graph
588651
589652
590653
591−-- CHECK UNIQUE MAINS
654+-- CHECK UNIQUE ROOTS
592655
593656
594−checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
595−checkUniqueMains insides smains =
657+checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
658+checkUniqueRoots insides sroots =
596659 let
597660 outsidesDict =
598− Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
661+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
599662 in
600663 case Map.traverseWithKey checkOutside outsidesDict of
601664 Left problem ->
@@ -607,61 +670,78 @@ checkUniqueMains insides smains =
607670 Left problem -> Just problem
608671
609672
610−mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
611−mainStatusToNamePathPair smain =
612− case smain of
613− SInside _ -> Nothing
614− SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
615− 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
616679
617680
618681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
619682checkOutside name paths =
620683 case OneOrMore.destruct NE.List paths of
621684 NE.List p [] -> Right p
622− NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
685+ NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
623686
624687
625688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
626689checkInside name p1 status =
627690 case status of
628− SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
629− SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
630− SBadImport _ -> Right ()
631− SBadSyntax _ _ _ _ -> Right ()
632− SForeign _ -> Right ()
633− 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 ()
634697
635698
636699
637700-- COMPILE MODULE
638701
639702
640−compile :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
641−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
642708 case Compile.compile pkg ifaces modul of
643709 Right (Compile.Artifacts canonical annotations objects) ->
644− do let name = Src.getName modul
645− let iface = I.fromModule pkg canonical annotations
646− File.writeBinary (Stuff.elmo root name) objects
647− maybeOldi <- File.readBinary (Stuff.elmi root name)
648− case maybeOldi of
649− Just oldi | oldi == iface ->
650− do -- iface should be fully forced by equality check
651− Reporting.report key Reporting.BDone
652− return (RSame local iface objects)
653−
654− _ ->
655− do -- iface may be lazy still
656− -- TODO try adding forkIO here
657− File.writeBinary (Stuff.elmi root name) iface
658− Reporting.report key Reporting.BDone
659− 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)
660734
661735 Left err ->
662− do Reporting.report key Reporting.BDone
663− return $ RProblem $
664− 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
665745
666746
667747
@@ -669,64 +749,210 @@ compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifac
669749
670750
671751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
672−writeDetails root (Details.Details time outline locals foreigns extras) results =
752+writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
673753 File.writeBinary (Stuff.details root) $
674− Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
754+ Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
675755
676756
677757addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
678758addNewLocal name result locals =
679759 case result of
680− RNew local _ _ -> Map.insert name local locals
681− RSame local _ _ -> Map.insert name local locals
682− RCached _ _ -> locals
683− RNotFound _ -> locals
684− RProblem _ -> locals
685− RBlocked -> locals
686− RForeign _ -> locals
687− 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
688768
689769
690770
691−-- DETECT EXPOSED PROBLEMS
771+-- FINALIZE EXPOSED
692772
693773
694−detectExposedProblems :: NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
695−detectExposedProblems exposed results =
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 =
696776 case foldr (addImportProblems results) [] (NE.toList exposed) of
697777 p:ps ->
698− Left (Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps)))
778+ return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
699779
700780 [] ->
701781 case Map.foldr addErrors [] results of
702− [] -> Right ()
703− e:es -> Left (Exit.BuildModuleProblems e es)
782+ [] -> Right <$> finalizeDocs docsGoal results
783+ e:es -> return $ Left $ Exit.BuildBadModules root e es
704784
705785
706786addErrors :: Result -> [Error.Module] -> [Error.Module]
707787addErrors result errors =
708788 case result of
709− RNew _ _ _ -> errors
710− RSame _ _ _ -> errors
711− RCached _ _ -> errors
712− RNotFound _ -> errors
713− RProblem e -> e:errors
714− RBlocked -> errors
715− RForeign _ -> errors
716− 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
717797
718798
719799addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
720800addImportProblems results name problems =
721801 case results ! name of
722− RNew _ _ _ -> problems
723− RSame _ _ _ -> problems
724− RCached _ _ -> problems
725− RNotFound p -> (name, p) : problems
726− RProblem _ -> problems
727− RBlocked -> problems
728− RForeign _ -> problems
729− RKernel -> problems
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
730956
731957
732958
@@ -738,25 +964,25 @@ addImportProblems results name problems =
738964
739965
740966
741−-- FIND MAIN
967+-- FIND ROOT
742968
743969
744−data MainLocation
970+data RootLocation
745971 = LInside ModuleName.Raw
746972 | LOutside FilePath
747973
748974
749−findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
750−findMains env paths =
751− do mvars <- traverse (fork . findLocation env) paths
752− elocs <- traverse readMVar mvars
753− 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
754980
755981
756−checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
757−checkLocations locations =
982+checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
983+checkRoots infos =
758984 let
759− toOneOrMore loc@(Location absolute _ _) =
985+ toOneOrMore loc@(RootInfo absolute _ _) =
760986 (absolute, OneOrMore.one loc)
761987
762988 fromOneOrMore loc locs =
@@ -764,71 +990,83 @@ checkLocations locations =
764990 [] -> Right ()
765991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
766992 in
767− fmap (\_ -> fmap _location locations) $
993+ fmap (\_ -> fmap _location infos) $
768994 traverse (OneOrMore.destruct fromOneOrMore) $
769− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
995+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
770996
771997
772998
773−-- LOCATIONS
999+-- ROOT INFO
7741000
7751001
776−data Location =
777− Location
1002+data RootInfo =
1003+ RootInfo
7781004 { _absolute :: FilePath
7791005 , _relative :: FilePath
780− , _location :: MainLocation
1006+ , _location :: RootLocation
7811007 }
7821008
7831009
784−findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
785−findLocation env path =
1010+getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1011+getRootInfo env path =
7861012 do exists <- File.exists path
7871013 if exists
788− then isInsideSrcDirs env path <$> Dir.canonicalizePath path
1014+ then getRootInfoHelp env path =<< Dir.canonicalizePath path
7891015 else return (Left (Exit.BP_PathUnknown path))
7901016
7911017
792−isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
793−isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
1018+getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1019+getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
7941020 let
7951021 (dirs, file) = FP.splitFileName absolutePath
796− (final, ext) = break (=='.') file
1022+ (final, ext) = FP.splitExtension file
7971023 in
7981024 if ext /= ".elm"
799− then Left (Exit.BP_WithBadExtension path)
1025+ then
1026+ return $ Left $ Exit.BP_WithBadExtension path
8001027 else
8011028 let
802− roots = FP.splitDirectories root
803− segments = FP.splitDirectories dirs ++ [final]
1029+ absoluteSegments = FP.splitDirectories dirs ++ [final]
8041030 in
805− case dropPrefix roots segments of
806− Nothing ->
807− Right (Location absolutePath path (LOutside path))
808−
809− Just relativeSegments ->
810− let
811− (exits, maybes) =
812− Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
813− in
814− -- TODO make sure this is all correct
815− case (exits, Maybe.catMaybes maybes) of
816− (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
817− ([], []) -> Right (Location absolutePath path (LOutside path))
818− (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
819− (exit:_, _) -> Left exit
820−
821−
822−isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
823−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) =
8241062 case dropPrefix (FP.splitDirectories srcDir) segments of
8251063 Nothing ->
826− Right Nothing
1064+ Nothing
8271065
8281066 Just names ->
8291067 if all isGoodName names
830− then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
831− else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
1068+ then Just (srcDir, Right names)
1069+ else Just (srcDir, Left names)
8321070
8331071
8341072isGoodName :: [Char] -> Bool
@@ -841,6 +1079,8 @@ isGoodName name =
8411079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
8421080
8431081
1082+-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083+--
8441084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
8451085dropPrefix roots paths =
8461086 case roots of
@@ -849,37 +1089,37 @@ dropPrefix roots paths =
8491089
8501090 r:rs ->
8511091 case paths of
852− [] -> Nothing
1092+ [] -> Nothing
8531093 p:ps -> if r == p then dropPrefix rs ps else Nothing
8541094
8551095
8561096
857−-- CRAWL MAINS
1097+-- CRAWL ROOTS
8581098
8591099
860−data MainStatus
1100+data RootStatus
8611101 = SInside ModuleName.Raw
8621102 | SOutsideOk Details.Local B.ByteString Src.Module
8631103 | SOutsideErr Error.Module
8641104
8651105
866−crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
867−crawlMain env@(Env _ _ pkg _ _ _) mvar given =
868− case given of
1106+crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
1107+crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1108+ case root of
8691109 LInside name ->
8701110 do statusMVar <- newEmptyMVar
8711111 statusDict <- takeMVar mvar
8721112 putMVar mvar (Map.insert name statusMVar statusDict)
873− putMVar statusMVar =<< crawlModule env mvar name
1113+ putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
8741114 return (SInside name)
8751115
8761116 LOutside path ->
8771117 do time <- File.getTime path
8781118 source <- File.readUtf8 path
879− case Parse.fromByteString pkg source of
1119+ case Parse.fromByteString projectType source of
8801120 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
8811121 do let deps = map Src.getImportName imports
882− let local = Details.Local path time deps (any isMain values)
1122+ let local = Details.Local path time deps (any isMain values) buildID buildID
8831123 crawlDeps env mvar deps (SOutsideOk local source modul)
8841124
8851125 Left syntaxError ->
@@ -888,40 +1128,36 @@ crawlMain env@(Env _ _ pkg _ _ _) mvar given =
8881128
8891129
8901130
891−-- CHECK MAINS
1131+-- CHECK ROOTS
8921132
8931133
894−data MainResult
1134+data RootResult
8951135 = RInside ModuleName.Raw
8961136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
8971137 | ROutsideErr Error.Module
8981138 | ROutsideBlocked
8991139
9001140
901−checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
902−checkMain env@(Env _ root _ _ _ _) results pendingMain =
903− case pendingMain of
1141+checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
1142+checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
1143+ case rootStatus of
9041144 SInside name ->
9051145 return (RInside name)
9061146
9071147 SOutsideErr err ->
9081148 return (ROutsideErr err)
9091149
910− SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
911− 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
9121152 case depsStatus of
9131153 DepsChange ifaces ->
914− return $ compileOutside env local source ifaces modul
1154+ compileOutside env local source ifaces modul
9151155
9161156 DepsSame same cached ->
917− do maybeLoaded <- checkCachedInterfaces root cached
1157+ do maybeLoaded <- loadInterfaces root same cached
9181158 case maybeLoaded of
919− Nothing ->
920− return ROutsideBlocked
921−
922− Just loaded ->
923− do let ifaces = Map.union loaded (Map.fromList same)
924− return $ compileOutside env local source ifaces modul
1159+ Nothing -> return ROutsideBlocked
1160+ Just ifaces -> compileOutside env local source ifaces modul
9251161
9261162 DepsBlock ->
9271163 return ROutsideBlocked
@@ -931,53 +1167,54 @@ checkMain env@(Env _ root _ _ _ _) results pendingMain =
9311167 Error.BadImports (toImportErrors env results imports problems)
9321168
9331169
934−compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
935−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 =
9361172 let
1173+ pkg = projectTypeToPkg projectType
9371174 name = Src.getName modul
9381175 in
9391176 case Compile.compile pkg ifaces modul of
9401177 Right (Compile.Artifacts canonical annotations objects) ->
941− 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
9421180
9431181 Left errors ->
944− ROutsideErr $
945− Error.Module name path time source errors
1182+ return $ ROutsideErr $ Error.Module name path time source errors
9461183
9471184
9481185
9491186-- TO ARTIFACTS
9501187
9511188
952−data Main
1189+data Root
9531190 = Inside ModuleName.Raw
9541191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
9551192
9561193
957−toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
958−toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
959− 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
9601197 Left (NE.List e es) ->
961− Left (Exit.BuildModuleProblems e es)
1198+ Left (Exit.BuildBadModules root e es)
9621199
963− Right mains ->
964− Right $ Artifacts pkg foreigns mains $
965− 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
9661203
9671204
968−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
969−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) =
9701207 let
971− sortMain result (es, mains) =
1208+ addResult result (es, roots) =
9721209 case result of
973− RInside n -> ( es, Inside n : mains)
974− ROutsideOk n i o -> ( es, Outside n i o : mains)
975− ROutsideErr e -> (e:es, mains)
976− 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)
9771214
9781215 errors = Map.foldr addErrors [] results
9791216 in
980− case (mainResult, foldr sortMain (errors, []) mainResults) of
1217+ case (rootResult, foldr addResult (errors, []) rootResults) of
9811218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
9821219 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
9831220 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
@@ -990,14 +1227,14 @@ gatherProblemsOrMains results (NE.List mainResult mainResults) =
9901227addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
9911228addInside name result modules =
9921229 case result of
993− RNew _ iface objs -> Fresh name iface objs : modules
994− RSame _ iface objs -> Fresh name iface objs : modules
995− RCached main mvar -> Cached name main mvar : modules
996− RNotFound _ -> error (badInside name)
997− RProblem _ -> error (badInside name)
998− RBlocked -> error (badInside name)
999− RForeign _ -> modules
1000− 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
10011238
10021239
10031240badInside :: ModuleName.Raw -> [Char]
@@ -1005,9 +1242,9 @@ badInside name =
10051242 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
10061243
10071244
1008−addOutside :: MainResult -> [Module] -> [Module]
1009−addOutside main modules =
1010− case main of
1245+addOutside :: RootResult -> [Module] -> [Module]
1246+addOutside root modules =
1247+ case root of
10111248 RInside _ -> modules
10121249 ROutsideOk name iface objs -> Fresh name iface objs : modules
10131250 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+193−96
@@ -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
598+ case Parse.fromByteString (Parse.Package pkg) bytes of
571599 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+146−117
@@ -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,11 +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
2323import qualified Data.NonEmptyList as NE
24−import qualified Data.Utf8 as Utf8
24+import qualified Data.OneOrMore as OneOrMore
25+import Foreign.Ptr (minusPtr)
2526import qualified System.Directory as Dir
27+import qualified System.FilePath as FP
2628import System.FilePath ((</>))
2729
2830import qualified Elm.Constraint as Con
@@ -33,6 +35,9 @@ import qualified Elm.Version as V
3335import qualified File
3436import qualified Json.Decode as D
3537import qualified Json.Encode as E
38+import Json.Encode ((==>))
39+import qualified Json.String as Json
40+import qualified Parse.Primitives as P
3641import qualified Reporting.Exit as Exit
3742
3843
@@ -48,7 +53,7 @@ data Outline
4853data AppOutline =
4954 AppOutline
5055 { _app_elm_version :: V.Version
51− , _app_source_dirs :: NE.List FilePath
56+ , _app_source_dirs :: NE.List SrcDir
5257 , _app_deps_direct :: Map.Map Pkg.Name V.Version
5358 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
5459 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -59,7 +64,7 @@ data AppOutline =
5964data PkgOutline =
6065 PkgOutline
6166 { _pkg_name :: Pkg.Name
62− , _pkg_summary :: Utf8.String
67+ , _pkg_summary :: Json.String
6368 , _pkg_license :: Licenses.License
6469 , _pkg_version :: V.Version
6570 , _pkg_exposed :: Exposed
@@ -71,16 +76,21 @@ data PkgOutline =
7176
7277data Exposed
7378 = ExposedList [ModuleName.Raw]
74− | ExposedDict [(Utf8.String, [ModuleName.Raw])]
79+ | ExposedDict [(Json.String, [ModuleName.Raw])]
80+
81+
82+data SrcDir
83+ = AbsoluteSrcDir FilePath
84+ | RelativeSrcDir FilePath
7585
7686
7787
7888-- DEFAULTS
7989
8090
81−defaultSummary :: Utf8.String
91+defaultSummary :: Json.String
8292defaultSummary =
83− "helpful summary of your project, less than 80 characters"
93+ Json.fromChars "helpful summary of your project, less than 80 characters"
8494
8595
8696
@@ -115,8 +125,8 @@ encode outline =
115125 case outline of
116126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
117127 E.object
118− [ "type" ==> E.string "application"
119− , "source-directories" ==> E.list (E.string . Utf8.fromChars) (NE.toList srcDirs)
128+ [ "type" ==> E.chars "application"
129+ , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
120130 , "elm-version" ==> V.encode elm
121131 , "dependencies" ==>
122132 E.object
@@ -132,7 +142,7 @@ encode outline =
132142
133143 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
134144 E.object
135− [ "type" ==> E.string "package"
145+ [ "type" ==> E.string (Json.fromChars "package")
136146 , "name" ==> Pkg.encode name
137147 , "summary" ==> E.string summary
138148 , "license" ==> Licenses.encode license
@@ -144,11 +154,6 @@ encode outline =
144154 ]
145155
146156
147−(==>) :: a -> b -> (a, b)
148−(==>) a b =
149− (a, b)
150−
151−
152157encodeExposed :: Exposed -> E.Value
153158encodeExposed exposed =
154159 case exposed of
@@ -166,7 +171,14 @@ encodeModule name =
166171
167172encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
168173encodeDeps encodeValue deps =
169− 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
170182
171183
172184
@@ -182,19 +194,72 @@ read root =
182194
183195 Right outline ->
184196 case outline of
185− Pkg _ ->
186− 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)
187224
188− App (AppOutline _ srcDirs _ _ _ _) ->
189− do badDirs <- filterM (isBadSrcDir root) (NE.toList srcDirs)
190− case badDirs of
191− [] -> return $ Right outline
192− d:ds -> return $ Left (Exit.OutlineHasBadSrcDirs d ds)
193225
226+isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
227+isSrcDirMissing root srcDir =
228+ not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
194229
195−isBadSrcDir :: FilePath -> FilePath -> IO Bool
196−isBadSrcDir root dir =
197− not <$> Dir.doesDirectoryExist (root </> dir)
230+
231+toGiven :: SrcDir -> FilePath
232+toGiven srcDir =
233+ case srcDir of
234+ AbsoluteSrcDir dir -> dir
235+ RelativeSrcDir dir -> dir
236+
237+
238+toAbsolute :: FilePath -> SrcDir -> FilePath
239+toAbsolute root srcDir =
240+ case srcDir of
241+ AbsoluteSrcDir dir -> dir
242+ RelativeSrcDir dir -> root </> dir
243+
244+
245+detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
246+detectDuplicates root srcDirs =
247+ do pairs <- traverse (toPair root) srcDirs
248+ return $ Map.lookupMin $ Map.mapMaybe isDup $
249+ Map.fromListWith OneOrMore.more pairs
250+
251+
252+toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
253+toPair root srcDir =
254+ do key <- Dir.canonicalizePath (toAbsolute root srcDir)
255+ return (key, OneOrMore.one (toGiven srcDir))
256+
257+
258+isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
259+isDup paths =
260+ case paths of
261+ OneOrMore.One _ -> Nothing
262+ OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
198263
199264
200265
@@ -207,16 +272,14 @@ type Decoder a =
207272
208273decoder :: Decoder Outline
209274decoder =
275+ let
276+ application = Json.fromChars "application"
277+ package = Json.fromChars "package"
278+ in
210279 do tipe <- D.field "type" D.string
211− case tipe of
212− "application" ->
213− App <$> appDecoder
214−
215− "package" ->
216− Pkg <$> pkgDecoder
217−
218− other ->
219− D.failure (Exit.OP_BadType other)
280+ if | tipe == application -> App <$> appDecoder
281+ | tipe == package -> Pkg <$> pkgDecoder
282+ | otherwise -> D.failure Exit.OP_BadType
220283
221284
222285appDecoder :: Decoder AppOutline
@@ -233,7 +296,7 @@ appDecoder =
233296pkgDecoder :: Decoder PkgOutline
234297pkgDecoder =
235298 PkgOutline
236− <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)
299+ <$> D.field "name" nameDecoder
237300 <*> D.field "summary" summaryDecoder
238301 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
239302 <*> D.field "version" versionDecoder
@@ -247,17 +310,21 @@ pkgDecoder =
247310-- JSON DECODE HELPERS
248311
249312
250−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
251319summaryDecoder =
252− do summary <- D.string
253− if Utf8.size summary < 80
254− then return summary
255− else D.failure Exit.OP_BadSummaryTooLong
320+ D.customString
321+ (boundParser 80 Exit.OP_BadSummaryTooLong)
322+ (\_ _ -> Exit.OP_BadSummaryTooLong)
256323
257324
258325versionDecoder :: Decoder V.Version
259326versionDecoder =
260− D.mapError Exit.OP_BadVersion V.decoder
327+ D.mapError (uncurry Exit.OP_BadVersion) V.decoder
261328
262329
263330constraintDecoder :: Decoder Con.Constraint
@@ -267,27 +334,19 @@ constraintDecoder =
267334
268335depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
269336depsDecoder valueDecoder =
270− Map.fromList <$> (
271− traverse validateKey =<< D.pairs valueDecoder
272− )
273−
337+ D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
274338
275−validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
276−validateKey (key, value) =
277− case Pkg.fromString key of
278− Right name ->
279− return (name, value)
280339
281− Left _ ->
282− D.failure (Exit.OP_BadDependencyName key)
340+dirsDecoder :: Decoder (NE.List SrcDir)
341+dirsDecoder =
342+ fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
283343
284344
285−dirsDecoder :: Decoder (NE.List FilePath)
286−dirsDecoder =
287− do dirs <- D.list D.string
288− case map Utf8.toChars dirs of
289− d:ds -> return (NE.List d ds)
290− [] -> D.failure Exit.OP_NoSrcDirs
345+toSrcDir :: FilePath -> SrcDir
346+toSrcDir path =
347+ if FP.isRelative path
348+ then RelativeSrcDir path
349+ else AbsoluteSrcDir path
291350
292351
293352
@@ -298,81 +357,51 @@ exposedDecoder :: Decoder Exposed
298357exposedDecoder =
299358 D.oneOf
300359 [ ExposedList <$> D.list moduleDecoder
301− , do pairs <- D.pairs (D.list moduleDecoder)
302− traverse_ (checkHeader . fst) pairs
303− return (ExposedDict pairs)
360+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
304361 ]
305362
306363
307364moduleDecoder :: Decoder ModuleName.Raw
308365moduleDecoder =
309− D.mapError Exit.OP_BadModuleName ModuleName.decoder
310−
366+ D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
311367
312−checkHeader :: Utf8.String -> Decoder ()
313−checkHeader header =
314− if Utf8.size header < 20
315− then return ()
316− else D.failure (Exit.OP_BadModuleHeaderTooLong header)
317368
369+headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
370+headerKeyDecoder =
371+ D.KeyDecoder
372+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
373+ (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
318374
319375
320−-- BINARY
321−
322376
323−instance Binary Outline where
324− put outline =
325− case outline of
326− App a -> putWord8 0 >> put a
327− Pkg a -> putWord8 1 >> put a
377+-- BOUND PARSER
328378
329− get =
330− do n <- getWord8
331− case n of
332− 0 -> liftM App get
333− 1 -> liftM Pkg get
334− _ -> error "binary encoding of Outline was corrupted"
335379
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)
336390
337−instance Binary AppOutline where
338− put (AppOutline a b c d e f) =
339− put a >> put b >> put c >> put d >> put e >> put f
340391
341− get =
342− do a <- get
343− b <- get
344− c <- get
345− d <- get
346− e <- get
347− f <- get
348− return (AppOutline a b c d e f)
349392
393+-- BINARY
350394
351−instance Binary PkgOutline where
352− put (PkgOutline a b c d e f g h) =
353− put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
354395
355− get =
356− do a <- get
357− b <- get
358− c <- get
359− d <- get
360− e <- get
361− f <- get
362− g <- get
363− h <- get
364− return (PkgOutline a b c d e f g h)
365−
366−
367−instance Binary Exposed where
368− put exposed =
369− case exposed of
370− ExposedList a -> putWord8 0 >> put a
371− 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
372401
373402 get =
374403 do n <- getWord8
375404 case n of
376− 0 -> liftM ExposedList get
377− 1 -> liftM ExposedDict get
378− _ -> 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+1628−387
@@ -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,61 +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
35+import qualified Data.Map as Map
36+import qualified Data.Name as N
3737import qualified Data.NonEmptyList as NE
38−import qualified Data.Utf8 as Utf8
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 ((</>), (<.>))
3943
4044import qualified Elm.Constraint as C
4145import qualified Elm.Magnitude as M
4246import qualified Elm.ModuleName as ModuleName
4347import qualified Elm.Package as Pkg
4448import qualified Elm.Version as V
49+import qualified File
4550import qualified Http
51+import qualified Json.Decode as Decode
4652import 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
4756import Reporting.Doc ((<>))
4857import qualified Reporting.Doc as D
4958import qualified Reporting.Error.Import as Import
5059import qualified Reporting.Error.Json as Json
5160import qualified Reporting.Exit.Help as Help
5261import qualified Reporting.Error as Error
62+import qualified Reporting.Render.Code as Code
5363
5464
5565
56−-- ALL POSSIBLE ERRORS
66+-- RENDERERS
5767
5868
59−data Exit
60− -- bump
61− = BumpApplication
62− | BumpUnexpectedVersion V.Version [V.Version]
63− | BumpMustHaveLatestRegistry RegistryProblem
64− | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
65− -- publish
66− | PublishMustHaveLatestRegistry RegistryProblem
67− | PublishApplication
68− | PublishNotInitialVersion V.Version
69− | PublishAlreadyPublished V.Version
70− | PublishInvalidBump V.Version V.Version
71− | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
72− | PublishNoSummary
73− | PublishNoExposed
74− | PublishNoReadme
75− | PublishShortReadme
76− | PublishNoLicense
77− | PublishCannotGetTag Http.Error
78− | PublishCannotGetZip Http.Error
79− | PublishCannotDecodeZip
80− | PublishCannotGetDocs DocsProblem
81− | PublishCannotRegister Http.Error
82− | PublishMissingTag V.Version
83− | PublishNoGit
84− | PublishLocalChanges V.Version
69+toString :: Help.Report -> String
70+toString report =
71+ Help.toString (Help.reportToDoc report)
8572
8673
87−data DocsProblem
88− = DP_Http Http.Error
89− | DP_Data
90− | 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
9182
9283
9384
@@ -118,13 +109,18 @@ initToReport exit =
118109
119110 InitNoOfflineSolution pkgs ->
120111 Help.report "NO OFFLINE SOLUTION" Nothing
121− (error "TODO InitNoOfflineSolution" pkgs)
122− (error "TODO InitNoOfflineSolution" pkgs)
123− -- note about Russia IP addresses?
124− -- 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+ ]
125121
126122 InitSolverProblem solver ->
127− error "TODO InitSolverProblem" solver
123+ toSolverReport solver
128124
129125 InitAlreadyExists ->
130126 Help.report "EXISTING PROJECT" Nothing
@@ -135,8 +131,9 @@ initToReport exit =
135131 ]
136132 ]
137133
138− InitRegistryProblem _ ->
139− 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"
140137
141138
142139
@@ -144,22 +141,48 @@ initToReport exit =
144141
145142
146143data Diff
147− = DiffApplication
144+ = DiffNoOutline
145+ | DiffBadOutline Outline
146+ | DiffApplication
147+ | DiffNoExposed
148148 | DiffUnpublished
149149 | DiffUnknownPackage Pkg.Name [Pkg.Name]
150150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
151− | DiffCannotFindDocs DocsProblem
151+ | DiffDocsProblem V.Version DocsProblem
152152 | DiffMustHaveLatestRegistry RegistryProblem
153+ | DiffBadDetails Details
154+ | DiffBadBuild BuildProblem
153155
154156
155157diffToReport :: Diff -> Help.Report
156158diffToReport diff =
157159 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+
158171 DiffApplication ->
159− Help.report "CANNOT DIFF APPLICATIONS" Nothing
160− "I cannot perform diffs on applications, only packages! If you are\
161− \ just curious to see a diff, try running this command:"
162− [ 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."
163186 ]
164187
165188 DiffUnpublished ->
@@ -171,16 +194,16 @@ diffToReport diff =
171194 Help.report "UNKNOWN PACKAGE" Nothing
172195 ( "I cannot find a package called:"
173196 )
174− [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg
197+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
175198 , "Maybe you want one of these instead?"
176− , 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
177200 , "But check <https://package.elm-lang.org> to see all possibilities!"
178201 ]
179202
180203 DiffUnknownVersion _pkg vsn realVersions ->
181204 Help.docReport "UNKNOWN VERSION" Nothing
182205 ( D.fillSep $
183− [ "Version", D.red (D.fromUtf8 (V.toString vsn))
206+ [ "Version", D.red (D.fromVersion vsn)
184207 , "has", "never", "been", "published,", "so", "I"
185208 , "cannot", "diff", "against", "it."
186209 ]
@@ -189,232 +212,57 @@ diffToReport diff =
189212 , D.indent 4 $ D.dullyellow $ D.vcat $
190213 let
191214 sameMajor v1 v2 = V._major v1 == V._major v2
192− mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns
215+ mkRow vsns = D.hsep $ map D.fromVersion vsns
193216 in
194217 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
195218 , "Want one of those instead?"
196219 ]
197220
198− DiffCannotFindDocs problem ->
199− error "TODO DiffCannotFindDocs" problem
221+ DiffDocsProblem version problem ->
222+ toDocsProblemReport problem $
223+ "I need the docs for " ++ V.toChars version ++ " to compute this diff"
200224
201225 DiffMustHaveLatestRegistry problem ->
202− 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"
203228
229+ DiffBadDetails details ->
230+ toDetailsReport details
204231
232+ DiffBadBuild buildProblem ->
233+ toBuildProblemReport buildProblem
205234
206−-- INSTALL
207235
208236
209−data Install
210− = InstallNoProject
211− | InstallNoArgs FilePath
212− | InstallNoOnlineSolution
213− | InstallNoOfflineSolution
214− | InstallHadSolverTrouble Solver
215− | InstallUnknownPackageOnline [Pkg.Name]
216− | InstallUnknownPackageOffline [Pkg.Name]
217− | InstallHasBadDetails Details
237+-- BUMP
218238
219239
220−installToReport :: Install -> Help.Report
221−installToReport exit =
222− case exit of
223− InstallNoProject ->
224− Help.report "NEW PROJECT?" Nothing
225− "Are you trying to start a new project? Try this command instead:"
226− [ D.indent 4 $ D.green "elm init"
227− , D.reflow "It will help you get started!"
228− ]
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
229250
230− InstallNoArgs elmHome ->
231− Help.report "INSTALL WHAT?" Nothing
232− "I am expecting commands like:"
233− [ D.green $ D.indent 4 $ D.vcat $
234− [ "elm install elm/http"
235− , "elm install elm/json"
236− , "elm install elm/random"
237− ]
238− , D.toFancyHint
239− ["In","JavaScript","folks","run","`npm install`","to","start","projects."
240− ,"\"Gotta","download","everything!\"","But","why","download","packages"
241− ,"again","and","again?","Instead,","Elm","caches","packages","in"
242− ,D.dullyellow (D.fromChars elmHome)
243− ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
244− ,"Elm","projects","check","that","cache","before","trying","the","internet."
245− ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
246− ,"easier","to","work","offline.","As","a","result"
247− ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
248− ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
249− ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
250− ]
251− ]
252251
253− InstallNoOnlineSolution ->
254− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO recommend using solver in `elm reactor`
255− "This usually happens if you try to modify dependency constraints by\
256− \ hand. I recommend deleting any dependency you added recently (or all\
257− \ of them if things are bad) and then adding them again with:"
258− [ D.indent 4 $ D.green "elm install"
259− , D.reflow $
260− "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."
261262 ]
262263
263− InstallNoOfflineSolution ->
264− error "TODO InstallNoOfflineSolution"
265−
266− InstallHadSolverTrouble solver ->
267− error "TODO InstallHadSolverTrouble" solver
268−
269− InstallUnknownPackageOnline suggestions ->
270− error "TODO InstallUnknownPackageOnline" suggestions
271−
272− InstallUnknownPackageOffline suggestions ->
273− error "TODO InstallUnknownPackageOffline" suggestions
274−
275− InstallHasBadDetails _ ->
276− error "TODO InstallHasBadDetails"
277−
278−
279−{- TODO detect if library has no 0.19.0 version. Maybe do this on website though?
280− Help.report "OLD DEPENDENCIES" (Just "elm.json")
281− ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
282− )
283− [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
284− , D.reflow $
285− "This may be because it is not upgraded yet. It may be because a\
286− \ better solution came along, so there was no need to upgrade it.\
287− \ Etc. Try asking around on Slack to learn more about the topic."
288− , D.toSimpleNote
289− "Whatever the case, please be kind to the relevant package authors! Having\
290− \ friendly interactions with users is great motivation, and conversely, getting\
291− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
292− \ authors are humans with families, friends, jobs, vacations, responsibilities,\
293− \ goals, etc. They face obstacles outside of their technical work you will never\
294− \ know about, so please assume the best and try to be patient and supportive!"
295− ]
296−-}
297−
298−
299−
300−-- SOLVER
301−
302−
303−data Solver
304− = SolverBadCacheData Pkg.Name V.Version
305− | SolverBadHttpData Pkg.Name V.Version
306− | SolverBadHttp Http.Error
307−
308−
309−
310−-- OUTLINE
311−
312−
313−data Outline
314− = OutlineHasBadStructure (Json.Error OutlineProblem)
315− | OutlineHasBadSrcDirs FilePath [FilePath]
316−
317−
318−data OutlineProblem
319− = OP_BadType Utf8.String
320− | OP_BadPkgName Pkg.BadName
321− | OP_BadVersion Utf8.String
322− | OP_BadConstraint C.Error
323− | OP_BadModuleName Utf8.String
324− | OP_BadModuleHeaderTooLong Utf8.String
325− | OP_BadDependencyName Utf8.String
326− | OP_BadLicense Utf8.String [Utf8.String]
327− | OP_BadSummaryTooLong
328− | OP_NoSrcDirs
329−
330−
331−
332−-- DETAILS
333−
334−
335−data Details
336− = DetailsCorrupt
337− | DetailsNoSolution
338− | DetailsNoOfflineSolution
339− | DetailsSolverProblem Solver
340− | DetailsBadElmInPkg C.Constraint
341− | DetailsBadElmInAppOutline V.Version
342− | DetailsHandEditedDependencies
343− | DetailsBadOutline Outline
344− | DetailsCannotGetRegistry RegistryProblem
345− | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem
346−
347−
348−data RegistryProblem
349− = RP_Http Http.Error
350− | RP_Data
351−
352−
353−data PackageProblem
354− = PP_BadEndpointRequest Http.Error
355− | PP_BadEndpointContent
356− | PP_BadArchiveRequest Http.Error
357− | PP_BadArchiveContent
358− | PP_BadArchiveHash String String
359−
360−
361−
362−-- MAKE
363−
364−
365−data Make
366− = MakeNeedsOutline
367− | MakeCannotOptimizeAndDebug
368− | MakeBlockedByDetailsProblem Details
369− | MakeAppNeedsFileNames
370− | MakePkgNeedsExposing
371− | MakeMultipleFilesIntoHtml
372− | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
373− | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
374− | MakeCannotBuild BuildProblem
375− | MakeCannotLoadArtifacts
376−
377−
378−data BuildProblem
379− = BuildModuleProblems Error.Module [Error.Module]
380− | BuildProjectProblem BuildProjectProblem
381−
382−
383−data BuildProjectProblem
384− = BP_PathUnknown FilePath
385− | BP_WithBadExtension FilePath
386− | BP_WithAmbiguousSrcDir FilePath FilePath
387− | BP_MainPathDuplicate FilePath FilePath
388− | BP_MainNameDuplicate ModuleName.Raw FilePath FilePath
389− | BP_CannotLoadDependencies
390− | BP_Cycle ModuleName.Raw [ModuleName.Raw]
391− | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
392−
393−
394−
395−-- RENDERERS
396−
397−
398−toString :: Help.Report -> String
399−toString report =
400− Help.toString (Help.reportToDoc report)
401−
402−
403−toStderr :: Help.Report -> IO ()
404−toStderr report =
405− Help.toStderr (Help.reportToDoc report)
406−
407−
408−toJson :: Help.Report -> Encode.Value
409−toJson report =
410− Help.reportToJson report
411−
412−
413−_toReport :: Exit -> Help.Report
414−_toReport exit =
415− case exit of
416−
417− -- bump
264+ BumpBadOutline outline ->
265+ toOutlineReport outline
418266
419267 BumpApplication ->
420268 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
@@ -426,7 +274,7 @@ _toReport exit =
426274 Help.docReport "CANNOT BUMP" (Just "elm.json")
427275 ( D.fillSep
428276 ["Your","elm.json","says","I","should","bump","relative","to","version"
429− ,D.red (D.fromUtf8 (V.toString vsn)) <> ","
277+ ,D.red (D.fromVersion vsn) <> ","
430278 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
431279 ,"That","means","there","is","no","API","for","me","to","diff","against","and"
432280 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
@@ -435,19 +283,116 @@ _toReport exit =
435283 [ D.fillSep $
436284 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
437285 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
438− , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions
286+ , D.vcat $ map (D.green . D.fromVersion) versions
439287 ]
440288
441289 BumpMustHaveLatestRegistry problem ->
442− 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+ ]
443386
444− BumpCannotFindDocs name version problem ->
445− error "TODO BumpCannotFindDocs" name version problem
387+ PublishBadOutline outline ->
388+ toOutlineReport outline
446389
447− -- publish
390+ PublishBadDetails problem ->
391+ toDetailsReport problem
448392
449393 PublishMustHaveLatestRegistry problem ->
450− 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"
451396
452397 PublishApplication ->
453398 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
@@ -456,7 +401,7 @@ _toReport exit =
456401 Help.docReport "INVALID VERSION" Nothing
457402 ( D.fillSep
458403 ["I","cannot","publish"
459− ,D.red (D.fromUtf8 (V.toString vsn))
404+ ,D.red (D.fromVersion vsn)
460405 ,"as","the","initial","version."
461406 ]
462407 )
@@ -470,7 +415,7 @@ _toReport exit =
470415 Help.docReport "ALREADY PUBLISHED" Nothing
471416 ( D.vcat
472417 [ D.fillSep
473− [ "Version", D.green (D.fromUtf8 (V.toString vsn))
418+ [ "Version", D.green (D.fromVersion vsn)
474419 , "has", "already", "been", "published.", "You", "cannot"
475420 , "publish", "it", "again!"
476421 ]
@@ -487,14 +432,14 @@ _toReport exit =
487432 Help.docReport "INVALID VERSION" (Just "elm.json")
488433 ( D.fillSep $
489434 ["Your","elm.json","says","the","next","version","should","be"
490− ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","
435+ ,D.red (D.fromVersion statedVersion) <> ","
491436 ,"but","that","is","not","valid","based","on","the","previously"
492437 ,"published","versions."
493438 ]
494439 )
495440 [ D.fillSep $
496441 ["Change","the","version","back","to"
497− ,D.green (D.fromUtf8 (V.toString latestVersion))
442+ ,D.green (D.fromVersion latestVersion)
498443 ,"which","is","the","most","recently","published","version."
499444 ,"From","there,","have","Elm","bump","the","version","by","running:"
500445 ]
@@ -509,7 +454,7 @@ _toReport exit =
509454 (
510455 D.fillSep $
511456 ["Your","elm.json","says","the","next","version","should","be"
512− ,D.red (D.fromUtf8 (V.toString new)) <> ","
457+ ,D.red (D.fromVersion new) <> ","
513458 ,"indicating","a",D.fromChars (M.toChars magnitude)
514459 ,"change","to","the","public","API."
515460 ,"This","does","not","match","the","API","diff","given","by:"
@@ -522,7 +467,7 @@ _toReport exit =
522467 ["This","command","says","this","is","a"
523468 ,D.fromChars (M.toChars realMagnitude)
524469 ,"change,","so","the","next","version","should","be"
525− ,D.green (D.fromUtf8 (V.toString realNew)) <> "."
470+ ,D.green (D.fromVersion realNew) <> "."
526471 ,"Double","check","everything","to","make","sure","you"
527472 ,"are","publishing","what","you","want!"
528473 ]
@@ -552,16 +497,17 @@ _toReport exit =
552497 ]
553498 )
554499 [ D.reflow $
555− "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."
556502 ]
557503
558504 PublishNoReadme ->
559− badReadmeReport "NO README" $
505+ toBadReadmeReport "NO README" $
560506 "Every published package must have a helpful README.md\
561507 \ file, but I do not see one in your project."
562508
563509 PublishShortReadme ->
564− badReadmeReport "SHORT README" $
510+ toBadReadmeReport "SHORT README" $
565511 "This README.md is too short. Having more details will help\
566512 \ people assess your package quickly and fairly."
567513
@@ -578,20 +524,8 @@ _toReport exit =
578524 \ named LICENSE. Add that file and you will be all set!"
579525 ]
580526
581− PublishCannotGetTag httpError ->
582− error "TODO PublishCannotGetTag" httpError
583−
584− PublishCannotGetZip httpError ->
585− error "TODO PublishCannotGetZip" httpError
586−
587− PublishCannotDecodeZip ->
588− error "TODO PublishCannotDecodeZip"
589−
590− PublishCannotGetDocs docsProblem ->
591− error "TODO PublishCannotGetDocs" docsProblem
592−
593− PublishCannotRegister httpError ->
594− error "TODO PublishCannotRegister" httpError
527+ PublishBuildProblem buildProblem ->
528+ toBuildProblemReport buildProblem
595529
596530 PublishMissingTag version ->
597531 let vsn = V.toChars version in
@@ -612,18 +546,82 @@ _toReport exit =
612546 , "The -m flag is for a helpful message. Try to make it more informative!"
613547 ]
614548
615− PublishNoGit ->
616− Help.report "NO GIT" Nothing
617− "I searched your PATH environment variable for `git` and could not\
618− \ find it. Is it available through your PATH?"
619− [ D.reflow $
620− "Who cares about this? Well, I currently use `git` to check if there\
621− \ are any local changes in your code. Local changes are a good sign\
622− \ that some important improvements have gotten mistagged, so this\
623− \ check can be extremely helpful for package authors!"
624− , D.toSimpleNote $
625− "We plan to do this without the `git` binary in a future release."
626− ]
549+ PublishCannotGetTag version httpError ->
550+ case httpError of
551+ Http.BadHttp _ (HTTP.StatusCodeException response _)
552+ | HTTP.statusCode (HTTP.responseStatus response) == 404 ->
553+ let vsn = V.toChars version in
554+ Help.report "NO TAG ON GITHUB" Nothing
555+ ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")
556+ [ D.reflow
557+ "Run the following command to make this tag available on GitHub:"
558+ , D.indent 4 $ D.dullyellow $ D.fromChars $
559+ "git push origin " ++ vsn
560+ , D.reflow
561+ "This will make it possible to find your code online based on the version number."
562+ ]
563+
564+ _ ->
565+ toHttpErrorReport "PROBLEM VERIFYING TAG" httpError
566+ "I need to check that the version tag is registered on GitHub"
567+
568+ PublishCannotGetTagData version url body ->
569+ Help.report "PROBLEM VERIFYING TAG" Nothing
570+ ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")
571+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
572+ , D.reflow $
573+ "I got the data back, but it was not what I was expecting. The response\
574+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
575+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
576+ , D.indent 4 $ D.dullyellow $ D.fromChars $
577+ if BS.length body <= 76
578+ then BS_UTF8.toString body
579+ else take 73 (BS_UTF8.toString body) ++ "..."
580+ , D.reflow $
581+ "Does this error keep showing up? Maybe there is something weird with your\
582+ \ internet connection. We have gotten reports that schools, businesses,\
583+ \ airports, etc. sometimes intercept requests and add things to the body\
584+ \ or change its contents entirely. Could that be the problem?"
585+ ]
586+
587+ PublishCannotGetZip httpError ->
588+ toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $
589+ "I need to check that folks can download and build the source code when they\
590+ \ install this package"
591+
592+ PublishCannotDecodeZip url ->
593+ Help.report "PROBLEM DOWNLOADING CODE" Nothing
594+ "I need to check that folks can download and build the source code when they\
595+ \ install this package, so I downloaded the code from:"
596+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
597+ , D.reflow $
598+ "I was unable to unzip the archive though. Maybe there is something weird with\
599+ \ your internet connection. We have gotten reports that schools, businesses,\
600+ \ airports, etc. sometimes intercept requests and add things to the body or\
601+ \ change its contents entirely. Could that be the problem?"
602+ ]
603+
604+ PublishCannotGetDocs old new docsProblem ->
605+ toDocsProblemReport docsProblem $
606+ "I need the docs for " ++ V.toChars old ++ " to verify that "
607+ ++ V.toChars new ++ " really does come next"
608+
609+ PublishCannotRegister httpError ->
610+ toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $
611+ "I need to send information about your package to the package website"
612+
613+ PublishNoGit ->
614+ Help.report "NO GIT" Nothing
615+ "I searched your PATH environment variable for `git` and could not\
616+ \ find it. Is it available through your PATH?"
617+ [ D.reflow $
618+ "Who cares about this? Well, I currently use `git` to check if there\
619+ \ are any local changes in your code. Local changes are a good sign\
620+ \ that some important improvements have gotten mistagged, so this\
621+ \ check can be extremely helpful for package authors!"
622+ , D.toSimpleNote $
623+ "We plan to do this without the `git` binary in a future release."
624+ ]
627625
628626 PublishLocalChanges version ->
629627 let vsn = V.toChars version in
@@ -641,9 +639,21 @@ _toReport exit =
641639 ++ vsn ++ "` and publish your code from there."
642640 ]
643641
642+ PublishZipBadDetails _ ->
643+ badZipReport
644+
645+ PublishZipApplication ->
646+ badZipReport
647+
648+ PublishZipNoExposed ->
649+ badZipReport
650+
651+ PublishZipBuildProblem _ ->
652+ badZipReport
644653
645−badReadmeReport :: String -> String -> Help.Report
646−badReadmeReport title summary =
654+
655+toBadReadmeReport :: String -> String -> Help.Report
656+toBadReadmeReport title summary =
647657 Help.report title (Just "README.md") summary
648658 [ D.reflow $
649659 "When people look at your README, they are wondering:"
@@ -656,32 +666,653 @@ badReadmeReport title summary =
656666 \ most common usage scenario. Show people what they can expect if\
657667 \ they learn more!"
658668 , D.toSimpleNote $
659− "By publishing your package, you are inviting people to invest time\
660− \ in understanding your work. Spending an hour to communicate your\
661− \ knowledge more clearly can save the community days or weeks of time\
662− \ in aggregate, and saving time in aggregate is the whole point of\
663− \ publishing packages! People really appreciate it, and it makes the\
664− \ 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!"
665675 ]
666676
667677
678+badZipReport :: Help.Report
679+badZipReport =
680+ Help.report "PROBLEM VERIFYING PACKAGE" Nothing
681+ "Before publishing packages, I download the code from GitHub and try to build it\
682+ \ from scratch. That way I can be more confident that it will work for other\
683+ \ people too. But I am not able to build it!"
684+ [ D.reflow $
685+ "I was just able to build your local copy though. Is there some way the version\
686+ \ on GitHub could be different?"
687+ ]
688+
689+
690+
691+-- DOCS
692+
693+
694+data DocsProblem
695+ = DP_Http Http.Error
696+ | DP_Data String BS.ByteString
697+ | DP_Cache
698+
699+
700+toDocsProblemReport :: DocsProblem -> String -> Help.Report
701+toDocsProblemReport problem context =
702+ case problem of
703+ DP_Http httpError ->
704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705+
706+ DP_Data url body ->
707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
709+ , D.reflow $
710+ "I got the data back, but it was not what I was expecting. The response\
711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713+ , D.indent 4 $ D.dullyellow $ D.fromChars $
714+ if BS.length body <= 76
715+ then BS_UTF8.toString body
716+ else take 73 (BS_UTF8.toString body) ++ "..."
717+ , D.reflow $
718+ "Does this error keep showing up? Maybe there is something weird with your\
719+ \ internet connection. We have gotten reports that schools, businesses,\
720+ \ airports, etc. sometimes intercept requests and add things to the body\
721+ \ or change its contents entirely. Could that be the problem?"
722+ ]
723+
724+ DP_Cache ->
725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726+ [ D.reflow $
727+ "I deleted the cached version, so the next run should download a fresh copy of\
728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730+ \ for some reason."
731+ ]
732+
733+
734+
735+-- INSTALL
736+
737+
738+data Install
739+ = InstallNoOutline
740+ | InstallBadOutline Outline
741+ | InstallBadRegistry RegistryProblem
742+ | InstallNoArgs FilePath
743+ | InstallNoOnlineAppSolution Pkg.Name
744+ | InstallNoOfflineAppSolution Pkg.Name
745+ | InstallNoOnlinePkgSolution Pkg.Name
746+ | InstallNoOfflinePkgSolution Pkg.Name
747+ | InstallHadSolverTrouble Solver
748+ | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
749+ | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
750+ | InstallBadDetails Details
751+
752+
753+installToReport :: Install -> Help.Report
754+installToReport exit =
755+ case exit of
756+ InstallNoOutline ->
757+ Help.report "NEW PROJECT?" Nothing
758+ "Are you trying to start a new project? Try this command instead:"
759+ [ D.indent 4 $ D.green "elm init"
760+ , D.reflow "It will help you get started!"
761+ ]
762+
763+ InstallBadOutline outline ->
764+ toOutlineReport outline
765+
766+ InstallBadRegistry problem ->
767+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
768+ "I need the list of published packages to figure out how to install things"
769+
770+ InstallNoArgs elmHome ->
771+ Help.report "INSTALL WHAT?" Nothing
772+ "I am expecting commands like:"
773+ [ D.green $ D.indent 4 $ D.vcat $
774+ [ "elm install elm/http"
775+ , "elm install elm/json"
776+ , "elm install elm/random"
777+ ]
778+ , D.toFancyHint
779+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."
780+ ,"\"Gotta","download","everything!\"","But","why","download","packages"
781+ ,"again","and","again?","Instead,","Elm","caches","packages","in"
782+ ,D.dullyellow (D.fromChars elmHome)
783+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
784+ ,"Elm","projects","check","that","cache","before","trying","the","internet."
785+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
786+ ,"easier","to","work","offline.","As","a","result"
787+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
788+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
789+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
790+ ]
791+ ]
792+
793+ InstallNoOnlineAppSolution pkg ->
794+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
795+ (
796+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
797+ \ with your existing dependencies."
798+ )
799+ [ D.reflow $
800+ "I checked all the published versions. When that failed, I tried to find any\
801+ \ compatible combination of these packages, even if it meant changing all your\
802+ \ existing dependencies! That did not work either!"
803+ , D.reflow $
804+ "This is most likely to happen when a package is not upgraded yet. Maybe a new\
805+ \ version of Elm came out recently? Maybe a common package was changed recently?\
806+ \ Maybe a better package came along, so there was no need to upgrade this one?\
807+ \ Try asking around https://elm-lang.org/community to learn what might be going on\
808+ \ with this package."
809+ , D.toSimpleNote $
810+ "Whatever the case, please be kind to the relevant package authors! Having\
811+ \ friendly interactions with users is great motivation, and conversely, getting\
812+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
813+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
814+ \ goals, etc. They face obstacles outside of their technical work you will never\
815+ \ know about, so please assume the best and try to be patient and supportive!"
816+ ]
817+
818+ InstallNoOfflineAppSolution pkg ->
819+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
820+ (
821+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
822+ \ with your existing dependencies."
823+ )
824+ [ D.reflow $
825+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
826+ \ able to look through packages that you have downloaded in the past."
827+ , D.reflow $
828+ "Try again later when you have internet!"
829+ ]
830+
831+ InstallNoOnlinePkgSolution pkg ->
832+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
833+ (
834+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
835+ \ with your existing constraints."
836+ )
837+ [ D.reflow $
838+ "With applications, I try to broaden the constraints to see if anything works,\
839+ \ but messing with package constraints is much more delicate business. E.g. making\
840+ \ your constraints stricter may make it harder for applications to find compatible\
841+ \ dependencies. So fixing something here may break it for a lot of other people!"
842+ , D.reflow $
843+ "So I recommend making an application with the same dependencies as your package.\
844+ \ See if there is a solution at all. From there it may be easier to figure out\
845+ \ how to proceed in a way that will disrupt your users as little as possible. And\
846+ \ the solution may be to help other package authors to get their packages updated,\
847+ \ or to drop a dependency entirely."
848+ ]
849+
850+ InstallNoOfflinePkgSolution pkg ->
851+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
852+ (
853+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
854+ \ with your existing constraints."
855+ )
856+ [ D.reflow $
857+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
858+ \ able to look through packages that you have downloaded in the past."
859+ , D.reflow $
860+ "Try again later when you have internet!"
861+ ]
862+
863+ InstallHadSolverTrouble solver ->
864+ toSolverReport solver
865+
866+ InstallUnknownPackageOnline pkg suggestions ->
867+ Help.docReport "UNKNOWN PACKAGE" Nothing
868+ (
869+ D.fillSep
870+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
871+ )
872+ [ D.reflow $
873+ "I looked through https://package.elm-lang.org for packages with similar names\
874+ \ and found these:"
875+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
876+ , D.reflow $ "Maybe you want one of these instead?"
877+ ]
878+
879+ InstallUnknownPackageOffline pkg suggestions ->
880+ Help.docReport "UNKNOWN PACKAGE" Nothing
881+ (
882+ D.fillSep
883+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
884+ )
885+ [ D.reflow $
886+ "I could not connect to https://package.elm-lang.org though, so new packages may\
887+ \ have been published since I last updated my local cache of package names."
888+ , D.reflow $
889+ "Looking through the locally cached names, the closest ones are:"
890+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
891+ , D.reflow $ "Maybe you want one of these instead?"
892+ ]
893+
894+ InstallBadDetails details ->
895+ toDetailsReport details
896+
897+
898+
899+-- SOLVER
900+
901+
902+data Solver
903+ = SolverBadCacheData Pkg.Name V.Version
904+ | SolverBadHttpData Pkg.Name V.Version String
905+ | SolverBadHttp Pkg.Name V.Version Http.Error
906+
907+
908+toSolverReport :: Solver -> Help.Report
909+toSolverReport problem =
910+ case problem of
911+ SolverBadCacheData pkg vsn ->
912+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
913+ (
914+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
915+ \ help me search for a set of compatible packages. I had it cached locally, but\
916+ \ it looks like the file was corrupted!"
917+ )
918+ [ D.reflow $
919+ "I deleted the cached version, so the next run should download a fresh copy.\
920+ \ Hopefully that will get you unstuck, but it will not resolve the root\
921+ \ problem if a 3rd party tool is modifing cached files for some reason."
922+ ]
923+
924+ SolverBadHttpData pkg vsn url ->
925+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
926+ (
927+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
928+ \ help me search for a set of compatible packages, but I ran into corrupted\
929+ \ information from:"
930+ )
931+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
932+ , D.reflow $
933+ "Is something weird with your internet connection. We have gotten reports that\
934+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\
935+ \ to the body or change its contents entirely. Could that be the problem?"
936+ ]
937+
938+ SolverBadHttp pkg vsn httpError ->
939+ toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
940+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
941+ ++ " to help me search for a set of compatible packages"
942+
943+
944+
945+-- OUTLINE
946+
947+
948+data Outline
949+ = OutlineHasBadStructure (Decode.Error OutlineProblem)
950+ | OutlineHasMissingSrcDirs FilePath [FilePath]
951+ | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952+ | OutlineNoPkgCore
953+ | OutlineNoAppCore
954+ | OutlineNoAppJson
955+
956+
957+data OutlineProblem
958+ = OP_BadType
959+ | OP_BadPkgName Row Col
960+ | OP_BadVersion Row Col
961+ | OP_BadConstraint C.Error
962+ | OP_BadModuleName Row Col
963+ | OP_BadModuleHeaderTooLong
964+ | OP_BadDependencyName Row Col
965+ | OP_BadLicense Json.String [Json.String]
966+ | OP_BadSummaryTooLong
967+ | OP_NoSrcDirs
968+
969+
970+toOutlineReport :: Outline -> Help.Report
971+toOutlineReport problem =
972+ case problem of
973+ OutlineHasBadStructure decodeError ->
974+ Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
975+ Json.ExplicitReason "I ran into a problem with your elm.json file."
976+
977+ OutlineHasMissingSrcDirs dir dirs ->
978+ case dirs of
979+ [] ->
980+ Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
981+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
982+ [ D.indent 4 $ D.red $ D.fromChars dir
983+ , D.reflow $
984+ "I cannot find it though. Is it missing? Is there a typo?"
985+ ]
986+
987+ _:_ ->
988+ Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
989+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
990+ [ D.indent 4 $ D.vcat $
991+ map (D.red . D.fromChars) (dir:dirs)
992+ , D.reflow $
993+ "I cannot find them though. Are they missing? Are there typos?"
994+ ]
995+
996+ OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
997+ if dir1 == dir2 then
998+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
999+ "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
1000+ [ D.indent 4 $ D.vcat $
1001+ map (D.red . D.fromChars) [dir1,dir2]
1002+ , D.reflow $
1003+ "Remove one of the entries!"
1004+ ]
1005+ else
1006+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
1007+ "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
1008+ [ D.indent 4 $ D.vcat $
1009+ map (D.red . D.fromChars) [dir1,dir2]
1010+ , D.reflow $
1011+ "These are two different ways of refering to the same directory:"
1012+ , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
1013+ , D.reflow $
1014+ "Remove one of the redundant entries from your \"source-directories\" field."
1015+ ]
1016+
1017+ OutlineNoPkgCore ->
1018+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1019+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1020+ \ of `List` and `Maybe` do not work without it."
1021+ [ D.reflow $
1022+ "If you modified your elm.json by hand, try to change it back! And if you are\
1023+ \ having trouble getting back to a working elm.json, it may be easier to find a\
1024+ \ working package and start fresh with their elm.json file."
1025+ ]
1026+
1027+ OutlineNoAppCore ->
1028+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1029+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1030+ \ of `List` and `Maybe` do not work without it."
1031+ [ D.reflow $
1032+ "If you modified your elm.json by hand, try to change it back! And if you are\
1033+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1034+ \ and use `elm init` to start fresh."
1035+ ]
1036+
1037+ OutlineNoAppJson ->
1038+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1039+ "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
1040+ \ flags and ports."
1041+ [ D.reflow $
1042+ "If you modified your elm.json by hand, try to change it back! And if you are\
1043+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1044+ \ and use `elm init` to start fresh."
1045+ ]
1046+
1047+
1048+toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
1049+toOutlineProblemReport path source _ region problem =
1050+ let
1051+ toHighlight row col =
1052+ Just $ A.Region (A.Position row col) (A.Position row col)
1053+
1054+ toSnippet title highlight pair =
1055+ Help.jsonReport title (Just path) $
1056+ Code.toSnippet source region highlight pair
1057+ in
1058+ case problem of
1059+ OP_BadType ->
1060+ toSnippet "UNEXPECTED TYPE" Nothing
1061+ ( D.reflow $
1062+ "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
1063+ , D.fillSep
1064+ ["Try","changing","the","\"type\"","to"
1065+ ,D.green "\"application\"","or",D.green "\"package\"","instead."
1066+ ]
1067+ )
1068+
1069+ OP_BadPkgName row col ->
1070+ toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
1071+ ( D.reflow $
1072+ "I got stuck while reading your elm.json file. I ran into trouble with the package name:"
1073+ , D.stack
1074+ [ D.fillSep
1075+ ["Package","names","are","always","written","as"
1076+ ,D.green "\"author/project\""
1077+ ,"so","I","am","expecting","to","see","something","like:"
1078+ ]
1079+ , D.dullyellow $ D.indent 4 $ D.vcat $
1080+ [ "\"mdgriffith/elm-ui\""
1081+ , "\"w0rm/elm-physics\""
1082+ , "\"Microsoft/elm-json-tree-view\""
1083+ , "\"FordLabs/elm-star-rating\""
1084+ , "\"1602/json-schema\""
1085+ ]
1086+ , D.reflow
1087+ "The author name should match your GitHub name exactly, and the project name\
1088+ \ needs to follow these rules:"
1089+ , D.indent 4 $ D.vcat $
1090+ [ "+--------------------------------------+-----------+-----------+"
1091+ , "| RULE | BAD | GOOD |"
1092+ , "+--------------------------------------+-----------+-----------+"
1093+ , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
1094+ , "| no leading digits | 3D | elm-3d |"
1095+ , "| no non-ASCII characters | elm-bjørn | elm-bear |"
1096+ , "| no underscores | elm_ui | elm-ui |"
1097+ , "| no double hyphens | elm--hash | elm-hash |"
1098+ , "| no starting or ending hyphen | -elm-tar- | elm-tar |"
1099+ , "+--------------------------------------+-----------+-----------+"
1100+ ]
1101+ , D.toSimpleNote $
1102+ "These rules only apply to the project name, so you should never need\
1103+ \ to change your GitHub name!"
1104+ ]
1105+ )
1106+
1107+ OP_BadVersion row col ->
1108+ toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
1109+ ( D.reflow $
1110+ "I got stuck while reading your elm.json file. I was expecting a version number here:"
1111+ , D.fillSep
1112+ ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
1113+ ,"that","explicitly","states","all","three","numbers!"
1114+ ]
1115+ )
1116+
1117+ OP_BadConstraint constraintError ->
1118+ case constraintError of
1119+ C.BadFormat row col ->
1120+ toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
1121+ ( D.reflow $
1122+ "I got stuck while reading your elm.json file. I do not understand this version constraint:"
1123+ , D.stack
1124+ [ D.fillSep
1125+ ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
1126+ ,"that","explicitly","lists","the","lower","and","upper","bounds."
1127+ ]
1128+ , D.toSimpleNote $
1129+ "The spaces in there are required! Taking them out will confuse me. Adding\
1130+ \ extra spaces confuses me too. I recommend starting with a valid example\
1131+ \ and just changing the version numbers."
1132+ ]
1133+ )
1134+
1135+ C.InvalidRange before after ->
1136+ if before == after then
1137+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1138+ ( D.reflow $
1139+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1140+ , D.fillSep
1141+ ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
1142+ ,"so","it","is","best","to","use","wide","constraints.","I","recommend"
1143+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
1144+ ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
1145+ ,"happen","in","any","of","the","versions","in","that","range."
1146+ ]
1147+ )
1148+
1149+ else
1150+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1151+ ( D.reflow $
1152+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1153+ , D.fillSep
1154+ ["Maybe","you","want","something","like"
1155+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
1156+ ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
1157+ ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
1158+ ,"cannot","happen","in","any","of","the","versions","in","that","range."
1159+ ]
1160+ )
1161+
1162+ OP_BadModuleName row col ->
1163+ toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
1164+ ( D.reflow $
1165+ "I got stuck while reading your elm.json file. I was expecting a module name here:"
1166+ , D.fillSep
1167+ ["I","need","something","like",D.green "\"Html.Events\""
1168+ ,"or",D.green "\"Browser.Navigation\""
1169+ ,"where","each","segment","starts","with","a","capital"
1170+ ,"letter","and","the","segments","are","separated","by","dots."
1171+ ]
1172+ )
1173+
1174+ OP_BadModuleHeaderTooLong ->
1175+ toSnippet "HEADER TOO LONG" Nothing
1176+ ( D.reflow $
1177+ "I got stuck while reading your elm.json file. This section header is too long:"
1178+ , D.stack
1179+ [ D.fillSep
1180+ ["I","need","it","to","be"
1181+ ,D.green "under",D.green "20",D.green "bytes"
1182+ ,"so","it","renders","nicely","on","the","package","website!"
1183+ ]
1184+ , D.toSimpleNote
1185+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1186+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1187+ \ overly restrictive for your needs."
1188+ ]
1189+ )
1190+
1191+ OP_BadDependencyName row col ->
1192+ toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
1193+ ( D.reflow $
1194+ "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
1195+ , D.stack
1196+ [ D.fillSep
1197+ ["Package","names","always","include","the","name","of","the","author,"
1198+ ,"so","I","am","expecting","to","see","dependencies","like"
1199+ ,D.dullyellow "\"mdgriffith/elm-ui\"","and"
1200+ ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
1201+ ]
1202+ , D.fillSep $
1203+ ["I","generally","recommend","finding","the","package","you","want","on"
1204+ ,"the","package","website,","and","installing","it","with","the"
1205+ ,D.green "elm install","command!"
1206+ ]
1207+ ]
1208+ )
1209+
1210+ OP_BadLicense _ suggestions ->
1211+ toSnippet "UNKNOWN LICENSE" Nothing
1212+ ( D.reflow $
1213+ "I got stuck while reading your elm.json file. I do not know about this type of license:"
1214+ ,
1215+ D.stack
1216+ [ D.fillSep
1217+ ["Elm","packages","generally","use"
1218+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
1219+ ,"but","I","accept","any","OSI","approved","SPDX","license."
1220+ ,"Here","some","that","seem","close","to","what","you","wrote:"
1221+ ]
1222+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
1223+ , D.reflow $
1224+ "Check out https://spdx.org/licenses/ for the full list of options."
1225+ ]
1226+ )
1227+
1228+ OP_BadSummaryTooLong ->
1229+ toSnippet "SUMMARY TOO LONG" Nothing
1230+ ( D.reflow $
1231+ "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
1232+ , D.stack
1233+ [ D.fillSep
1234+ ["I","need","it","to","be"
1235+ ,D.green "under",D.green "80",D.green "bytes"
1236+ ,"so","it","renders","nicely","on","the","package","website!"
1237+ ]
1238+ , D.toSimpleNote
1239+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1240+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1241+ \ overly restrictive for your needs."
1242+ ]
1243+ )
1244+
1245+ OP_NoSrcDirs ->
1246+ toSnippet "NO SOURCE DIRECTORIES" Nothing
1247+ ( D.reflow $
1248+ "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
1249+ , D.fillSep
1250+ ["I","need","something","like",D.green "[\"src\"]"
1251+ ,"so","I","know","where","to","look","for","your","modules!"
1252+ ]
1253+ )
1254+
1255+
1256+
1257+-- DETAILS
1258+
1259+
1260+data Details
1261+ = DetailsNoSolution
1262+ | DetailsNoOfflineSolution
1263+ | DetailsSolverProblem Solver
1264+ | DetailsBadElmInPkg C.Constraint
1265+ | DetailsBadElmInAppOutline V.Version
1266+ | DetailsHandEditedDependencies
1267+ | DetailsBadOutline Outline
1268+ | DetailsCannotGetRegistry RegistryProblem
1269+ | DetailsBadDeps FilePath [DetailsBadDep]
1270+
6681271
669−-- DETAILS TO REPORT
1272+data DetailsBadDep
1273+ = BD_BadDownload Pkg.Name V.Version PackageProblem
1274+ | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)
6701275
6711276
672−detailsToReport :: Details -> Help.Report
673−detailsToReport details =
1277+toDetailsReport :: Details -> Help.Report
1278+toDetailsReport details =
6741279 case details of
675− DetailsCorrupt ->
676− 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
6771308
6781309 DetailsBadElmInPkg constraint ->
6791310 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
6801311 "Your elm.json says this package needs a version of Elm in this range:"
681− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ C.toString constraint
1312+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
6821313 , D.fillSep
6831314 [ "But", "you", "are", "using", "Elm"
684− , D.red (D.fromUtf8 (V.toString V.compiler))
1315+ , D.red (D.fromVersion V.compiler)
6851316 , "right", "now."
6861317 ]
6871318 ]
@@ -691,40 +1322,286 @@ detailsToReport details =
6911322 "Your elm.json says this application needs a different version of Elm."
6921323 [ D.fillSep
6931324 [ "It", "requires"
694− , D.green (D.fromUtf8 (V.toString version)) <> ","
1325+ , D.green (D.fromVersion version) <> ","
6951326 , "but", "you", "are", "using"
696− , D.red (D.fromUtf8 (V.toString V.compiler))
1327+ , D.red (D.fromVersion V.compiler)
6971328 , "right", "now."
6981329 ]
6991330 ]
7001331
7011332 DetailsHandEditedDependencies ->
702− 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+ ]
7031344
704− DetailsBadOutline problem ->
705− error "TODO DetailsBadOutline" problem
1345+ DetailsBadOutline outline ->
1346+ toOutlineReport outline
7061347
7071348 DetailsCannotGetRegistry problem ->
708− 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+ ]
7091365
710− DetailsCannotBuildPackage name version problem ->
711− error "TODO DetailsCannotBuildPackage" name version problem
1366+ d:_ ->
1367+ case d of
1368+ BD_BadDownload pkg vsn packageProblem ->
1369+ toPackageProblemReport pkg vsn packageProblem
7121370
713− DetailsNoSolution ->
714− 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+ ]
7151391
716− DetailsNoOfflineSolution ->
717− error "TODO DetailsNoOfflineSolution"
7181392
719− DetailsSolverProblem _ ->
720− 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+ ]
7211434
1435+ PP_BadArchiveRequest httpError ->
1436+ toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1437+ "I was trying to download the source code for " ++ thePackage
1438+
1439+ PP_BadArchiveContent url ->
1440+ Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1441+ (
1442+ "I downloaded the source code for " ++ thePackage ++ " from:"
1443+ )
1444+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1445+ , D.reflow $
1446+ "But I was unable to unzip the data. Maybe there is something weird with\
1447+ \ your internet connection. We have gotten reports that schools, businesses,\
1448+ \ airports, etc. sometimes intercept requests and add things to the body or\
1449+ \ change its contents entirely. Could that be the problem?"
1450+ ]
1451+
1452+ PP_BadArchiveHash url expectedHash actualHash ->
1453+ Help.report "CORRUPT PACKAGE DATA" Nothing
1454+ (
1455+ "I downloaded the source code for " ++ thePackage ++ " from:"
1456+ )
1457+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1458+ , D.reflow "But it looks like the hash of the archive has changed since publication:"
1459+ , D.vcat $ map D.fromChars $
1460+ [ " Expected: " ++ expectedHash
1461+ , " Actual: " ++ actualHash
1462+ ]
1463+ , D.reflow $
1464+ "This usually means that the package author moved the version\
1465+ \ tag, so report it to them and see if that is the issue. Folks\
1466+ \ on Elm slack can probably help as well."
1467+ ]
1468+
1469+
1470+
1471+-- REGISTRY PROBLEM
1472+
1473+
1474+data RegistryProblem
1475+ = RP_Http Http.Error
1476+ | RP_Data String BS.ByteString
1477+
1478+
1479+toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report
1480+toRegistryProblemReport title problem context =
1481+ case problem of
1482+ RP_Http err ->
1483+ toHttpErrorReport title err context
1484+
1485+ RP_Data url body ->
1486+ Help.report title Nothing (context ++ ", so I fetched:")
1487+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1488+ , D.reflow $
1489+ "I got the data back, but it was not what I was expecting. The response\
1490+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
1491+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
1492+ , D.indent 4 $ D.dullyellow $ D.fromChars $
1493+ if BS.length body <= 76
1494+ then BS_UTF8.toString body
1495+ else take 73 (BS_UTF8.toString body) ++ "..."
1496+ , D.reflow $
1497+ "Does this error keep showing up? Maybe there is something weird with your\
1498+ \ internet connection. We have gotten reports that schools, businesses,\
1499+ \ airports, etc. sometimes intercept requests and add things to the body\
1500+ \ or change its contents entirely. Could that be the problem?"
1501+ ]
1502+
1503+
1504+toHttpErrorReport :: String -> Http.Error -> String -> Help.Report
1505+toHttpErrorReport title err context =
1506+ let
1507+ toHttpReport intro url details =
1508+ Help.report title Nothing intro $
1509+ D.indent 4 (D.dullyellow (D.fromChars url)) : details
1510+ in
1511+ case err of
1512+ Http.BadUrl url reason ->
1513+ toHttpReport (context ++ ", so I wanted to fetch:") url
1514+ [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"
1515+ , D.indent 4 $ D.fromChars reason
1516+ , D.reflow $
1517+ "This may indicate that there is some problem in the compiler, so please open an\
1518+ \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\
1519+ \ version, the command you ran, the terminal output, and any additional information\
1520+ \ that might help others reproduce the error."
1521+ ]
1522+
1523+ Http.BadHttp url httpExceptionContent ->
1524+ case httpExceptionContent of
1525+ HTTP.StatusCodeException response body ->
1526+ let
1527+ (HTTP.Status code message) = HTTP.responseStatus response
1528+ in
1529+ toHttpReport (context ++ ", so I tried to fetch:") url
1530+ [ D.fillSep $
1531+ ["But","it","came","back","as",D.red (D.fromInt code)]
1532+ ++ map D.fromChars (words (BS_UTF8.toString message))
1533+ , D.indent 4 $ D.reflow $ BS_UTF8.toString body
1534+ , D.reflow $
1535+ "This may mean some online endpoint changed in an unexpected way, so if does not\
1536+ \ seem like something on your side is causing this (e.g. firewall) please report\
1537+ \ this to https://github.com/elm/compiler/issues with your operating system, Elm\
1538+ \ version, the command you ran, the terminal output, and any additional information\
1539+ \ that can help others reproduce the error!"
1540+ ]
1541+
1542+ HTTP.TooManyRedirects responses ->
1543+ toHttpReport (context ++ ", so I tried to fetch:") url
1544+ [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"
1545+ , D.indent 4 $ D.vcat $ map toRedirectDoc responses
1546+ , D.reflow $
1547+ "Is it possible that your internet connection intercepts certain requests? That\
1548+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1549+ \ and certain countries. Try asking for help locally or in a community forum!"
1550+ ]
1551+
1552+ otherException ->
1553+ toHttpReport (context ++ ", so I tried to fetch:") url
1554+ [ D.reflow $ "But my HTTP library is giving me the following error message:"
1555+ , D.indent 4 $ D.fromChars (show otherException)
1556+ , D.reflow $
1557+ "Are you somewhere with a slow internet connection? Or no internet?\
1558+ \ Does the link I am trying to fetch work in your browser? Maybe the\
1559+ \ site is down? Does your internet connection have a firewall that\
1560+ \ blocks certain domains? It is usually something like that!"
1561+ ]
1562+
1563+ Http.BadMystery url someException ->
1564+ toHttpReport (context ++ ", so I tried to fetch:") url
1565+ [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"
1566+ , D.indent 4 $ D.fromChars (show someException)
1567+ , D.reflow $
1568+ "Is it possible that your internet connection intercepts certain requests? That\
1569+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1570+ \ and certain countries. Try asking for help locally or in a community forum!"
1571+ ]
1572+
1573+
1574+toRedirectDoc :: HTTP.Response body -> D.Doc
1575+toRedirectDoc response =
1576+ let
1577+ (HTTP.Status code message) = HTTP.responseStatus response
1578+ in
1579+ case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of
1580+ Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)
1581+ Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)
1582+
1583+
1584+
1585+-- MAKE
1586+
1587+
1588+data Make
1589+ = MakeNoOutline
1590+ | MakeCannotOptimizeAndDebug
1591+ | MakeBadDetails Details
1592+ | MakeAppNeedsFileNames
1593+ | MakePkgNeedsExposing
1594+ | MakeMultipleFilesIntoHtml
1595+ | MakeNoMain
1596+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1597+ | MakeCannotBuild BuildProblem
1598+ | MakeBadGenerate Generate
7221599
7231600
7241601makeToReport :: Make -> Help.Report
7251602makeToReport make =
7261603 case make of
727− MakeNeedsOutline ->
1604+ MakeNoOutline ->
7281605 Help.report "NO elm.json FILE" Nothing
7291606 "It looks like you are starting a new Elm project. Very exciting! Try running:"
7301607 [ D.indent 4 $ D.green $ "elm init"
@@ -745,27 +1622,344 @@ makeToReport make =
7451622 \ at once though! Pick just one of those flags and it should work!"
7461623 ]
7471624
748− MakeBlockedByDetailsProblem detailsProblem ->
749− detailsToReport detailsProblem
1625+ MakeBadDetails detailsProblem ->
1626+ toDetailsReport detailsProblem
7501627
7511628 MakeAppNeedsFileNames ->
7521629 Help.report "NO INPUT" Nothing
753− "What should I make though? I need a specific file like this:"
754− [ D.indent 4 $ D.green "elm make src/Main.elm"
755− , D.reflow
756− "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!"
7571638 ]
7581639
7591640 MakePkgNeedsExposing ->
760− 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+ ]
7611651
7621652 MakeMultipleFilesIntoHtml ->
763− 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+ ]
1671+
1672+ MakeNoMain ->
1673+ Help.report "NO MAIN" Nothing
1674+ (
1675+ "When producing an HTML file, I require that the given file has a `main` value.\
1676+ \ That way I have something to show on screen!"
1677+ )
1678+ [ D.reflow $
1679+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1680+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1681+ \ altogether."
1682+ , D.toSimpleNote $
1683+ "Adding a `main` value can be as brief as adding something like this:"
1684+ , D.vcat
1685+ [ D.fillSep [D.cyan "import","Html"]
1686+ , ""
1687+ , D.fillSep [D.green "main","="]
1688+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1689+ ]
1690+ , D.reflow $
1691+ "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\
1692+ \ looking through https://guide.elm-lang.org for more guidance on how to fill in\
1693+ \ the `main` value."
1694+ ]
1695+
1696+ MakeNonMainFilesIntoJavaScript m ms ->
1697+ case ms of
1698+ [] ->
1699+ Help.report "NO MAIN" Nothing
1700+ (
1701+ "When producing a JS file, I require that the given file has a `main` value. That\
1702+ \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\
1703+ \ resulting file!"
1704+ )
1705+ [ D.reflow $
1706+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1707+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1708+ \ altogether."
1709+ , D.toSimpleNote $
1710+ "Adding a `main` value can be as brief as adding something like this:"
1711+ , D.vcat
1712+ [ D.fillSep [D.cyan "import","Html"]
1713+ , ""
1714+ , D.fillSep [D.green "main","="]
1715+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1716+ ]
1717+ , D.reflow $
1718+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1719+ \ make a `main` with no user interface."
1720+ ]
1721+
1722+ _:_ ->
1723+ Help.report "NO MAIN" Nothing
1724+ (
1725+ "When producing a JS file, I require that given files all have `main` values.\
1726+ \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\
1727+ \ definitely defined in the resulting file. I am missing `main` values in:"
1728+ )
1729+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)
1730+ , D.reflow $
1731+ "Try adding a `main` value to them? Or if you just want to verify that these\
1732+ \ modules compile, switch to --output=/dev/null to skip the code gen phase\
1733+ \ altogether."
1734+ , D.toSimpleNote $
1735+ "Adding a `main` value can be as brief as adding something like this:"
1736+ , D.vcat
1737+ [ D.fillSep [D.cyan "import","Html"]
1738+ , ""
1739+ , D.fillSep [D.green "main","="]
1740+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1741+ ]
1742+ , D.reflow $
1743+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1744+ \ make a `main` with no user interface."
1745+ ]
1746+
1747+ MakeCannotBuild buildProblem ->
1748+ toBuildProblemReport buildProblem
1749+
1750+ MakeBadGenerate generateProblem ->
1751+ toGenerateReport generateProblem
1752+
1753+
1754+
1755+-- BUILD PROBLEM
1756+
1757+
1758+data BuildProblem
1759+ = BuildBadModules FilePath Error.Module [Error.Module]
1760+ | BuildProjectProblem BuildProjectProblem
1761+
1762+
1763+data BuildProjectProblem
1764+ = BP_PathUnknown FilePath
1765+ | BP_WithBadExtension FilePath
1766+ | BP_WithAmbiguousSrcDir FilePath FilePath FilePath
1767+ | BP_MainPathDuplicate FilePath FilePath
1768+ | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath
1769+ | BP_RootNameInvalid FilePath FilePath [String]
1770+ | BP_CannotLoadDependencies
1771+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]
1772+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
1773+
1774+
1775+toBuildProblemReport :: BuildProblem -> Help.Report
1776+toBuildProblemReport problem =
1777+ case problem of
1778+ BuildBadModules root e es ->
1779+ Help.compilerReport root e es
1780+
1781+ BuildProjectProblem projectProblem ->
1782+ toProjectProblemReport projectProblem
1783+
1784+
1785+toProjectProblemReport :: BuildProjectProblem -> Help.Report
1786+toProjectProblemReport projectProblem =
1787+ case projectProblem of
1788+ BP_PathUnknown path ->
1789+ Help.report "FILE NOT FOUND" Nothing
1790+ "I cannot find this file:"
1791+ [ D.indent 4 $ D.red $ D.fromChars path
1792+ , D.reflow $ "Is there a typo?"
1793+ , D.toSimpleNote $
1794+ "If you are just getting started, try working through the examples in the\
1795+ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\
1796+ \ that typically go in a src/Main.elm file."
1797+ ]
1798+
1799+ BP_WithBadExtension path ->
1800+ Help.report "UNEXPECTED FILE EXTENSION" Nothing
1801+ "I can only compile Elm files (with a .elm extension) but you want me to compile:"
1802+ [ D.indent 4 $ D.red $ D.fromChars path
1803+ , D.reflow $ "Is there a typo? Can the file extension be changed?"
1804+ ]
1805+
1806+ BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->
1807+ Help.report "CONFUSING FILE" Nothing
1808+ "I am getting confused when I try to compile this file:"
1809+ [ D.indent 4 $ D.red $ D.fromChars path
1810+ , D.reflow $
1811+ "I always check if files appear in any of the \"source-directories\" listed in\
1812+ \ your elm.json to see if there might be some cached information about them. That\
1813+ \ can help me compile faster! But in this case, it looks like this file may be in\
1814+ \ either of these directories:"
1815+ , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]
1816+ , D.reflow $
1817+ "Try to make it so no source directory contains another source directory!"
1818+ ]
1819+
1820+ BP_MainPathDuplicate path1 path2 ->
1821+ Help.report "CONFUSING FILES" Nothing
1822+ "You are telling me to compile these two files:"
1823+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]
1824+ , D.reflow $
1825+ if path1 == path2 then
1826+ "Why are you telling me twice? Is something weird going on with a script?\
1827+ \ I figured I would let you know about it just in case something is wrong.\
1828+ \ Only list it once and you should be all set!"
1829+ else
1830+ "But seem to be the same file though... It makes me think something tricky is\
1831+ \ going on with symlinks in your project, so I figured I would let you know\
1832+ \ about it just in case. Remove one of these files from your command to get\
1833+ \ unstuck!"
1834+ ]
1835+
1836+ BP_RootNameDuplicate name outsidePath otherPath ->
1837+ Help.report "MODULE NAME CLASH" Nothing
1838+ "These two files are causing a module name clash:"
1839+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]
1840+ , D.reflow $
1841+ "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\
1842+ \ at the top, but they cannot have the same name!"
1843+ , D.reflow $
1844+ "Try changing to a different module name in one of them!"
1845+ ]
1846+
1847+ BP_RootNameInvalid givenPath srcDir _ ->
1848+ Help.report "UNEXPECTED FILE NAME" Nothing
1849+ "I am having trouble with this file name:"
1850+ [ D.indent 4 $ D.red $ D.fromChars givenPath
1851+ , D.reflow $
1852+ "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\
1853+ \ which is good, but I expect all of the files in there to use the following\
1854+ \ module naming convention:"
1855+ , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]
1856+ , D.reflow $
1857+ "Notice that the names always start with capital letters! Can you make your file\
1858+ \ use this naming convention?"
1859+ , D.toSimpleNote $
1860+ "Having a strict naming convention like this makes it a lot easier to find\
1861+ \ things in large projects. If you see a module imported, you know where to look\
1862+ \ for the corresponding file every time!"
1863+ ]
1864+
1865+ BP_CannotLoadDependencies ->
1866+ corruptCacheReport
1867+
1868+ BP_Cycle name names ->
1869+ Help.report "IMPORT CYCLE" Nothing
1870+ "Your module imports form a cycle:"
1871+ [ D.cycle 4 name names
1872+ , D.reflow $
1873+ "Learn more about why this is disallowed and how to break cycles here:"
1874+ ++ D.makeLink "import-cycles"
1875+ ]
1876+
1877+ BP_MissingExposed (NE.List (name, problem) _) ->
1878+ case problem of
1879+ Import.NotFound ->
1880+ Help.report "MISSING MODULE" (Just "elm.json")
1881+ "The \"exposed-modules\" of your elm.json lists the following module:"
1882+ [ D.indent 4 $ D.red $ D.fromName name
1883+ , D.reflow $
1884+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1885+ ]
1886+
1887+ Import.Ambiguous _ _ pkg _ ->
1888+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1889+ "The \"exposed-modules\" of your elm.json lists the following module:"
1890+ [ D.indent 4 $ D.red $ D.fromName name
1891+ , D.reflow $
1892+ "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\
1893+ \ choosing a different name for your local file."
1894+ ]
1895+
1896+ Import.AmbiguousLocal path1 path2 paths ->
1897+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1898+ "The \"exposed-modules\" of your elm.json lists the following module:"
1899+ [ D.indent 4 $ D.red $ D.fromName name
1900+ , D.reflow $
1901+ "But I found multiple files with that name:"
1902+ , D.dullyellow $ D.indent 4 $ D.vcat $
1903+ map D.fromChars (path1:path2:paths)
1904+ , D.reflow $
1905+ "Change the module names to be distinct!"
1906+ ]
1907+
1908+ Import.AmbiguousForeign _ _ _ ->
1909+ Help.report "MISSING MODULE" (Just "elm.json")
1910+ "The \"exposed-modules\" of your elm.json lists the following module:"
1911+ [ D.indent 4 $ D.red $ D.fromName name
1912+ , D.reflow $
1913+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1914+ , D.toSimpleNote $
1915+ "It is not possible to \"re-export\" modules from other packages. You can only\
1916+ \ expose modules that you define in your own code."
1917+ ]
1918+
1919+
1920+toModuleNameConventionTable :: FilePath -> [String] -> D.Doc
1921+toModuleNameConventionTable srcDir names =
1922+ let
1923+ toPair name =
1924+ ( name
1925+ , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"
1926+ )
1927+
1928+ namePairs = map toPair names
1929+ nameWidth = maximum (11 : map (length . fst) namePairs)
1930+ pathWidth = maximum ( 9 : map (length . snd) namePairs)
1931+
1932+ padded width str =
1933+ str ++ replicate (width - length str) ' '
1934+
1935+ toRow (name, path) =
1936+ D.fromChars $
1937+ "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"
1938+
1939+ bar =
1940+ D.fromChars $
1941+ "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"
1942+ in
1943+ D.indent 4 $ D.vcat $
1944+ [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]
1945+
1946+
1947+
1948+-- GENERATE
1949+
1950+
1951+data Generate
1952+ = GenerateCannotLoadArtifacts
1953+ | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
1954+
7641955
765− MakeNonMainFilesIntoJavaScript _ _ ->
766− error "TODO MakeNonMainFilesIntoJavaScript"
1956+toGenerateReport :: Generate -> Help.Report
1957+toGenerateReport problem =
1958+ case problem of
1959+ GenerateCannotLoadArtifacts ->
1960+ corruptCacheReport
7671961
768− MakeCannotOptimizeDebugValues m ms ->
1962+ GenerateCannotOptimizeDebugValues m ms ->
7691963 Help.report "DEBUG REMNANTS" Nothing
7701964 "There are uses of the `Debug` module in the following modules:"
7711965 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
@@ -774,7 +1968,7 @@ makeToReport make =
7741968 "The issue is that --optimize strips out info needed by `Debug` functions.\
7751969 \ Here are two examples:"
7761970 , D.indent 4 $ D.reflow $
777− "(1) It shortens record field names. This makes the generated JavaScript is\
1971+ "(1) It shortens record field names. This makes the generated JavaScript\
7781972 \ smaller, but `Debug.toString` cannot know the real field names anymore."
7791973 , D.indent 4 $ D.reflow $
7801974 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
@@ -787,42 +1981,89 @@ makeToReport make =
7871981 \ exists!"
7881982 ]
7891983
790− MakeCannotBuild buildProblem ->
791− case buildProblem of
792− BuildProjectProblem bp ->
793− case bp of
794− BP_PathUnknown _ ->
795− error "TODO BP_PathUnknown"
7961984
797− BP_WithBadExtension _ ->
798− error "TODO BP_WithBadExtension"
7991985
800− BP_WithAmbiguousSrcDir _ _ ->
801− error "TODO BP_WithAmbiguousSrcDir"
1986+-- CORRUPT CACHE
8021987
803− BP_MainPathDuplicate _ _ ->
804− error "TODO BP_MainPathDuplicate"
8051988
806− BP_MainNameDuplicate _ _ _ ->
807− error "TODO BP_MainNameDuplicate"
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+ ]
8082000
809− BP_CannotLoadDependencies ->
810− error "TODO BP_CannotLoadDependencies"
8112001
812− BP_Cycle name names ->
813− Help.report "IMPORT CYCLE" Nothing
814− "Your module imports form a cycle:"
815− [ D.cycle 4 name names
816− , D.reflow $
817− "Learn more about why this is disallowed and how to break cycles here:"
818− ++ D.makeLink "import-cycles"
819− ]
8202002
821− BP_MissingExposed _ ->
822− error "TODO BP_MissingExposed"
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
8232064
824− BuildModuleProblems p ps ->
825− Help.compilerReport p ps
2065+ ReplBadCache ->
2066+ corruptCacheReport
8262067
827− MakeCannotLoadArtifacts ->
828− 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+9−10
@@ -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
@@ -30,7 +29,7 @@ import qualified Reporting.Error as Error
3029
3130
3231data Report
33− = CompilerReport Error.Module [Error.Module]
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 :: Error.Module -> [Error.Module] -> 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− Error.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"
99+ [ "type" ==> E.chars "compile-errors"
101100 , "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+10−9
@@ -56,13 +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
6160import qualified AST.Source as Src
6261import qualified AST.Utils.Binop as Binop
6362import qualified AST.Utils.Shader as Shader
6463import qualified Data.Index as Index
64+import qualified Elm.Float as EF
6565import qualified Elm.ModuleName as ModuleName
66+import qualified Elm.String as ES
6667import qualified Reporting.Annotation as A
6768
6869
@@ -83,10 +84,10 @@ data Expr_
8384 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
8485 | VarDebug ModuleName.Canonical Name Annotation
8586 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
86− | Chr Utf8.String
87− | Str Utf8.String
87+ | Chr ES.String
88+ | Str ES.String
8889 | Int Int
89− | Float (Utf8.Under256 Float)
90+ | Float EF.Float
9091 | List [Expr]
9192 | Negate Expr
9293 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
@@ -151,8 +152,8 @@ data Pattern_
151152 | PList [Pattern]
152153 | PCons Pattern Pattern
153154 | PBool Union Bool
154− | PChr Utf8.String
155− | PStr Utf8.String
155+ | PChr ES.String
156+ | PStr ES.String
156157 | PInt Int
157158 | PCtor
158159 { _p_home :: ModuleName.Canonical
@@ -232,7 +233,7 @@ data Module =
232233 Module
233234 { _name :: ModuleName.Canonical
234235 , _exports :: Exports
235− , _docs :: Maybe Src.Docs
236+ , _docs :: Src.Docs
236237 , _decls :: Decls
237238 , _unions :: Map.Map Name Union
238239 , _aliases :: Map.Map Name Alias
@@ -341,7 +342,7 @@ instance Binary CtorOpts where
341342 0 -> return Normal
342343 1 -> return Enum
343344 2 -> return Unbox
344− _ -> error "binary encoding of CtorOpts was corrupted"
345+ _ -> fail "binary encoding of CtorOpts was corrupted"
345346
346347
347348instance Binary Annotation where
@@ -392,7 +393,7 @@ instance Binary AliasType where
392393 case n of
393394 0 -> liftM Holey get
394395 1 -> liftM Filled get
395− _ -> error "binary encoding of AliasType was corrupted"
396+ _ -> fail "binary encoding of AliasType was corrupted"
396397
397398
398399instance 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+21−32
@@ -1,5 +1,4 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
32module AST.Source
43 ( Expr, Expr_(..), VarType(..)
54 , Def(..)
@@ -26,12 +25,13 @@ module AST.Source
2625
2726
2827import Data.Name (Name)
29−import qualified Data.Utf8 as Utf8
30−import Data.Word (Word8)
31−import Foreign.Ptr (Ptr)
28+import qualified Data.Name as Name
3229
3330import qualified AST.Utils.Binop as Binop
3431import 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
3535import qualified Reporting.Annotation as A
3636
3737
@@ -43,10 +43,10 @@ type Expr = A.Located Expr_
4343
4444
4545data Expr_
46− = Chr Utf8.String
47− | Str Utf8.String
46+ = Chr ES.String
47+ | Str ES.String
4848 | Int Int
49− | Float (Utf8.Under256 Float)
49+ | Float EF.Float
5050 | Var VarType Name
5151 | VarQual VarType Name Name
5252 | List [Expr]
@@ -97,8 +97,8 @@ data Pattern_
9797 | PCtorQual A.Region Name Name [Pattern]
9898 | PList [Pattern]
9999 | PCons Pattern Pattern
100− | PChr Utf8.String
101− | PStr Utf8.String
100+ | PChr ES.String
101+ | PStr ES.String
102102 | PInt Int
103103
104104
@@ -128,7 +128,7 @@ data Module =
128128 Module
129129 { _name :: Maybe (A.Located Name)
130130 , _exports :: A.Located Exposing
131− , _docs :: Maybe Docs
131+ , _docs :: Docs
132132 , _imports :: [Import]
133133 , _values :: [A.Located Value]
134134 , _unions :: [A.Located Union]
@@ -145,13 +145,7 @@ getName (Module maybeName _ _ _ _ _ _ _ _) =
145145 name
146146
147147 Nothing ->
148− defaultModuleName
149−
150−
151−{-# NOINLINE defaultModuleName #-}
152−defaultModuleName :: Name
153−defaultModuleName =
154− "Main"
148+ Name._Main
155149
156150
157151getImportName :: Import -> Name
@@ -186,18 +180,13 @@ data Manager
186180 | Fx (A.Located Name) (A.Located Name)
187181
188182
189−data Docs =
190− Docs
191− { _overview :: Comment
192− , _comments :: [(Name, Comment)]
193− }
183+data Docs
184+ = NoDocs A.Region
185+ | YesDocs Comment [(Name, Comment)]
194186
195187
196−data Comment =
197− Comment
198− { _start :: Ptr Word8
199− , _end :: Ptr Word8
200− }
188+newtype Comment =
189+ Comment P.Snippet
201190
202191
203192
@@ -206,15 +195,15 @@ data Comment =
206195
207196data Exposing
208197 = Open
209− | Explicit [A.Located Exposed]
198+ | Explicit [Exposed]
210199
211200
212201data Exposed
213− = Lower Name
214− | Upper Name Privacy
215− | Operator Name
202+ = Lower (A.Located Name)
203+ | Upper (A.Located Name) Privacy
204+ | Operator A.Region Name
216205
217206
218207data Privacy
219− = Public
208+ = Public A.Region
220209 | 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+5−5
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs
110110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112112 do arity <- checkUnionFreeVars union
113− let one = 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
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs
281281 )
282282
283283
284−type CtorDups = Dups.Dict (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+7−7
@@ -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/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+12−2
@@ -1,5 +1,6 @@
11module Data.NonEmptyList
22 ( List(..)
3+ , singleton
34 , toList
45 , sortBy
56 )
@@ -19,6 +20,11 @@ data List a =
1920 List a [a]
2021
2122
23+singleton :: a -> List a
24+singleton a =
25+ List a []
26+
27+
2228toList :: List a -> [a]
2329toList (List x xs) =
2430 x:xs
@@ -46,8 +52,12 @@ instance Foldable List where
4652-- SORT BY
4753
4854
49−sortBy :: (a -> a -> Ordering) -> List a -> List a
50−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
5161 case List.sortBy comparison xs of
5262 [] ->
5363 List x []
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+3−3
@@ -49,14 +49,14 @@ closed =
4949
5050typeOpen :: Name.Name -> Src.Exposing
5151typeOpen name =
52− 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) ]
5353
5454
5555typeClosed :: Name.Name -> Src.Exposing
5656typeClosed name =
57− Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
5858
5959
6060operator :: Name.Name -> Src.Exposing
6161operator op =
62− 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+3−3
@@ -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+203−93
@@ -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
84−
100+ Utf8.toChars author </> Utf8.toChars project
85101
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
100102
101− _ ->
102− Left BadStructure
103+toJsonString :: Name -> Json.String
104+toJsonString (Name author project) =
105+ Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]
103106
104107
105−data BadName
106− = BadStructure
107− | TooLong
108− | HasDoubleDash
109− | HasUnderscore
110− | HasDot
111− | HasUppercase
112− | HasDashEnd
113− | HasNonLowercaseStart
114108
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
@@ -190,28 +199,61 @@ linearAlgebra =
190199suggestions :: Map.Map Name.Name Name
191200suggestions =
192201 let
193− random = Name "elm" "random"
194− time = Name "elm" "time"
195− file = Name "elm" "file"
202+ random = toName elm "random"
203+ time = toName elm "time"
204+ file = toName elm "file"
196205 in
197206 Map.fromList
198− [ ("Browser", browser)
199− , ("File", file)
200− , ("File.Download", file)
201− , ("File.Select", file)
202− , ("Html", html)
203− , ("Html.Attributes", html)
204− , ("Html.Events", html)
205− , ("Http", http)
206− , ("Json.Decode", json)
207− , ("Json.Encode", json)
208− , ("Random", random)
209− , ("Time", time)
210− , ("Url.Parser", url)
211− , ("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
212221 ]
213222
214223
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+
215257
216258-- INSTANCES
217259
@@ -226,17 +268,13 @@ instance Eq Canonical where
226268 version1 == version2 && package1 == package2
227269
228270
229−instance Ord Name where
230− compare (Name author1 project1) (Name author2 project2) =
231− case compare project1 project2 of
232− LT -> LT
233− EQ -> compare author1 author2
234− GT -> GT
235271
272+-- BINARY
236273
237−instance Binary Name where
238− get = liftM2 Name get get
239− put (Name a b) = put a >> put b
274+
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
240278
241279
242280instance Binary Canonical where
@@ -248,17 +286,89 @@ instance Binary Canonical where
248286-- JSON
249287
250288
251−decoder :: Decode.Decoder BadName Name
289+decoder :: D.Decoder (Row, Col) Name
252290decoder =
253− do str <- Decode.string
254− case fromString str of
255− Right name ->
256− return name
257−
258− Left err ->
259− Decode.failure err
291+ D.customString parser (,)
260292
261293
262−encode :: Name -> Encode.Value
294+encode :: Name -> E.Value
263295encode name =
264− 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+3−3
@@ -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
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+3−3
@@ -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+4−4
@@ -80,7 +80,7 @@ valueDecl maybeDocs start =
8080 do word1 0x3A {-:-} E.DeclDefEquals
8181 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
8282 (tipe, _) <- specialize E.DeclDefType Type.expression
83− Space.checkFreshLine E.DeclDefFreshLineAfterType
83+ Space.checkFreshLine E.DeclDefNameRepeat
8484 defName <- chompMatchingName name
8585 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
8686 chompDefArgsAndBody maybeDocs start defName (Just tipe) []
@@ -109,14 +109,14 @@ chompMatchingName expectedName =
109109 let
110110 (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
111111 in
112− P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
112+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
113113 let
114− cokL name newState@(P.State _ _ _ er ec) =
114+ cokL name newState@(P.State _ _ _ _ er ec) =
115115 if expectedName == name
116116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
117117 else cerr sr sc (E.DeclDefNameMatch name)
118118
119− eokL name newState@(P.State _ _ _ er ec) =
119+ eokL name newState@(P.State _ _ _ _ er ec) =
120120 if expectedName == name
121121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
122122 else eerr sr sc (E.DeclDefNameMatch 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+51−43
@@ -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,38 +128,46 @@ 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.TupleIndentExpr1
132− [
133− do op <- Symbol.operator E.TupleIndentExpr1 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− do (entry, end) <-
142− specialize E.TupleExpr $
143− do negatedExpr@(A.At (A.Region _ end) _) <- term
144− Space.chomp E.Space
145− let exprStart = A.Position row (col + 2)
146− let expr = A.at exprStart end (Src.Negate negatedExpr)
147− chompExprEnd exprStart (State [] expr [] end)
148− Space.checkIndent end E.TupleIndentEnd
149− chompTupleEnd start entry []
150− ]
151− else
152− do word1 0x29 {-)-} E.TupleOperatorClose
153− addEnd start (Src.Op op)
154− ,
155− do word1 0x29 {-)-} E.TupleIndentExpr1
156− addEnd start Src.Unit
157− ,
158− do Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
159− (entry, end) <- specialize E.TupleExpr expression
160− Space.checkIndent end E.TupleIndentEnd
161− chompTupleEnd start entry []
162− ]
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+ ]
163171
164172
165173chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
@@ -267,14 +275,14 @@ chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr
267275chompExprEnd start (State ops expr args end) =
268276 oneOfWithFallback
269277 [ -- argument
270− do Space.checkIndent end E.IndentMoreExpr
278+ do Space.checkIndent end E.Start
271279 arg <- term
272280 newEnd <- getPosition
273281 Space.chomp E.Space
274282 chompExprEnd start (State ops expr (arg:args) newEnd)
275283
276284 , -- operator
277− do Space.checkIndent end E.IndentMoreExpr
285+ do Space.checkIndent end E.Start
278286 op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
279287 Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
280288 newStart <- getPosition
@@ -535,19 +543,19 @@ chompDefArgsAndBody start name tipe revArgs =
535543chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
536544chompMatchingName expectedName =
537545 let
538− (P.Parser parserL) = Var.lower (E.DefNameRepeat expectedName)
546+ (P.Parser parserL) = Var.lower E.DefNameRepeat
539547 in
540− P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
548+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
541549 let
542− cokL name newState@(P.State _ _ _ er ec) =
550+ cokL name newState@(P.State _ _ _ _ er ec) =
543551 if expectedName == name
544552 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
545− else cerr sr sc (E.DefNameMatch expectedName name)
553+ else cerr sr sc (E.DefNameMatch name)
546554
547− eokL name newState@(P.State _ _ _ er ec) =
555+ eokL name newState@(P.State _ _ _ _ er ec) =
548556 if expectedName == name
549557 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
550− else eerr sr sc (E.DefNameMatch expectedName name)
558+ else eerr sr sc (E.DefNameMatch name)
551559 in
552560 parserL state cokL eokL cerr eerr
553561
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+164−115
@@ -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,11 +31,34 @@ 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− case P.fromByteString (chompModule pkg) source of
36− P.Ok modul _ -> checkModule modul
37− P.Err err -> Left (E.ParseError 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)
39+
40+
41+
42+-- PROJECT TYPE
43+
44+
45+data ProjectType
46+ = Package Pkg.Name
47+ | Application
48+
49+
50+isCore :: ProjectType -> Bool
51+isCore projectType =
52+ case projectType of
53+ Package pkg -> pkg == Pkg.core
54+ Application -> False
55+
56+
57+isKernel :: ProjectType -> Bool
58+isKernel projectType =
59+ case projectType of
60+ Package pkg -> Pkg.isKernel pkg
61+ Application -> False
3862
3963
4064
@@ -44,69 +68,74 @@ fromByteString pkg source =
4468data Module =
4569 Module
4670 { _header :: Maybe Header
47− , _comment :: Maybe Src.Comment
4871 , _imports :: [Src.Import]
4972 , _infixes :: [A.Located Src.Infix]
5073 , _decls :: [Decl.Decl]
5174 }
5275
5376
54−chompModule :: Pkg.Name -> Parser E.Module Module
55−chompModule pkg =
56− do freshLine E.FreshLine
57− header <- chompHeader
58− comment <- chompModuleDocComment
59− imports <- chompImports (if pkg == Pkg.core then [] else Imports.defaults)
60− infixes <- if Pkg.isKernel pkg then chompInfixes [] else return []
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 []
6182 decls <- specialize E.Declarations $ chompDecls []
62− endOfFile
63− return (Module header comment imports infixes decls)
83+ return (Module header imports infixes decls)
6484
6585
6686
6787-- CHECK MODULE
6888
6989
70−checkModule :: Module -> Either E.Error Src.Module
71−checkModule (Module maybeHeader maybeComment imports infixes decls) =
90+checkModule :: ProjectType -> Module -> Either E.Error Src.Module
91+checkModule projectType (Module maybeHeader imports infixes decls) =
7292 let
7393 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
74−
75− docs =
76− case maybeComment of
77− Just c -> Just (Src.Docs c (getComments decls []))
78− Nothing -> Nothing
7994 in
8095 case maybeHeader of
81− Just (Header name effects exports) ->
82− Src.Module (Just name) exports docs imports values unions aliases infixes
83− <$> 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
8499
85100 Nothing ->
86101 Right $
87− Src.Module Nothing (A.At A.one Src.Open) docs imports values unions aliases infixes $
102+ Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $
88103 case ports of
89104 [] -> Src.NoEffects
90105 _:_ -> Src.Ports ports
91106
92107
93−checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects
94−checkEffects ports effects =
108+checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
109+checkEffects projectType ports effects =
95110 case effects of
96111 NoEffects region ->
97112 case ports of
98− [] -> Right Src.NoEffects
99− _:_ -> 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)
100120
101121 Ports region ->
102− case ports of
103− [] -> Left (E.NoPorts region)
104− _:_ -> 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)
105130
106131 Manager region manager ->
107− case ports of
108− [] -> Right (Src.Manager region manager)
109− _:_ -> 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+
110139
111140
112141categorizeDecls :: [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] )
@@ -123,6 +152,20 @@ categorizeDecls values unions aliases ports decls =
123152 Decl.Port _ port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls
124153
125154
155+
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+
126169getComments :: [Decl.Decl] -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]
127170getComments decls comments =
128171 case decls of
@@ -154,15 +197,6 @@ freshLine toFreshLineError =
154197 Space.checkFreshLine toFreshLineError
155198
156199
157−endOfFile :: Parser E.Module ()
158−endOfFile =
159− P.Parser $ \state@(P.State pos end _ row col) _ eok _ eerr ->
160− if pos < end then
161− eerr row col E.ModuleEndOfFile
162− else
163− eok () state
164−
165−
166200
167201-- CHOMP DECLARATIONS
168202
@@ -171,7 +205,7 @@ chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]
171205chompDecls decls =
172206 do (decl, _) <- Decl.declaration
173207 oneOfWithFallback
174− [ do Space.checkFreshLine E.DeclFreshLineStart
208+ [ do Space.checkFreshLine E.DeclStart
175209 chompDecls (decl:decls)
176210 ]
177211 (reverse (decl:decls))
@@ -190,16 +224,17 @@ chompInfixes infixes =
190224-- MODULE DOC COMMENT
191225
192226
193−chompModuleDocComment :: Parser E.Module (Maybe Src.Comment)
194−chompModuleDocComment =
195− oneOfWithFallback
196− [
197− do docComment <- Space.docComment E.ImportStart E.ModuleSpace
198− Space.chomp E.ModuleSpace
199− Space.checkFreshLine E.FreshLine
200− return (Just docComment)
201− ]
202− 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)
203238
204239
205240
@@ -207,7 +242,7 @@ chompModuleDocComment =
207242
208243
209244data Header =
210− 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)
211246
212247
213248data Effects
@@ -218,40 +253,43 @@ data Effects
218253
219254chompHeader :: Parser E.Module (Maybe Header)
220255chompHeader =
221− do start <- getPosition
256+ do freshLine E.FreshLine
257+ start <- getPosition
222258 oneOfWithFallback
223259 [
224260 -- module MyThing exposing (..)
225261 do Keyword.module_ E.ModuleProblem
226− end <- getPosition
262+ effectEnd <- getPosition
227263 Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
228264 name <- addLocation (Var.moduleName E.ModuleName)
229265 Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
230266 Keyword.exposing_ E.ModuleProblem
231267 Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
232268 exports <- addLocation (specialize E.ModuleExposing exposing)
233− freshLine E.FreshLine
234− return (Just (Header name (NoEffects (A.Region start end)) exports))
269+ comment <- chompModuleDocCommentSpace
270+ return $ Just $
271+ Header name (NoEffects (A.Region start effectEnd)) exports comment
235272 ,
236273 -- port module MyThing exposing (..)
237274 do Keyword.port_ E.PortModuleProblem
238275 Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
239276 Keyword.module_ E.PortModuleProblem
240− end <- getPosition
277+ effectEnd <- getPosition
241278 Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
242279 name <- addLocation (Var.moduleName E.PortModuleName)
243280 Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
244281 Keyword.exposing_ E.PortModuleProblem
245282 Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
246283 exports <- addLocation (specialize E.PortModuleExposing exposing)
247− freshLine E.FreshLine
248− return (Just (Header name (Ports (A.Region start end)) exports))
284+ comment <- chompModuleDocCommentSpace
285+ return $ Just $
286+ Header name (Ports (A.Region start effectEnd)) exports comment
249287 ,
250288 -- effect module MyThing where { command = MyCmd } exposing (..)
251289 do Keyword.effect_ E.Effect
252290 Space.chompAndCheckIndent E.ModuleSpace E.Effect
253291 Keyword.module_ E.Effect
254− end <- getPosition
292+ effectEnd <- getPosition
255293 Space.chompAndCheckIndent E.ModuleSpace E.Effect
256294 name <- addLocation (Var.moduleName E.ModuleName)
257295 Space.chompAndCheckIndent E.ModuleSpace E.Effect
@@ -262,8 +300,9 @@ chompHeader =
262300 Keyword.exposing_ E.Effect
263301 Space.chompAndCheckIndent E.ModuleSpace E.Effect
264302 exports <- addLocation (specialize (const E.Effect) exposing)
265− freshLine E.FreshLine
266− return (Just (Header name (Manager (A.Region start end) manager) exports))
303+ comment <- chompModuleDocCommentSpace
304+ return $ Just $
305+ Header name (Manager (A.Region start effectEnd) manager) exports comment
267306 ]
268307 -- default header
269308 Nothing
@@ -333,28 +372,33 @@ spaces_em =
333372
334373
335374chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
336−chompImports imports =
375+chompImports is =
337376 oneOfWithFallback
338− [ do Keyword.import_ E.ImportStart
339− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
340− name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
341− Space.chomp E.ModuleSpace
342− oneOf E.ImportEnd
343− [ do Space.checkFreshLine E.ImportEnd
344− chompImports $
345− Src.Import name Nothing (Src.Explicit []) : imports
346− , do Space.checkIndent end E.ImportEnd
347− oneOf E.ImportAs
348− [ chompAs name imports
349− , chompExposing name Nothing imports
350− ]
351− ]
377+ [ do i <- chompImport
378+ chompImports (i:is)
352379 ]
353− (reverse imports)
380+ (reverse is)
354381
355382
356−chompAs :: A.Located Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
357−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 =
358402 do Keyword.as_ E.ImportAs
359403 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
360404 alias <- Var.upper E.ImportAlias
@@ -362,21 +406,19 @@ chompAs name imports =
362406 Space.chomp E.ModuleSpace
363407 oneOf E.ImportEnd
364408 [ do Space.checkFreshLine E.ImportEnd
365− chompImports $
366− Src.Import name (Just alias) (Src.Explicit []) : imports
409+ return $ Src.Import name (Just alias) (Src.Explicit [])
367410 , do Space.checkIndent end E.ImportEnd
368− chompExposing name (Just alias) imports
411+ chompExposing name (Just alias)
369412 ]
370413
371414
372−chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
373−chompExposing name maybeAlias imports =
415+chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import
416+chompExposing name maybeAlias =
374417 do Keyword.exposing_ E.ImportExposing
375418 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
376419 exposed <- specialize E.ImportExposingList exposing
377420 freshLine E.ImportEnd
378− chompImports $
379− Src.Import name maybeAlias exposed : imports
421+ return $ Src.Import name maybeAlias exposed
380422
381423
382424
@@ -387,24 +429,24 @@ exposing :: Parser E.Exposing Src.Exposing
387429exposing =
388430 do word1 0x28 {-(-} E.ExposingStart
389431 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
390− oneOf E.ExposingIndentValue
391− [ do word2 0x2E 0x2E {-..-} E.ExposingIndentValue
432+ oneOf E.ExposingValue
433+ [ do word2 0x2E 0x2E {-..-} E.ExposingValue
392434 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
393435 word1 0x29 {-)-} E.ExposingEnd
394436 return Src.Open
395− , do exposed <- addLocation chompExposed
437+ , do exposed <- chompExposed
396438 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
397439 exposingHelp [exposed]
398440 ]
399441
400442
401−exposingHelp :: [A.Located Src.Exposed] -> Parser E.Exposing Src.Exposing
443+exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing
402444exposingHelp revExposed =
403445 oneOf E.ExposingEnd
404446 [ do word1 0x2C {-,-} E.ExposingEnd
405447 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
406− exposed <- addLocation chompExposed
407− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValueEnd
448+ exposed <- chompExposed
449+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
408450 exposingHelp (exposed:revExposed)
409451 , do word1 0x29 {-)-} E.ExposingEnd
410452 return (Src.Explicit (reverse revExposed))
@@ -413,26 +455,33 @@ exposingHelp revExposed =
413455
414456chompExposed :: Parser E.Exposing Src.Exposed
415457chompExposed =
416− oneOf E.ExposingValue
417− [ Src.Lower <$> Var.lower E.ExposingValue
418− , do word1 0x28 {-(-} E.ExposingValue
419− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
420− word1 0x29 {-)-} E.ExposingOperatorRightParen
421− return (Src.Operator op)
422− , do name <- Var.upper E.ExposingValue
423− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacy
424− Src.Upper name <$> privacy
425− ]
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+ ]
426473
427474
428475privacy :: Parser E.Exposing Src.Privacy
429476privacy =
430477 oneOfWithFallback
431478 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
432− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyDots
433− word2 0x2E 0x2E {-..-} E.ExposingTypePrivacyDots
434− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyEnd
435− word1 0x29 {-)-} E.ExposingTypePrivacyEnd
436− 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)
437486 ]
438487 Src.Private
compiler/src/Parse/Number.hs+8−8
@@ -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
@@ -290,7 +290,7 @@ stepHex pos end word acc
290290
291291precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence
292292precedence toExpectation =
293− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
293+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
294294 if pos >= end then
295295 eerr row col toExpectation
296296
@@ -299,7 +299,7 @@ precedence toExpectation =
299299 if isDecimalDigit word then
300300 cok
301301 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
302− (P.State (plusPtr pos 1) end indent row (col + 1))
302+ (P.State src (plusPtr pos 1) end indent row (col + 1))
303303
304304 else
305305 eerr row col toExpectation
compiler/src/Parse/Pattern.hs+25−22
@@ -16,7 +16,7 @@ import qualified AST.Source as Src
1616import qualified Parse.Keyword as Keyword
1717import qualified Parse.Number as Number
1818import qualified Parse.Space as Space
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)
@@ -67,13 +67,16 @@ 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
@@ -84,7 +87,7 @@ termHelp start =
8487
8588wildcard :: Parser E.Pattern ()
8689wildcard =
87− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
90+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
8891 if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
8992 eerr row col E.PStart
9093 else
@@ -93,10 +96,10 @@ wildcard =
9396 !newCol = col + 1
9497 in
9598 if Var.getInnerWidth newPos end > 0 then
96− let (# _, badCol #) = Var.chompInnerChars newPos end newCol in
97− cerr row col (E.PWildcardNotVar (fromIntegral (badCol - col)))
99+ let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in
100+ cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col)))
98101 else
99− let !newState = P.State newPos end indent row newCol in
102+ let !newState = P.State src newPos end indent row newCol in
100103 cok () newState
101104
102105
@@ -126,7 +129,7 @@ recordHelp start vars =
126129 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
127130 recordHelp start (var:vars)
128131 , do word1 0x7D {-}-} E.PRecordEnd
129− addEnd start (Src.PRecord vars)
132+ addEnd start (Src.PRecord (reverse vars))
130133 ]
131134
132135
@@ -137,7 +140,7 @@ recordHelp start vars =
137140tuple :: A.Position -> Parser E.Pattern Src.Pattern
138141tuple start =
139142 inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
140− do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentOpen
143+ do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1
141144 oneOf E.PTupleOpen
142145 [ do (pattern, end) <- P.specialize E.PTupleExpr expression
143146 Space.checkIndent end E.PTupleIndentEnd
@@ -151,7 +154,7 @@ tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.P
151154tupleHelp start firstPattern revPatterns =
152155 oneOf E.PTupleEnd
153156 [ do word1 0x2C {-,-} E.PTupleEnd
154− Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr
157+ Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN
155158 (pattern, end) <- P.specialize E.PTupleExpr expression
156159 Space.checkIndent end E.PTupleIndentEnd
157160 tupleHelp start firstPattern (pattern : revPatterns)
@@ -202,18 +205,18 @@ listHelp start patterns =
202205expression :: Space.Parser E.Pattern Src.Pattern
203206expression =
204207 do start <- getPosition
205− cTerm <- exprTerm
206− exprHelp start [] cTerm
208+ ePart <- exprPart
209+ exprHelp start [] ePart
207210
208211
209212exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
210−exprHelp start patterns (pattern, end) =
213+exprHelp start revPatterns (pattern, end) =
211214 oneOfWithFallback
212215 [ do Space.checkIndent end E.PIndentStart
213216 word2 0x3A 0x3A {-::-} E.PStart
214217 Space.chompAndCheckIndent E.PSpace E.PIndentStart
215− cTerm <- exprTerm
216− exprHelp start (pattern:patterns) cTerm
218+ ePart <- exprPart
219+ exprHelp start (pattern:revPatterns) ePart
217220 , do Space.checkIndent end E.PIndentStart
218221 Keyword.as_ E.PStart
219222 Space.chompAndCheckIndent E.PSpace E.PIndentAlias
@@ -223,11 +226,11 @@ exprHelp start patterns (pattern, end) =
223226 Space.chomp E.PSpace
224227 let alias = A.at nameStart newEnd name
225228 return
226− ( 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)
227230 , newEnd
228231 )
229232 ]
230− ( List.foldl' cons pattern patterns
233+ ( List.foldl' cons pattern revPatterns
231234 , end
232235 )
233236
@@ -238,11 +241,11 @@ cons tl hd =
238241
239242
240243
241−-- EXPRESSION TERM
244+-- EXPRESSION PART
242245
243246
244−exprTerm :: Space.Parser E.Pattern Src.Pattern
245−exprTerm =
247+exprPart :: Space.Parser E.Pattern Src.Pattern
248+exprPart =
246249 oneOf E.PStart
247250 [
248251 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+18−17
@@ -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
@@ -63,11 +63,12 @@ parseBlock =
6363 case status of
6464 Good ->
6565 let
66− !block = Utf8.fromPtr pos6 newPos
67− !source = Utf8.toChars block
68− !newState = P.State (plusPtr newPos 2) end indent newRow (newCol + 2)
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
@@ -95,7 +96,7 @@ eatShader pos end row col =
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+22−16
@@ -16,7 +16,8 @@ module Parse.Space
1616
1717
1818import Data.Word (Word8, Word16)
19−import Foreign.Ptr (Ptr, plusPtr)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
2021
2122import qualified AST.Source as Src
2223import Parse.Primitives (Row, Col)
@@ -39,14 +40,14 @@ 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
@@ -60,7 +61,7 @@ chomp toError =
6061
6162checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x ()
6263checkIndent (A.Position endRow endCol) toError =
63− P.Parser $ \state@(P.State _ _ indent _ col) _ eok _ eerr ->
64+ P.Parser $ \state@(P.State _ _ _ indent _ col) _ eok _ eerr ->
6465 if col > indent && col > 1
6566 then eok () state
6667 else eerr endRow endCol toError
@@ -68,7 +69,7 @@ checkIndent (A.Position endRow endCol) toError =
6869
6970checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x ()
7071checkAligned toError =
71− P.Parser $ \state@(P.State _ _ indent row col) _ eok _ eerr ->
72+ P.Parser $ \state@(P.State _ _ _ indent row col) _ eok _ eerr ->
7273 if col == indent
7374 then eok () state
7475 else eerr row col (toError indent)
@@ -76,7 +77,7 @@ checkAligned toError =
7677
7778checkFreshLine :: (Row -> Col -> x) -> P.Parser x ()
7879checkFreshLine toError =
79− P.Parser $ \state@(P.State _ _ _ row col) _ eok _ eerr ->
80+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
8081 if col == 1
8182 then eok () state
8283 else eerr row col toError
@@ -88,7 +89,7 @@ checkFreshLine toError =
8889
8990chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x ()
9091chompAndCheckIndent toSpaceError toIndentError =
91− P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
92+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
9293 let
9394 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
9495 in
@@ -98,7 +99,7 @@ chompAndCheckIndent toSpaceError toIndentError =
9899 then
99100
100101 let
101− !newState = P.State newPos end indent newRow newCol
102+ !newState = P.State src newPos end indent newRow newCol
102103 in
103104 cok () newState
104105
@@ -156,7 +157,7 @@ eatSpaces pos end row col =
156157-- LINE COMMENTS
157158
158159
159−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 #)
160161eatLineComment pos end row col =
161162 if pos >= end then
162163 (# Good, pos, row, col #)
@@ -166,7 +167,7 @@ eatLineComment pos end row col =
166167 if word == 0x0A {- \n -} then
167168 eatSpaces (plusPtr pos 1) end (row + 1) 1
168169 else
169− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
170+ let !newPos = plusPtr pos (P.getCharWidth word) in
170171 eatLineComment newPos end row (col + 1)
171172
172173
@@ -207,7 +208,7 @@ data MultiStatus
207208 | MultiEndless
208209
209210
210−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 #)
211212eatMultiCommentHelp pos end row col openComments =
212213 if pos >= end then
213214 (# MultiEndless, pos, row, col #)
@@ -230,7 +231,7 @@ eatMultiCommentHelp pos end row col openComments =
230231 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
231232
232233 else
233− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
234+ let !newPos = plusPtr pos (P.getCharWidth word) in
234235 eatMultiCommentHelp newPos end row (col + 1) openComments
235236
236237
@@ -240,7 +241,7 @@ eatMultiCommentHelp pos end row col openComments =
240241
241242docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment
242243docComment toExpectation toSpaceError =
243− 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 ->
244245 let
245246 !pos3 = plusPtr pos 3
246247 in
@@ -250,14 +251,19 @@ docComment toExpectation toSpaceError =
250251 && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
251252 then
252253 let
254+ !col3 = col + 3
255+
253256 (# status, newPos, newRow, newCol #) =
254− eatMultiCommentHelp pos3 end row (col + 3) 1
257+ eatMultiCommentHelp pos3 end row col3 1
255258 in
256259 case status of
257260 MultiGood ->
258261 let
259− !comment = Src.Comment pos3 (plusPtr newPos (-2))
260− !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
261267 in
262268 cok comment newState
263269
compiler/src/Parse/Utf8.hs → compiler/src/Parse/String.hsrenamed+37−36
@@ -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,9 +22,9 @@ 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
@@ -34,8 +35,8 @@ character toExpectation toError =
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
@@ -47,12 +48,12 @@ character toExpectation toError =
4748
4849
4950data CharResult
50− = Good (Ptr Word8) Col Word16 Utf8.Chunk
51+ = Good (Ptr Word8) Col Word16 ES.Chunk
5152 | CharEndless Col
5253 | CharEscape Row Col E.Escape
5354
5455
55−chompChar :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> Utf8.Chunk -> CharResult
56+chompChar :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> ES.Chunk -> CharResult
5657chompChar pos end row col numChars mostRecent =
5758 if pos >= end then
5859 CharEndless col
@@ -73,10 +74,10 @@ chompChar pos end row col numChars mostRecent =
7374 else if word == 0x5C {- \ -} then
7475 case eatEscape (plusPtr pos 1) end row col of
7576 EscapeNormal ->
76− chompChar (plusPtr pos 2) end row (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 row (col + fromIntegral delta) (numChars + 1) (Utf8.CodePoint code)
80+ chompChar (plusPtr pos delta) end row (col + fromIntegral delta) (numChars + 1) (ES.CodePoint code)
8081
8182 EscapeProblem r c badEscape ->
8283 CharEscape r c badEscape
@@ -86,19 +87,19 @@ chompChar pos end row col numChars mostRecent =
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 row (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
@@ -193,7 +194,7 @@ singleString pos end row col initialPos revChunks =
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
198199 EscapeProblem r c x ->
199200 Err r c (E.StringEscape x)
@@ -202,7 +203,7 @@ singleString pos end row col initialPos revChunks =
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
@@ -244,7 +245,7 @@ multiString pos end row col initialPos sr sc revChunks =
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
249250 EscapeProblem r c x ->
250251 Err r c (E.StringEscape x)
@@ -253,7 +254,7 @@ multiString pos end row col initialPos sr sc revChunks =
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
@@ -313,30 +314,30 @@ eatUnicode pos end row col =
313314
314315
315316{-# NOINLINE singleQuote #-}
316−singleQuote :: Utf8.Chunk
317+singleQuote :: ES.Chunk
317318singleQuote =
318− Utf8.Escape 0x27 {- ' -}
319+ ES.Escape 0x27 {-'-}
319320
320321
321322{-# NOINLINE doubleQuote #-}
322−doubleQuote :: Utf8.Chunk
323+doubleQuote :: ES.Chunk
323324doubleQuote =
324− Utf8.Escape 0x22 {- " -}
325+ ES.Escape 0x22 {-"-}
325326
326327
327328{-# NOINLINE newline #-}
328−newline :: Utf8.Chunk
329+newline :: ES.Chunk
329330newline =
330− Utf8.Escape 0x6E {- n -}
331+ ES.Escape 0x6E {-n-}
331332
332333
333334{-# NOINLINE carriageReturn #-}
334−carriageReturn :: Utf8.Chunk
335+carriageReturn :: ES.Chunk
335336carriageReturn =
336− Utf8.Escape 0x72 {- \r -}
337+ ES.Escape 0x72 {-r-}
337338
338339
339340{-# NOINLINE placeholder #-}
340−placeholder :: Utf8.Chunk
341+placeholder :: ES.Chunk
341342placeholder =
342− Utf8.CodePoint 0xFFFD {- replacement character -}
343+ ES.CodePoint 0xFFFD {-replacement character-}
compiler/src/Parse/Symbol.hs+3−3
@@ -33,14 +33,14 @@ data BadOperator
3333
3434operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name
3535operator toExpectation toError =
36− 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 ->
3737 let !newPos = chompOps pos end in
3838 if pos == newPos then
3939 eerr row col toExpectation
4040
4141 else
4242 case Name.fromPtr pos newPos of
43− "." -> cerr row col (toError BadDot)
43+ "." -> eerr row col (toError BadDot)
4444 "|" -> cerr row col (toError BadPipe)
4545 "->" -> cerr row col (toError BadArrow)
4646 "=" -> cerr row col (toError BadEquals)
@@ -48,7 +48,7 @@ operator toExpectation toError =
4848 op ->
4949 let
5050 !newCol = col + fromIntegral (minusPtr newPos pos)
51− !newState = P.State newPos end indent row newCol
51+ !newState = P.State src newPos end indent row newCol
5252 in
5353 cok op newState
5454
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+15−14
@@ -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,6 +8,7 @@ module Parse.Variable
88 , foreignUpper
99 , foreignAlpha
1010 , chompInnerChars
11+ , getUpperWidth
1112 , getInnerWidth
1213 , getInnerWidthHelp
1314 , reservedWords
@@ -34,13 +35,13 @@ import qualified Parse.Primitives as P
3435
3536upper :: (Row -> Col -> x) -> Parser x Name.Name
3637upper toError =
37− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
38+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
3839 let (# newPos, newCol #) = chompUpper pos end col in
3940 if pos == newPos then
4041 eerr row col toError
4142 else
4243 let !name = Name.fromPtr pos newPos in
43− cok name (P.State newPos end indent row newCol)
44+ cok name (P.State src newPos end indent row newCol)
4445
4546
4647
@@ -49,7 +50,7 @@ upper toError =
4950
5051lower :: (Row -> Col -> x) -> Parser x Name.Name
5152lower toError =
52− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
53+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
5354 let (# newPos, newCol #) = chompLower pos end col in
5455 if pos == newPos then
5556 eerr row col toError
@@ -60,13 +61,13 @@ lower toError =
6061 else
6162 let
6263 !newState =
63− P.State newPos end indent row newCol
64+ P.State src newPos end indent row newCol
6465 in
6566 cok name newState
6667
6768
6869{-# NOINLINE reservedWords #-}
69−reservedWords :: Set.Set Name.Name -- TODO try using a trie instead
70+reservedWords :: Set.Set Name.Name -- PERF try using a trie instead
7071reservedWords =
7172 Set.fromList
7273 [ "if", "then", "else"
@@ -86,7 +87,7 @@ reservedWords =
8687
8788moduleName :: (Row -> Col -> x) -> Parser x Name.Name
8889moduleName toError =
89− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
90+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
9091 let
9192 (# pos1, col1 #) = chompUpper pos end col
9293 in
@@ -100,7 +101,7 @@ moduleName toError =
100101 Good ->
101102 let
102103 !name = Name.fromPtr pos newPos
103− !newState = P.State newPos end indent row newCol
104+ !newState = P.State src newPos end indent row newCol
104105 in
105106 cok name newState
106107
@@ -140,22 +141,22 @@ data Upper
140141
141142foreignUpper :: (Row -> Col -> x) -> Parser x Upper
142143foreignUpper toError =
143− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
144+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
144145 let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
145146 if upperStart == upperEnd then
146147 eerr row newCol toError
147148 else
148149 let
149− !newState = P.State upperEnd end indent row newCol
150+ !newState = P.State src upperEnd end indent row newCol
150151 !name = Name.fromPtr upperStart upperEnd
151− !foreign =
152+ !upperName =
152153 if upperStart == pos then
153154 Unqualified name
154155 else
155156 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
156157 Qualified home name
157158 in
158− cok foreign newState
159+ cok upperName newState
159160
160161
161162foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
@@ -179,13 +180,13 @@ foreignUpperHelp pos end col =
179180
180181foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_
181182foreignAlpha toError =
182− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
183+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
183184 let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
184185 if alphaStart == alphaEnd then
185186 eerr row newCol toError
186187 else
187188 let
188− !newState = P.State alphaEnd end indent row newCol
189+ !newState = P.State src alphaEnd end indent row newCol
189190 !name = Name.fromPtr alphaStart alphaEnd
190191 in
191192 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+32−26
@@ -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,32 +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 :: Module -> [Module] -> D.Doc
93−toDoc err errs =
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 (NE.List err errs)
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
106109 ,""
107110 ]
108111
109112 module2 : otherModules ->
110− moduleToDoc module1
113+ moduleToDoc root module1
111114 : toSeparator module1 module2
112− : toDocHelp module2 otherModules
115+ : toDocHelp root module2 otherModules
113116
114117
115118toSeparator :: Module -> Module -> D.Doc
@@ -131,19 +134,22 @@ toSeparator beforeModule afterModule =
131134-- MODULE TO DOC
132135
133136
134−moduleToDoc :: Module -> D.Doc
135−moduleToDoc (Module _ path _ source err) =
137+moduleToDoc :: FilePath -> Module -> D.Doc
138+moduleToDoc root (Module _ absolutePath _ source err) =
136139 let
137140 reports =
138141 toReports (Code.toSource source) err
142+
143+ relativePath =
144+ FP.makeRelative root absolutePath
139145 in
140− D.vcat $ map (reportToDoc path) (NE.toList reports)
146+ D.vcat $ map (reportToDoc relativePath) (NE.toList reports)
141147
142148
143149reportToDoc :: FilePath -> Report.Report -> D.Doc
144−reportToDoc path (Report.Report title _ _ message) =
150+reportToDoc relativePath (Report.Report title _ _ message) =
145151 D.vcat
146− [ toMessageBar title path
152+ [ toMessageBar title relativePath
147153 , ""
148154 , message
149155 , ""
@@ -173,8 +179,8 @@ toJson (Module name path _ source err) =
173179 toReports (Code.toSource source) err
174180 in
175181 E.object
176− [ "path" ==> E.string (Utf8.fromChars path)
177− , "name" ==> E.string (Name.toUtf8 name)
182+ [ "path" ==> E.chars path
183+ , "name" ==> E.name name
178184 , "problems" ==> E.array (map reportToJson (NE.toList reports))
179185 ]
180186
@@ -182,7 +188,7 @@ toJson (Module name path _ source err) =
182188reportToJson :: Report.Report -> E.Value
183189reportToJson (Report.Report title region _sgstns message) =
184190 E.object
185− [ "title" ==> E.string (Utf8.fromChars title)
191+ [ "title" ==> E.chars title
186192 , "region" ==> encodeRegion region
187193 , "message" ==> D.encode message
188194 ]
@@ -193,12 +199,12 @@ encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
193199 E.object
194200 [ "start" ==>
195201 E.object
196− [ ("line", E.int (fromIntegral sr))
197− , ("column", E.int (fromIntegral sc))
202+ [ "line" ==> E.int (fromIntegral sr)
203+ , "column" ==> E.int (fromIntegral sc)
198204 ]
199205 , "end" ==>
200206 E.object
201− [ ("line", E.int (fromIntegral er))
202− , ("column", E.int (fromIntegral ec))
207+ [ "line" ==> E.int (fromIntegral er)
208+ , "column" ==> E.int (fromIntegral ec)
203209 ]
204210 ]
compiler/src/Reporting/Error/Canonicalize.hs+41−40
@@ -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
@@ -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
@@ -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 $
@@ -274,7 +276,7 @@ toReport source err =
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 ->
@@ -342,7 +344,7 @@ toReport source err =
342344 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 $
@@ -355,12 +357,12 @@ toReport source err =
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 )
@@ -386,13 +388,8 @@ toReport source err =
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 ->
@@ -522,7 +519,7 @@ toReport source err =
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 ->
@@ -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!"
@@ -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!"
@@ -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 [] $
985985 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"
compiler/src/Reporting/Error/Docs.hs+127−18
@@ -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,9 +86,83 @@ 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+
101+
102+
103+-- SYNTAX PROBLEM
104+
63105
64− Duplicate name r1 r2 ->
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 [] $
66167 Code.toPair source r1 r2
67168 (
@@ -81,7 +182,7 @@ toReport source err =
81182 "Remove one of them!"
82183 )
83184
84− OnlyInDocs name region ->
185+ NameOnlyInDocs name region ->
85186 Report.Report "DOCS MISTAKE" region [] $
86187 Code.toSnippet source region Nothing
87188 (
@@ -94,7 +195,7 @@ 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 [] $
99200 Code.toSnippet source region Nothing
100201 (
@@ -110,6 +211,14 @@ 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 [] $
115224 Code.toSnippet source region Nothing
compiler/src/Reporting/Error/Import.hs+1−1
@@ -56,7 +56,7 @@ toReport source (Error region name unimportedModules problem) =
5656 D.stack
5757 [
5858 D.reflow $
59− "I checked the \"dependencies\" and \"source-directories\" listend in your elm.json,\
59+ "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json,\
6060 \ but I cannot find it! Maybe it is a typo for one of these names?"
6161 ,
6262 D.dullyellow $ D.indent 4 $ D.vcat $
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/Pattern.hs+5−4
@@ -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
@@ -40,7 +41,7 @@ toReport source err =
4041 Report.Report "UNSAFE PATTERN" region [] $
4142 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:"
@@ -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\
@@ -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+4388−1325

This diff is too big to show here.

compiler/src/Reporting/Error/Type.hs+44−23

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hs+70−43

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+5−25

This diff is too big to show here.

compiler/src/Reporting/Result.hs+10

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+31−12

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/elm+42−16

This diff is too big to show here.

installers/npm/download.js+68−67

This diff is too big to show here.

installers/npm/install.js+1−7

This diff is too big to show here.

installers/npm/package.json+6−7

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.cabal+25−3

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.hs+36−241

This diff is too big to show here.