on 3306a50 help sign in
.github/CONTRIBUTING.md+20−18
since splitsnapshots
unifiedsplit
@@ -4,15 +4,10 @@ Thanks helping with the development of Elm! This document describes the basic
4standards for opening pull requests and making the review process as smooth as
4standards for opening pull requests and making the review process as smooth as
5possible.
5possible.
6
6
7+## Licensing
7
8
8−## Expectations
9+You need to sign the [contributor agreement](ContributorAgreement.pdf)
9−
10+and send it to <info@elm-lang.org> before opening your pull request.
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−
16
11
17## Style Guide
12## Style Guide
18
13
@@ -22,20 +17,27 @@ Finally, please be patient with the core team. They are trying their best with l
22[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be
17[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be
23[js]: https://google.github.io/styleguide/javascriptguide.xml
18[js]: https://google.github.io/styleguide/javascriptguide.xml
24
19
25−
26## Branches
20## Branches
27
21
28−[The master branch][master] is the home of the next release of the compiler
22+ * [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
23+ so new features and improvements get merged there. Most pull requests
30−should target this branch!
24+ should target this branch!
31−
32−[master]: http://github.com/elm-lang/elm/tree/master
33
25
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.
34
29
35−## Licensing
30+[master]: http://github.com/elm-lang/elm/tree/master
36−
31+[stable]: http://github.com/elm-lang/elm/tree/stable
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
32
39−> Whenever you add Content to a repository containing notice of a license, you license that Content under the same terms, and you agree that you have the right to license that Content under those terms. If you have a separate agreement to license that Content under different terms, such as a contributor license agreement, that agreement will supersede.
33+If you are working on a fairly large feature, we will probably want to merge it
34+in as its own branch and do some testing before bringing it into the master
35+branch. This way we can keep releases of the master branch independent of new
36+features.
40
37
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.
41
42
43+[website]: https://github.com/elm-lang/elm-lang.org
.github/PULL_REQUEST_TEMPLATE.mddeleted−18
@@ -1,18 +0,0 @@
1−
2−**Quick Summary:** ???
3−
4−
5−## SSCCE
6−
7−```elm
8−
9−```
10−
11−- **Elm:** ???
12−- **Browser:** ???
13−- **Operating System:** ???
14−
15−
16−## Additional Details
17−
18−???
.github/workflows/set-issue-expectations.ymldeleted−21
@@ -1,21 +0,0 @@
1−name: Set Issue Expectations
2−on:
3− issues:
4− types: [opened]
5−jobs:
6− comment-on-issue:
7− name: Comment On Issue
8− runs-on: ubuntu-latest
9− steps:
10− - uses: actions/github@v1.0.0
11− env:
12− GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
13− with:
14− args: |
15− comment "Thanks for reporting this! To set expectations:
16−
17− - Issues are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
18− - Ask questions in a [community forum](https://elm-lang.org/community). You will get an answer quicker that way!
19− - If you experience something similar, open a new issue. [We like duplicates](https://github.com/elm/expectations/blob/master/duplicates.md).
20−
21− Finally, please be patient with the core team. They are trying their best with limited resources."
.github/workflows/set-pull-expectations.ymldeleted−19
@@ -1,19 +0,0 @@
1−on:
2− pull_request_target:
3− types: [opened]
4−
5−jobs:
6− comment-on-pull:
7− name: Comment On Pull
8− runs-on: ubuntu-latest
9− steps:
10− - uses: actions/github-script@v3
11− with:
12− github-token: ${{secrets.GITHUB_TOKEN}}
13− script: |
14− github.issues.createComment({
15− issue_number: context.issue.number,
16− owner: context.repo.owner,
17− repo: context.repo.repo,
18− body: "Thanks for suggesting these code changes. To set expectations:\n\n- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.\n- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).\n- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.\n\nFinally, please be patient with the core team. They are trying their best with limited resources."
19− })
.gitignore−1
@@ -5,4 +5,3 @@ cabal-dev
5cabal.sandbox.config
5cabal.sandbox.config
6.DS_Store
6.DS_Store
7*~
7*~
8−travis.log
.travis.ymldeleted−28
@@ -1,28 +0,0 @@
1−language: minimal
2−services: docker
3−
4−env:
5− global:
6− - LINUX_ARCHIVE=binary-for-linux-64-bit.gz
7−
8−before_install:
9− - docker build -t elm -f installers/linux/Dockerfile .
10− - docker cp $(docker create elm):/usr/local/bin/elm .
11− - gzip -9 -c elm > $LINUX_ARCHIVE
12−
13−deploy:
14− provider: releases
15− api_key:
16− secure: Yz2Lo4u9rZQ7Ee7ohAsrZpkqsYDUerCSMdSQIH8ryrf7phHhiloPEkTKsM+NupHqU/LEAVsunxbau4QrCEjA2vPavAPVk8cKomRUWK/YjbXHKa24hPkal2c+A2bnMQ6w3qYk/PjL9rW+Goq++/SNLcYZwHBV0Chl2blivMwWCSA=
17− file: $LINUX_ARCHIVE
18− skip_cleanup: true
19− on:
20− branch: master
21− tags: true
22−
23−notifications:
24− email:
25− recipients:
26− - rlefevre@dmy.fr
27− on_success: change
28− on_failure: change
ContributorAgreement.pdfnew file

Binary file not shown.

LICENSE+25−6
@@ -1,11 +1,30 @@
1−Copyright 2012-present Evan Czaplicki
1+Copyright (c) 2012-present, Evan Czaplicki
2
2
3−Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
3+All rights reserved.
4
4
5−1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
6
7
8+ * Redistributions of source code must retain the above copyright
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.
9+ notice, this list of conditions and the following disclaimer.
8
10
9−3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
10
15
11−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
16+ * Neither the name of Evan Czaplicki nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+5−10
@@ -1,22 +1,17 @@
1−# Elm
1+# The Elm Compiler
2
2
3−A delightful language for reliable webapps.
3+Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
4
4
5−Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
6−
7−
8−<br>
9
5
10## Install
6## Install
11
7
12−✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
8+Follow [these instructions][installer]!
13
9
14−For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
10+ [installer]: https://guide.elm-lang.org/install.html
15
11
16−<br>
17
12
18## Help
13## Help
19
14
20If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
15If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
21
16
22−[slack]: http://elmlang.herokuapp.com/
17+[slack]: http://elmlang.herokuapp.com/
builder/src/BackgroundWriter.hsdeleted−42
@@ -1,42 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module BackgroundWriter
3− ( Scope
4− , withScope
5− , writeBinary
6− )
7− where
8−
9−
10−import Control.Concurrent (forkIO)
11−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
12−import qualified Data.Binary as Binary
13−import Data.Foldable (traverse_)
14−
15−import qualified File
16−
17−
18−
19−-- BACKGROUND WRITER
20−
21−
22−newtype Scope =
23− Scope (MVar [MVar ()])
24−
25−
26−withScope :: (Scope -> IO a) -> IO a
27−withScope callback =
28− do workList <- newMVar []
29− result <- callback (Scope workList)
30− mvars <- takeMVar workList
31− traverse_ takeMVar mvars
32− return result
33−
34−
35−writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
36−writeBinary (Scope workList) path value =
37− do mvar <- newEmptyMVar
38− _ <- forkIO (File.writeBinary path value >> putMVar mvar ())
39− oldWork <- takeMVar workList
40− let !newWork = mvar:oldWork
41− putMVar workList newWork
42−
builder/src/Build.hs+254−427
@@ -2,15 +2,12 @@
2{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
2{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3module Build
3module Build
4 ( fromExposed
4 ( fromExposed
5− , fromPaths
5+ , fromMains
6− , fromRepl
7 , Artifacts(..)
6 , Artifacts(..)
8− , Root(..)
7+ , Main(..)
9 , Module(..)
8 , Module(..)
10 , CachedInterface(..)
9 , CachedInterface(..)
11− , ReplArtifacts(..)
12 , DocsGoal(..)
10 , DocsGoal(..)
13− , getRootNames
14 )
11 )
15 where
12 where
16
13
@@ -20,6 +17,7 @@ import Control.Concurrent.MVar
20import Control.Monad (filterM, mapM_, sequence_)
17import Control.Monad (filterM, mapM_, sequence_)
21import qualified Data.ByteString as B
18import qualified Data.ByteString as B
22import qualified Data.Char as Char
19import qualified Data.Char as Char
20+import qualified Data.Either as Either
23import qualified Data.Graph as Graph
21import qualified Data.Graph as Graph
24import qualified Data.List as List
22import qualified Data.List as List
25import qualified Data.Map.Utils as Map
23import qualified Data.Map.Utils as Map
@@ -50,11 +48,9 @@ import qualified Parse.Module as Parse
50import qualified Reporting
48import qualified Reporting
51import qualified Reporting.Annotation as A
49import qualified Reporting.Annotation as A
52import qualified Reporting.Error as Error
50import qualified Reporting.Error as Error
53−import qualified Reporting.Error.Docs as EDocs
54import qualified Reporting.Error.Syntax as Syntax
51import qualified Reporting.Error.Syntax as Syntax
55import qualified Reporting.Error.Import as Import
52import qualified Reporting.Error.Import as Import
56import qualified Reporting.Exit as Exit
53import qualified Reporting.Exit as Exit
57−import qualified Reporting.Render.Type.Localizer as L
58import qualified Stuff
54import qualified Stuff
59
55
60
56
@@ -66,57 +62,27 @@ data Env =
66 Env
62 Env
67 { _key :: Reporting.BKey
63 { _key :: Reporting.BKey
68 , _root :: FilePath
64 , _root :: FilePath
69− , _project :: Parse.ProjectType
65+ , _pkg :: Pkg.Name
70− , _srcDirs :: [AbsoluteSrcDir]
66+ , _srcDirs :: [FilePath]
71− , _buildID :: Details.BuildID
72 , _locals :: Map.Map ModuleName.Raw Details.Local
67 , _locals :: Map.Map ModuleName.Raw Details.Local
73 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
68 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
74 }
69 }
75
70
76
71
77−makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
72+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
78−makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
73+makeEnv key root (Details.Details _ validOutline locals foreigns _) =
79 case validOutline of
74 case validOutline of
80− Details.ValidApp givenSrcDirs ->
75+ Details.ValidApp srcDirs ->
81− do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82− return $ Env key root Parse.Application srcDirs buildID locals foreigns
76+ Env key root Pkg.dummyName (NE.toList srcDirs) locals foreigns
83
77
84− Details.ValidPkg pkg _ _ ->
78+ Details.ValidPkg pkg _ ->
85− do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
86− return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
79+ Env key root pkg ["src"] locals foreigns
87−
88−
89−
90−-- SOURCE DIRECTORY
91−
92−
93−newtype AbsoluteSrcDir =
94− AbsoluteSrcDir FilePath
95−
96−
97−toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
98−toAbsoluteSrcDir root srcDir =
99− AbsoluteSrcDir <$> Dir.canonicalizePath
100− (
101− case srcDir of
102− Outline.AbsoluteSrcDir dir -> dir
103− Outline.RelativeSrcDir dir -> root </> dir
104− )
105−
106−
107−addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
108−addRelative (AbsoluteSrcDir srcDir) path =
109− srcDir </> path
110
80
111
81
112
82
113-- FORK
83-- FORK
114
84
115
85
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−--
120fork :: IO a -> IO (MVar a)
86fork :: IO a -> IO (MVar a)
121fork work =
87fork work =
122 do mvar <- newEmptyMVar
88 do mvar <- newEmptyMVar
@@ -137,7 +103,7 @@ forkWithKey func dict =
137fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
103fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
138fromExposed style root details docsGoal exposed@(NE.List e es) =
104fromExposed style root details docsGoal exposed@(NE.List e es) =
139 Reporting.trackBuild style $ \key ->
105 Reporting.trackBuild style $ \key ->
140− do env <- makeEnv key root details
106+ do let env = makeEnv key root details
141 dmvar <- Details.loadInterfaces root details
107 dmvar <- Details.loadInterfaces root details
142
108
143 -- crawl
109 -- crawl
@@ -149,7 +115,7 @@ fromExposed style root details docsGoal exposed@(NE.List e es) =
149 statuses <- traverse readMVar =<< readMVar mvar
115 statuses <- traverse readMVar =<< readMVar mvar
150
116
151 -- compile
117 -- compile
152− midpoint <- checkMidpoint dmvar statuses
118+ midpoint <- checkExposedMidpoint dmvar statuses
153 case midpoint of
119 case midpoint of
154 Left problem ->
120 Left problem ->
155 return (Left (Exit.BuildProjectProblem problem))
121 return (Left (Exit.BuildProjectProblem problem))
@@ -160,18 +126,18 @@ fromExposed style root details docsGoal exposed@(NE.List e es) =
160 putMVar rmvar resultMVars
126 putMVar rmvar resultMVars
161 results <- traverse readMVar resultMVars
127 results <- traverse readMVar resultMVars
162 writeDetails root details results
128 writeDetails root details results
163− finalizeExposed root docsGoal exposed results
129+ finalizeExposed docsGoal exposed results
164
130
165
131
166
132
167−-- FROM PATHS
133+-- FROM MAINS
168
134
169
135
170data Artifacts =
136data Artifacts =
171 Artifacts
137 Artifacts
172 { _name :: Pkg.Name
138 { _name :: Pkg.Name
173 , _deps :: Dependencies
139 , _deps :: Dependencies
174− , _roots :: NE.List Root
140+ , _mains :: NE.List Main
175 , _modules :: [Module]
141 , _modules :: [Module]
176 }
142 }
177
143
@@ -185,25 +151,25 @@ type Dependencies =
185 Map.Map ModuleName.Canonical I.DependencyInterface
151 Map.Map ModuleName.Canonical I.DependencyInterface
186
152
187
153
188−fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
154+fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
189−fromPaths style root details paths =
155+fromMains style root details paths =
190 Reporting.trackBuild style $ \key ->
156 Reporting.trackBuild style $ \key ->
191− do env <- makeEnv key root details
157+ do let env = makeEnv key root details
192
158
193− elroots <- findRoots env paths
159+ elmains <- findMains env paths
194− case elroots of
160+ case elmains of
195 Left problem ->
161 Left problem ->
196 return (Left (Exit.BuildProjectProblem problem))
162 return (Left (Exit.BuildProjectProblem problem))
197
163
198− Right lroots ->
164+ Right lmains ->
199 do -- crawl
165 do -- crawl
200 dmvar <- Details.loadInterfaces root details
166 dmvar <- Details.loadInterfaces root details
201 smvar <- newMVar Map.empty
167 smvar <- newMVar Map.empty
202− srootMVars <- traverse (fork . crawlRoot env smvar) lroots
168+ smainMVars <- traverse (fork . crawlMain env smvar) lmains
203− sroots <- traverse readMVar srootMVars
169+ smains <- traverse readMVar smainMVars
204 statuses <- traverse readMVar =<< readMVar smvar
170 statuses <- traverse readMVar =<< readMVar smvar
205
171
206− midpoint <- checkMidpointAndRoots dmvar statuses sroots
172+ midpoint <- checkMainsMidpoint dmvar statuses smains
207 case midpoint of
173 case midpoint of
208 Left problem ->
174 Left problem ->
209 return (Left (Exit.BuildProjectProblem problem))
175 return (Left (Exit.BuildProjectProblem problem))
@@ -213,26 +179,10 @@ fromPaths style root details paths =
213 rmvar <- newEmptyMVar
179 rmvar <- newEmptyMVar
214 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
180 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
215 putMVar rmvar resultsMVars
181 putMVar rmvar resultsMVars
216− rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
182+ rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
217 results <- traverse readMVar resultsMVars
183 results <- traverse readMVar resultsMVars
218 writeDetails root details results
184 writeDetails root details results
219− toArtifacts env foreigns results <$> traverse readMVar rrootMVars
185+ toArtifacts env foreigns results <$> traverse readMVar rmainMVars
220−
221−
222−
223−-- GET ROOT NAMES
224−
225−
226−getRootNames :: Artifacts -> NE.List ModuleName.Raw
227−getRootNames (Artifacts _ _ roots _) =
228− fmap getRootName roots
229−
230−
231−getRootName :: Root -> ModuleName.Raw
232−getRootName root =
233− case root of
234− Inside name -> name
235− Outside name _ _ -> name
236
186
237
187
238
188
@@ -266,10 +216,11 @@ crawlDeps env mvar deps blockedValue =
266
216
267
217
268crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
218crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
269−crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
219+crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
270 do let fileName = ModuleName.toFilePath name <.> "elm"
220 do let fileName = ModuleName.toFilePath name <.> "elm"
221+ let inRoot path = File.exists (root </> path)
271
222
272− paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
223+ paths <- filterM inRoot (map (</> fileName) srcDirs)
273
224
274 case paths of
225 case paths of
275 [path] ->
226 [path] ->
@@ -278,18 +229,21 @@ crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar do
278 return $ SBadImport $ Import.Ambiguous path [] dep deps
229 return $ SBadImport $ Import.Ambiguous path [] dep deps
279
230
280 Nothing ->
231 Nothing ->
281− do newTime <- File.getTime path
282− case Map.lookup name locals of
232+ case Map.lookup name locals of
283− Nothing ->
233+ Nothing ->
284− crawlFile env mvar docsNeed name path newTime buildID
234+ crawlFile env mvar docsNeed name path
285
235
286− Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
236+ Just local@(Details.Local oldPath oldTime deps _) ->
237+ if path /= oldPath
238+ then crawlFile env mvar docsNeed name path
239+ else
240+ do newTime <- File.getTime path
287− if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
241+ if oldTime < newTime || needsDocs docsNeed
288− then crawlFile env mvar docsNeed name path newTime lastChange
242+ then crawlFile env mvar docsNeed name path
289− else crawlDeps env mvar deps (SCached local)
243+ else crawlDeps env mvar deps (SCached local)
290
244
291 p1:p2:ps ->
245 p1:p2:ps ->
292− return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
246+ return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
293
247
294 [] ->
248 [] ->
295 case Map.lookup name foreigns of
249 case Map.lookup name foreigns of
@@ -302,18 +256,19 @@ crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar do
302 return $ SBadImport $ Import.AmbiguousForeign dep d ds
256 return $ SBadImport $ Import.AmbiguousForeign dep d ds
303
257
304 Nothing ->
258 Nothing ->
305− if Name.isKernel name && Parse.isKernel projectType then
259+ if Name.isKernel name && Pkg.isKernel pkg then
306 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
260 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
307 return $ if exists then SKernel else SBadImport Import.NotFound
261 return $ if exists then SKernel else SBadImport Import.NotFound
308 else
262 else
309 return $ SBadImport Import.NotFound
263 return $ SBadImport Import.NotFound
310
264
311
265
312−crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
266+crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
313−crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
267+crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
268+ do time <- File.getTime path
314− do source <- File.readUtf8 (root </> path)
269+ source <- File.readUtf8 (root </> path)
315
270
316− case Parse.fromByteString projectType source of
271+ case Parse.fromByteString pkg source of
317 Left err ->
272 Left err ->
318 return $ SBadSyntax path time source err
273 return $ SBadSyntax path time source err
319
274
@@ -326,7 +281,7 @@ crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName
326 if expectedName == actualName then
281 if expectedName == actualName then
327 let
282 let
328 deps = map Src.getImportName imports
283 deps = map Src.getImportName imports
329− local = Details.Local path time deps (any isMain values) lastChange buildID
284+ local = Details.Local path time deps (any isMain values)
330 in
285 in
331 crawlDeps env mvar deps (SChanged local source modul docsNeed)
286 crawlDeps env mvar deps (SChanged local source modul docsNeed)
332 else
287 else
@@ -349,7 +304,7 @@ type ResultDict =
349data Result
304data Result
350 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
305 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
351 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
306 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
352− | RCached Bool Details.BuildID (MVar CachedInterface)
307+ | RCached Bool (MVar CachedInterface)
353 | RNotFound Import.Problem
308 | RNotFound Import.Problem
354 | RProblem Error.Module
309 | RProblem Error.Module
355 | RBlocked
310 | RBlocked
@@ -364,15 +319,15 @@ data CachedInterface
364
319
365
320
366checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
321checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
367−checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
322+checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
368 case status of
323 case status of
369− SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
324+ SCached local@(Details.Local path time deps hasMain) ->
370 do results <- readMVar resultsMVar
325 do results <- readMVar resultsMVar
371− depsStatus <- checkDeps root results deps lastCompile
326+ depsStatus <- checkDeps root results deps
372 case depsStatus of
327 case depsStatus of
373 DepsChange ifaces ->
328 DepsChange ifaces ->
374 do source <- File.readUtf8 path
329 do source <- File.readUtf8 path
375− case Parse.fromByteString projectType source of
330+ case Parse.fromByteString pkg source of
376 Right modul -> compile env (DocsNeed False) local source ifaces modul
331 Right modul -> compile env (DocsNeed False) local source ifaces modul
377 Left err ->
332 Left err ->
378 return $ RProblem $
333 return $ RProblem $
@@ -380,7 +335,7 @@ checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name statu
380
335
381 DepsSame _ _ ->
336 DepsSame _ _ ->
382 do mvar <- newMVar Unneeded
337 do mvar <- newMVar Unneeded
383− return (RCached hasMain lastChange mvar)
338+ return (RCached hasMain mvar)
384
339
385 DepsBlock ->
340 DepsBlock ->
386 return RBlocked
341 return RBlocked
@@ -388,25 +343,29 @@ checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name statu
388 DepsNotFound problems ->
343 DepsNotFound problems ->
389 do source <- File.readUtf8 path
344 do source <- File.readUtf8 path
390 return $ RProblem $ Error.Module name path time source $
345 return $ RProblem $ Error.Module name path time source $
391− case Parse.fromByteString projectType source of
346+ case Parse.fromByteString pkg source of
392 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
347 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
393 Error.BadImports (toImportErrors env results imports problems)
348 Error.BadImports (toImportErrors env results imports problems)
394
349
395 Left err ->
350 Left err ->
396 Error.BadSyntax err
351 Error.BadSyntax err
397
352
398− SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
353+ SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
399 do results <- readMVar resultsMVar
354 do results <- readMVar resultsMVar
400− depsStatus <- checkDeps root results deps lastCompile
355+ depsStatus <- checkDeps root results deps
401 case depsStatus of
356 case depsStatus of
402 DepsChange ifaces ->
357 DepsChange ifaces ->
403 compile env docsNeed local source ifaces modul
358 compile env docsNeed local source ifaces modul
404
359
405 DepsSame same cached ->
360 DepsSame same cached ->
406− do maybeLoaded <- loadInterfaces root same cached
361+ do maybeLoaded <- checkCachedInterfaces root cached
407 case maybeLoaded of
362 case maybeLoaded of
363+ Nothing ->
408− Nothing -> return RBlocked
364+ return RBlocked
365+
366+ Just loaded ->
367+ do let ifaces = Map.union loaded (Map.fromList same)
409− Just ifaces -> compile env docsNeed local source ifaces modul
368+ compile env docsNeed local source ifaces modul
410
369
411 DepsBlock ->
370 DepsBlock ->
412 return RBlocked
371 return RBlocked
@@ -425,7 +384,7 @@ checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name statu
425 SForeign home ->
384 SForeign home ->
426 case foreigns ! ModuleName.Canonical home name of
385 case foreigns ! ModuleName.Canonical home name of
427 I.Public iface -> return (RForeign iface)
386 I.Public iface -> return (RForeign iface)
428− I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
387+ I.Private _ _ _ -> error "loading private interface in Build"
429
388
430 SKernel ->
389 SKernel ->
431 return RKernel
390 return RKernel
@@ -442,48 +401,32 @@ data DepsStatus
442 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
401 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
443
402
444
403
445−checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
404+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
446−checkDeps root results deps lastCompile =
405+checkDeps root results deps =
447− checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
406+ checkDepsHelp root results deps [] [] [] [] False
448
407
449
408
450type Dep = (ModuleName.Raw, I.Interface)
409type Dep = (ModuleName.Raw, I.Interface)
451type CDep = (ModuleName.Raw, MVar CachedInterface)
410type CDep = (ModuleName.Raw, MVar CachedInterface)
452
411
453
412
454−checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
413+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
455−checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
414+checkDepsHelp root results deps new same cached importProblems isBlocked =
456 case deps of
415 case deps of
457 dep:otherDeps ->
416 dep:otherDeps ->
458 do result <- readMVar (results ! dep)
417 do result <- readMVar (results ! dep)
459 case result of
418 case result of
460− RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
461− checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
419+ RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
462−
463− RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
464− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
420+ RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
465−
466− RCached _ lastChange mvar ->
467− checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
421+ RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
468−
469− RNotFound prob ->
470− checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
422+ RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
471−
472− RProblem _ ->
473− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
423+ RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
474−
475− RBlocked ->
476− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
424+ RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
477−
478− RForeign iface ->
479− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
425+ RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
480−
481− RKernel ->
482− checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
426+ RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
483−
484
427
485 [] ->
428 [] ->
486− case reverse importProblems of
429+ case importProblems of
487 p:ps ->
430 p:ps ->
488 return $ DepsNotFound (NE.List p ps)
431 return $ DepsNotFound (NE.List p ps)
489
432
@@ -491,14 +434,18 @@ checkDepsHelp root results deps new same cached importProblems isBlocked lastDep
491 if isBlocked then
434 if isBlocked then
492 return $ DepsBlock
435 return $ DepsBlock
493
436
494− else if null new && lastDepChange <= lastCompile then
437+ else if null new then
495 return $ DepsSame same cached
438 return $ DepsSame same cached
496
439
497 else
440 else
498− do maybeLoaded <- loadInterfaces root same cached
441+ do maybeLoaded <- checkCachedInterfaces root cached
499 case maybeLoaded of
442 case maybeLoaded of
443+ Nothing ->
500− Nothing -> return DepsBlock
444+ return DepsBlock
445+
446+ Just loaded ->
501− Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
447+ return $ DepsChange $
448+ Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
502
449
503
450
504
451
@@ -506,7 +453,7 @@ checkDepsHelp root results deps new same cached importProblems isBlocked lastDep
506
453
507
454
508toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
455toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
509−toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
456+toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
510 let
457 let
511 knownModules =
458 knownModules =
512 Set.unions
459 Set.unions
@@ -528,23 +475,18 @@ toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
528
475
529
476
530
477
531−-- LOAD CACHED INTERFACES
478+-- CACHED INTERFACE
532
479
533
480
534−loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
481+checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
535−loadInterfaces root same cached =
482+checkCachedInterfaces root deps =
536− do loading <- traverse (fork . loadInterface root) cached
483+ do loading <- traverse (fork . checkCache root) deps
537− maybeLoaded <- traverse readMVar loading
484+ loaded <- traverse readMVar loading
538− case sequence maybeLoaded of
485+ return $ Map.fromList <$> sequence loaded
539− Nothing ->
540− return Nothing
541−
542− Just loaded ->
543− return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
544
486
545
487
546−loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
488+checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
547−loadInterface root (name, ciMvar) =
489+checkCache root (name, ciMvar) =
548 do cachedInterface <- takeMVar ciMvar
490 do cachedInterface <- takeMVar ciMvar
549 case cachedInterface of
491 case cachedInterface of
550 Corrupted ->
492 Corrupted ->
@@ -571,8 +513,8 @@ loadInterface root (name, ciMvar) =
571-- CHECK PROJECT
513-- CHECK PROJECT
572
514
573
515
574−checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
516+checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575−checkMidpoint dmvar statuses =
517+checkExposedMidpoint dmvar statuses =
576 case checkForCycles statuses of
518 case checkForCycles statuses of
577 Nothing ->
519 Nothing ->
578 do maybeForeigns <- readMVar dmvar
520 do maybeForeigns <- readMVar dmvar
@@ -585,11 +527,11 @@ checkMidpoint dmvar statuses =
585 return (Left (Exit.BP_Cycle name names))
527 return (Left (Exit.BP_Cycle name names))
586
528
587
529
588−checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
530+checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
589−checkMidpointAndRoots dmvar statuses sroots =
531+checkMainsMidpoint dmvar statuses smains =
590 case checkForCycles statuses of
532 case checkForCycles statuses of
591 Nothing ->
533 Nothing ->
592− case checkUniqueRoots statuses sroots of
534+ case checkUniqueMains statuses smains of
593 Nothing ->
535 Nothing ->
594 do maybeForeigns <- readMVar dmvar
536 do maybeForeigns <- readMVar dmvar
595 case maybeForeigns of
537 case maybeForeigns of
@@ -640,25 +582,25 @@ addToGraph name status graph =
640 let
582 let
641 dependencies =
583 dependencies =
642 case status of
584 case status of
643− SCached (Details.Local _ _ deps _ _ _) -> deps
585+ SCached (Details.Local _ _ deps _) -> deps
644− SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
586+ SChanged (Details.Local _ _ deps _) _ _ _ -> deps
645− SBadImport _ -> []
587+ SBadImport _ -> []
646− SBadSyntax _ _ _ _ -> []
588+ SBadSyntax _ _ _ _ -> []
647− SForeign _ -> []
589+ SForeign _ -> []
648− SKernel -> []
590+ SKernel -> []
649 in
591 in
650 (name, name, dependencies) : graph
592 (name, name, dependencies) : graph
651
593
652
594
653
595
654−-- CHECK UNIQUE ROOTS
596+-- CHECK UNIQUE MAINS
655
597
656
598
657−checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
599+checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
658−checkUniqueRoots insides sroots =
600+checkUniqueMains insides smains =
659 let
601 let
660 outsidesDict =
602 outsidesDict =
661− Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
603+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
662 in
604 in
663 case Map.traverseWithKey checkOutside outsidesDict of
605 case Map.traverseWithKey checkOutside outsidesDict of
664 Left problem ->
606 Left problem ->
@@ -670,30 +612,30 @@ checkUniqueRoots insides sroots =
670 Left problem -> Just problem
612 Left problem -> Just problem
671
613
672
614
673−rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
615+mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
674−rootStatusToNamePathPair sroot =
616+mainStatusToNamePathPair smain =
675− case sroot of
617+ case smain of
676− SInside _ -> Nothing
618+ SInside _ -> Nothing
677− SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
619+ SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
678− SOutsideErr _ -> Nothing
620+ SOutsideErr _ -> Nothing
679
621
680
622
681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
623checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
682checkOutside name paths =
624checkOutside name paths =
683 case OneOrMore.destruct NE.List paths of
625 case OneOrMore.destruct NE.List paths of
684 NE.List p [] -> Right p
626 NE.List p [] -> Right p
685− NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
627+ NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
686
628
687
629
688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
630checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
689checkInside name p1 status =
631checkInside name p1 status =
690 case status of
632 case status of
691− SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
633+ SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
692− SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
634+ SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
693− SBadImport _ -> Right ()
635+ SBadImport _ -> Right ()
694− SBadSyntax _ _ _ _ -> Right ()
636+ SBadSyntax _ _ _ _ -> Right ()
695− SForeign _ -> Right ()
637+ SForeign _ -> Right ()
696− SKernel -> Right ()
638+ SKernel -> Right ()
697
639
698
640
699
641
@@ -701,47 +643,31 @@ checkInside name p1 status =
701
643
702
644
703compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
645compile :: 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 =
646+compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
705− let
706− pkg = projectTypeToPkg projectType
707− in
708 case Compile.compile pkg ifaces modul of
647 case Compile.compile pkg ifaces modul of
709 Right (Compile.Artifacts canonical annotations objects) ->
648 Right (Compile.Artifacts canonical annotations objects) ->
710− case makeDocs docsNeed canonical of
711− Left err ->
712− return $ RProblem $
713− Error.Module (Src.getName modul) path time source (Error.BadDocs err)
714−
715− Right docs ->
716− do let name = Src.getName modul
649+ do let name = Src.getName modul
717− let iface = I.fromModule pkg canonical annotations
650+ let iface = I.fromModule pkg canonical annotations
718− let elmi = Stuff.elmi root name
651+ let docs = makeDocs docsNeed canonical
719− File.writeBinary (Stuff.elmo root name) objects
652+ File.writeBinary (Stuff.elmo root name) objects
720− maybeOldi <- File.readBinary elmi
653+ maybeOldi <- File.readBinary (Stuff.elmi root name)
721− case maybeOldi of
654+ case maybeOldi of
722− Just oldi | oldi == iface ->
655+ Just oldi | oldi == iface ->
723− do -- iface should be fully forced by equality check
656+ do -- iface should be fully forced by equality check
724− Reporting.report key Reporting.BDone
657+ Reporting.report key Reporting.BDone
725− let local = Details.Local path time deps main lastChange buildID
726− return (RSame local iface objects docs)
658+ return (RSame local iface objects docs)
727−
659+
728− _ ->
660+ _ ->
729− do -- iface may be lazy still
661+ do -- iface may be lazy still
662+ -- TODO try adding forkIO here
730− File.writeBinary elmi iface
663+ File.writeBinary (Stuff.elmi root name) iface
731− Reporting.report key Reporting.BDone
664+ Reporting.report key Reporting.BDone
732− let local = Details.Local path time deps main buildID buildID
733− return (RNew local iface objects docs)
665+ return (RNew local iface objects docs)
734
666
735 Left err ->
667 Left err ->
668+ do Reporting.report key Reporting.BDone
736− return $ RProblem $
669+ return $ RProblem $
737− Error.Module (Src.getName modul) path time source err
670+ Error.Module (Src.getName modul) path time source err
738−
739−
740−projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
741−projectTypeToPkg projectType =
742− case projectType of
743− Parse.Package pkg -> pkg
744− Parse.Application -> Pkg.dummyName
745
671
746
672
747
673
@@ -749,9 +675,9 @@ projectTypeToPkg projectType =
749
675
750
676
751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
677writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
752−writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
678+writeDetails root (Details.Details time outline locals foreigns extras) results =
753 File.writeBinary (Stuff.details root) $
679 File.writeBinary (Stuff.details root) $
754− Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
680+ Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
755
681
756
682
757addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
683addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
@@ -759,7 +685,7 @@ addNewLocal name result locals =
759 case result of
685 case result of
760 RNew local _ _ _ -> Map.insert name local locals
686 RNew local _ _ _ -> Map.insert name local locals
761 RSame local _ _ _ -> Map.insert name local locals
687 RSame local _ _ _ -> Map.insert name local locals
762− RCached _ _ _ -> locals
688+ RCached _ _ -> locals
763 RNotFound _ -> locals
689 RNotFound _ -> locals
764 RProblem _ -> locals
690 RProblem _ -> locals
765 RBlocked -> locals
691 RBlocked -> locals
@@ -771,8 +697,8 @@ addNewLocal name result locals =
771-- FINALIZE EXPOSED
697-- FINALIZE EXPOSED
772
698
773
699
774−finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
700+finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
775−finalizeExposed root docsGoal exposed results =
701+finalizeExposed docsGoal exposed results =
776 case foldr (addImportProblems results) [] (NE.toList exposed) of
702 case foldr (addImportProblems results) [] (NE.toList exposed) of
777 p:ps ->
703 p:ps ->
778 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
704 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
@@ -780,7 +706,7 @@ finalizeExposed root docsGoal exposed results =
780 [] ->
706 [] ->
781 case Map.foldr addErrors [] results of
707 case Map.foldr addErrors [] results of
782 [] -> Right <$> finalizeDocs docsGoal results
708 [] -> Right <$> finalizeDocs docsGoal results
783− e:es -> return $ Left $ Exit.BuildBadModules root e es
709+ e:es -> return $ Left $ Exit.BuildModuleProblems e es
784
710
785
711
786addErrors :: Result -> [Error.Module] -> [Error.Module]
712addErrors :: Result -> [Error.Module] -> [Error.Module]
@@ -788,7 +714,7 @@ addErrors result errors =
788 case result of
714 case result of
789 RNew _ _ _ _ -> errors
715 RNew _ _ _ _ -> errors
790 RSame _ _ _ _ -> errors
716 RSame _ _ _ _ -> errors
791− RCached _ _ _ -> errors
717+ RCached _ _ -> errors
792 RNotFound _ -> errors
718 RNotFound _ -> errors
793 RProblem e -> e:errors
719 RProblem e -> e:errors
794 RBlocked -> errors
720 RBlocked -> errors
@@ -801,7 +727,7 @@ addImportProblems results name problems =
801 case results ! name of
727 case results ! name of
802 RNew _ _ _ _ -> problems
728 RNew _ _ _ _ -> problems
803 RSame _ _ _ _ -> problems
729 RSame _ _ _ _ -> problems
804− RCached _ _ _ -> problems
730+ RCached _ _ -> problems
805 RNotFound p -> (name, p) : problems
731 RNotFound p -> (name, p) : problems
806 RProblem _ -> problems
732 RProblem _ -> problems
807 RBlocked -> problems
733 RBlocked -> problems
@@ -831,14 +757,14 @@ toDocsNeed goal =
831 KeepDocs -> DocsNeed True
757 KeepDocs -> DocsNeed True
832
758
833
759
834−makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
760+makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
835makeDocs (DocsNeed isNeeded) modul =
761makeDocs (DocsNeed isNeeded) modul =
836 if isNeeded then
762 if isNeeded then
837 case Docs.fromModule modul of
763 case Docs.fromModule modul of
838− Right docs -> Right (Just docs)
764+ Right docs -> Just docs
839− Left err -> Left err
765+ Left _ -> Nothing
840 else
766 else
841− Right Nothing
767+ Nothing
842
768
843
769
844finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
770finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
@@ -859,7 +785,7 @@ toDocs result =
859 case result of
785 case result of
860 RNew _ _ _ d -> d
786 RNew _ _ _ d -> d
861 RSame _ _ _ d -> d
787 RSame _ _ _ d -> d
862− RCached _ _ _ -> Nothing
788+ RCached _ _ -> Nothing
863 RNotFound _ -> Nothing
789 RNotFound _ -> Nothing
864 RProblem _ -> Nothing
790 RProblem _ -> Nothing
865 RBlocked -> Nothing
791 RBlocked -> Nothing
@@ -868,94 +794,6 @@ toDocs result =
868
794
869
795
870
796
871−--------------------------------------------------------------------------------
872−------ NOW FOR SOME REPL STUFF -------------------------------------------------
873−--------------------------------------------------------------------------------
874−
875−
876−-- FROM REPL
877−
878−
879−data ReplArtifacts =
880− ReplArtifacts
881− { _repl_home :: ModuleName.Canonical
882− , _repl_modules :: [Module]
883− , _repl_localizer :: L.Localizer
884− , _repl_annotations :: Map.Map Name.Name Can.Annotation
885− }
886−
887−
888−fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
889−fromRepl root details source =
890− do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
891− case Parse.fromByteString projectType source of
892− Left syntaxError ->
893− return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
894−
895− Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
896− do dmvar <- Details.loadInterfaces root details
897−
898− let deps = map Src.getImportName imports
899− mvar <- newMVar Map.empty
900− crawlDeps env mvar deps ()
901−
902− statuses <- traverse readMVar =<< readMVar mvar
903− midpoint <- checkMidpoint dmvar statuses
904−
905− case midpoint of
906− Left problem ->
907− return $ Left $ Exit.ReplProjectProblem problem
908−
909− Right foreigns ->
910− do rmvar <- newEmptyMVar
911− resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
912− putMVar rmvar resultMVars
913− results <- traverse readMVar resultMVars
914− writeDetails root details results
915− depsStatus <- checkDeps root resultMVars deps 0
916− finalizeReplArtifacts env source modul depsStatus resultMVars results
917−
918−
919−finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
920−finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
921− let
922− pkg =
923− projectTypeToPkg projectType
924−
925− compileInput ifaces =
926− case Compile.compile pkg ifaces modul of
927− Right (Compile.Artifacts canonical annotations objects) ->
928− let
929− h = Can._name canonical
930− m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
931− ms = Map.foldrWithKey addInside [] results
932− in
933− return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
934−
935− Left errors ->
936− return $ Left $ Exit.ReplBadInput source errors
937− in
938− case depsStatus of
939− DepsChange ifaces ->
940− compileInput ifaces
941−
942− DepsSame same cached ->
943− do maybeLoaded <- loadInterfaces root same cached
944− case maybeLoaded of
945− Just ifaces -> compileInput ifaces
946− Nothing -> return $ Left $ Exit.ReplBadCache
947−
948− DepsBlock ->
949− case Map.foldr addErrors [] results of
950− [] -> return $ Left $ Exit.ReplBlocked
951− e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
952−
953− DepsNotFound problems ->
954− return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
955− toImportErrors env resultMVars imports problems
956−
957−
958−
959--------------------------------------------------------------------------------
797--------------------------------------------------------------------------------
960--------------------------------------------------------------------------------
798--------------------------------------------------------------------------------
961------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
799------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
@@ -964,25 +802,25 @@ finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Mod
964
802
965
803
966
804
967−-- FIND ROOT
805+-- FIND MAIN
968
806
969
807
970−data RootLocation
808+data MainLocation
971 = LInside ModuleName.Raw
809 = LInside ModuleName.Raw
972 | LOutside FilePath
810 | LOutside FilePath
973
811
974
812
975−findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
813+findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
976−findRoots env paths =
814+findMains env paths =
977− do mvars <- traverse (fork . getRootInfo env) paths
815+ do mvars <- traverse (fork . findLocation env) paths
978− einfos <- traverse readMVar mvars
816+ elocs <- traverse readMVar mvars
979− return $ checkRoots =<< sequence einfos
817+ return $ checkLocations =<< sequence elocs
980
818
981
819
982−checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
820+checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
983−checkRoots infos =
821+checkLocations locations =
984 let
822 let
985− toOneOrMore loc@(RootInfo absolute _ _) =
823+ toOneOrMore loc@(Location absolute _ _) =
986 (absolute, OneOrMore.one loc)
824 (absolute, OneOrMore.one loc)
987
825
988 fromOneOrMore loc locs =
826 fromOneOrMore loc locs =
@@ -990,83 +828,71 @@ checkRoots infos =
990 [] -> Right ()
828 [] -> Right ()
991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
829 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
992 in
830 in
993− fmap (\_ -> fmap _location infos) $
831+ fmap (\_ -> fmap _location locations) $
994 traverse (OneOrMore.destruct fromOneOrMore) $
832 traverse (OneOrMore.destruct fromOneOrMore) $
995− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
833+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
996
834
997
835
998
836
999−-- ROOT INFO
837+-- LOCATIONS
1000
838
1001
839
1002−data RootInfo =
840+data Location =
1003− RootInfo
841+ Location
1004 { _absolute :: FilePath
842 { _absolute :: FilePath
1005 , _relative :: FilePath
843 , _relative :: FilePath
1006− , _location :: RootLocation
844+ , _location :: MainLocation
1007 }
845 }
1008
846
1009
847
1010−getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
848+findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
1011−getRootInfo env path =
849+findLocation env path =
1012 do exists <- File.exists path
850 do exists <- File.exists path
1013 if exists
851 if exists
1014− then getRootInfoHelp env path =<< Dir.canonicalizePath path
852+ then isInsideSrcDirs env path <$> Dir.canonicalizePath path
1015 else return (Left (Exit.BP_PathUnknown path))
853 else return (Left (Exit.BP_PathUnknown path))
1016
854
1017
855
1018−getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
856+isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
1019−getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
857+isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
1020 let
858 let
1021 (dirs, file) = FP.splitFileName absolutePath
859 (dirs, file) = FP.splitFileName absolutePath
1022− (final, ext) = FP.splitExtension file
860+ (final, ext) = break (=='.') file
1023 in
861 in
1024 if ext /= ".elm"
862 if ext /= ".elm"
1025− then
1026− return $ Left $ Exit.BP_WithBadExtension path
863+ then Left (Exit.BP_WithBadExtension path)
1027 else
864 else
1028 let
865 let
866+ roots = FP.splitDirectories root
1029− absoluteSegments = FP.splitDirectories dirs ++ [final]
867+ segments = FP.splitDirectories dirs ++ [final]
1030 in
868 in
1031− case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
869+ case dropPrefix roots segments of
1032− [] ->
870+ Nothing ->
1033− return $ Right $ RootInfo absolutePath path (LOutside path)
871+ Right (Location absolutePath path (LOutside path))
1034−
872+
1035− [(_, Right names)] ->
873+ Just relativeSegments ->
1036− do let name = Name.fromChars (List.intercalate "." names)
874+ let
1037− matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
875+ (exits, maybes) =
1038− case matchingDirs of
876+ Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
1039− d1:d2:_ ->
877+ in
1040− do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
878+ -- TODO make sure this is all correct
1041− let p2 = addRelative d2 (FP.joinPath names <.> "elm")
879+ case (exits, Maybe.catMaybes maybes) of
1042− return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1043−
1044− _ ->
1045− return $ Right $ RootInfo absolutePath path (LInside name)
880+ (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
1046−
881+ ([], []) -> Right (Location absolutePath path (LOutside path))
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
882+ (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
1052−
883+ (exit:_, _) -> Left exit
1053−
884+
1054−
885+
1055−isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
886+isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
1056−isInsideSrcDirByName names srcDir =
887+isInsideSrcDirsHelp segments srcDir =
1057− File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1058−
1059−
1060−isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1061−isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
1062 case dropPrefix (FP.splitDirectories srcDir) segments of
888 case dropPrefix (FP.splitDirectories srcDir) segments of
1063 Nothing ->
889 Nothing ->
1064− Nothing
890+ Right Nothing
1065
891
1066 Just names ->
892 Just names ->
1067 if all isGoodName names
893 if all isGoodName names
1068− then Just (srcDir, Right names)
894+ then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
1069− else Just (srcDir, Left names)
895+ else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
1070
896
1071
897
1072isGoodName :: [Char] -> Bool
898isGoodName :: [Char] -> Bool
@@ -1079,8 +905,6 @@ isGoodName name =
1079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
905 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1080
906
1081
907
1082−-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083−--
1084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
908dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1085dropPrefix roots paths =
909dropPrefix roots paths =
1086 case roots of
910 case roots of
@@ -1089,23 +913,23 @@ dropPrefix roots paths =
1089
913
1090 r:rs ->
914 r:rs ->
1091 case paths of
915 case paths of
1092− [] -> Nothing
916+ [] -> Nothing
1093 p:ps -> if r == p then dropPrefix rs ps else Nothing
917 p:ps -> if r == p then dropPrefix rs ps else Nothing
1094
918
1095
919
1096
920
1097−-- CRAWL ROOTS
921+-- CRAWL MAINS
1098
922
1099
923
1100−data RootStatus
924+data MainStatus
1101 = SInside ModuleName.Raw
925 = SInside ModuleName.Raw
1102 | SOutsideOk Details.Local B.ByteString Src.Module
926 | SOutsideOk Details.Local B.ByteString Src.Module
1103 | SOutsideErr Error.Module
927 | SOutsideErr Error.Module
1104
928
1105
929
1106−crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
930+crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1107−crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
931+crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1108− case root of
932+ case given of
1109 LInside name ->
933 LInside name ->
1110 do statusMVar <- newEmptyMVar
934 do statusMVar <- newEmptyMVar
1111 statusDict <- takeMVar mvar
935 statusDict <- takeMVar mvar
@@ -1116,10 +940,10 @@ crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1116 LOutside path ->
940 LOutside path ->
1117 do time <- File.getTime path
941 do time <- File.getTime path
1118 source <- File.readUtf8 path
942 source <- File.readUtf8 path
1119− case Parse.fromByteString projectType source of
943+ case Parse.fromByteString pkg source of
1120 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
944 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1121 do let deps = map Src.getImportName imports
945 do let deps = map Src.getImportName imports
1122− let local = Details.Local path time deps (any isMain values) buildID buildID
946+ let local = Details.Local path time deps (any isMain values)
1123 crawlDeps env mvar deps (SOutsideOk local source modul)
947 crawlDeps env mvar deps (SOutsideOk local source modul)
1124
948
1125 Left syntaxError ->
949 Left syntaxError ->
@@ -1128,36 +952,40 @@ crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1128
952
1129
953
1130
954
1131−-- CHECK ROOTS
955+-- CHECK MAINS
1132
956
1133
957
1134−data RootResult
958+data MainResult
1135 = RInside ModuleName.Raw
959 = RInside ModuleName.Raw
1136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
960 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1137 | ROutsideErr Error.Module
961 | ROutsideErr Error.Module
1138 | ROutsideBlocked
962 | ROutsideBlocked
1139
963
1140
964
1141−checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
965+checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1142−checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
966+checkMain env@(Env _ root _ _ _ _) results pendingMain =
1143− case rootStatus of
967+ case pendingMain of
1144 SInside name ->
968 SInside name ->
1145 return (RInside name)
969 return (RInside name)
1146
970
1147 SOutsideErr err ->
971 SOutsideErr err ->
1148 return (ROutsideErr err)
972 return (ROutsideErr err)
1149
973
1150− SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
974+ SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1151− do depsStatus <- checkDeps root results deps lastCompile
975+ do depsStatus <- checkDeps root results deps
1152 case depsStatus of
976 case depsStatus of
1153 DepsChange ifaces ->
977 DepsChange ifaces ->
1154− compileOutside env local source ifaces modul
978+ return $ compileOutside env local source ifaces modul
1155
979
1156 DepsSame same cached ->
980 DepsSame same cached ->
1157− do maybeLoaded <- loadInterfaces root same cached
981+ do maybeLoaded <- checkCachedInterfaces root cached
1158 case maybeLoaded of
982 case maybeLoaded of
983+ Nothing ->
1159− Nothing -> return ROutsideBlocked
984+ return ROutsideBlocked
985+
986+ Just loaded ->
987+ do let ifaces = Map.union loaded (Map.fromList same)
1160− Just ifaces -> compileOutside env local source ifaces modul
988+ return $ compileOutside env local source ifaces modul
1161
989
1162 DepsBlock ->
990 DepsBlock ->
1163 return ROutsideBlocked
991 return ROutsideBlocked
@@ -1167,54 +995,53 @@ checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
1167 Error.BadImports (toImportErrors env results imports problems)
995 Error.BadImports (toImportErrors env results imports problems)
1168
996
1169
997
1170−compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
998+compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
1171−compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
999+compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1172 let
1000 let
1173− pkg = projectTypeToPkg projectType
1174 name = Src.getName modul
1001 name = Src.getName modul
1175 in
1002 in
1176 case Compile.compile pkg ifaces modul of
1003 case Compile.compile pkg ifaces modul of
1177 Right (Compile.Artifacts canonical annotations objects) ->
1004 Right (Compile.Artifacts canonical annotations objects) ->
1178− do Reporting.report key Reporting.BDone
1179− return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1005+ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1180
1006
1181 Left errors ->
1007 Left errors ->
1008+ ROutsideErr $
1182− return $ ROutsideErr $ Error.Module name path time source errors
1009+ Error.Module name path time source errors
1183
1010
1184
1011
1185
1012
1186-- TO ARTIFACTS
1013-- TO ARTIFACTS
1187
1014
1188
1015
1189−data Root
1016+data Main
1190 = Inside ModuleName.Raw
1017 = Inside ModuleName.Raw
1191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1018 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1192
1019
1193
1020
1194−toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
1021+toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1195−toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
1022+toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1196− case gatherProblemsOrMains results rootResults of
1023+ case gatherProblemsOrMains results mainResults of
1197 Left (NE.List e es) ->
1024 Left (NE.List e es) ->
1198− Left (Exit.BuildBadModules root e es)
1025+ Left (Exit.BuildModuleProblems e es)
1199
1026
1200− Right roots ->
1027+ Right mains ->
1201− Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
1028+ Right $ Artifacts pkg foreigns mains $
1202− Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
1029+ Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1203
1030
1204
1031
1205−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
1032+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1206−gatherProblemsOrMains results (NE.List rootResult rootResults) =
1033+gatherProblemsOrMains results (NE.List mainResult mainResults) =
1207 let
1034 let
1208− addResult result (es, roots) =
1035+ sortMain result (es, mains) =
1209 case result of
1036 case result of
1210− RInside n -> ( es, Inside n : roots)
1037+ RInside n -> ( es, Inside n : mains)
1211− ROutsideOk n i o -> ( es, Outside n i o : roots)
1038+ ROutsideOk n i o -> ( es, Outside n i o : mains)
1212− ROutsideErr e -> (e:es, roots)
1039+ ROutsideErr e -> (e:es, mains)
1213− ROutsideBlocked -> ( es, roots)
1040+ ROutsideBlocked -> ( es, mains)
1214
1041
1215 errors = Map.foldr addErrors [] results
1042 errors = Map.foldr addErrors [] results
1216 in
1043 in
1217− case (rootResult, foldr addResult (errors, []) rootResults) of
1044+ case (mainResult, foldr sortMain (errors, []) mainResults) of
1218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1045 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1219 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1046 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1220 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1047 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
@@ -1229,7 +1056,7 @@ addInside name result modules =
1229 case result of
1056 case result of
1230 RNew _ iface objs _ -> Fresh name iface objs : modules
1057 RNew _ iface objs _ -> Fresh name iface objs : modules
1231 RSame _ iface objs _ -> Fresh name iface objs : modules
1058 RSame _ iface objs _ -> Fresh name iface objs : modules
1232− RCached main _ mvar -> Cached name main mvar : modules
1059+ RCached main mvar -> Cached name main mvar : modules
1233 RNotFound _ -> error (badInside name)
1060 RNotFound _ -> error (badInside name)
1234 RProblem _ -> error (badInside name)
1061 RProblem _ -> error (badInside name)
1235 RBlocked -> error (badInside name)
1062 RBlocked -> error (badInside name)
@@ -1242,9 +1069,9 @@ badInside name =
1242 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1069 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1243
1070
1244
1071
1245−addOutside :: RootResult -> [Module] -> [Module]
1072+addOutside :: MainResult -> [Module] -> [Module]
1246−addOutside root modules =
1073+addOutside main modules =
1247− case root of
1074+ case main of
1248 RInside _ -> modules
1075 RInside _ -> modules
1249 ROutsideOk name iface objs -> Fresh name iface objs : modules
1076 ROutsideOk name iface objs -> Fresh name iface objs : modules
1250 ROutsideErr _ -> modules
1077 ROutsideErr _ -> modules
builder/src/Deps/Diff.hs+4−6
@@ -18,7 +18,7 @@ import qualified Data.List as List
18import qualified Data.Map as Map
18import qualified Data.Map as Map
19import qualified Data.Name as Name
19import qualified Data.Name as Name
20import qualified Data.Set as Set
20import qualified Data.Set as Set
21−import qualified System.Directory as Dir
21+import qualified Data.Utf8 as Utf8
22import System.FilePath ((</>))
22import System.FilePath ((</>))
23
23
24import qualified Deps.Website as Website
24import qualified Deps.Website as Website
@@ -357,8 +357,7 @@ changeMagnitude (Changes added changed removed) =
357
357
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359getDocs cache manager name version =
359getDocs cache manager name version =
360− do let home = Stuff.package cache name version
360+ do let path = Stuff.package cache name version </> "docs.json"
361− let path = home </> "docs.json"
362 exists <- File.exists path
361 exists <- File.exists path
363 if exists
362 if exists
364 then
363 then
@@ -375,9 +374,8 @@ getDocs cache manager name version =
375 Http.get manager url [] Exit.DP_Http $ \body ->
374 Http.get manager url [] Exit.DP_Http $ \body ->
376 case D.fromByteString Docs.decoder body of
375 case D.fromByteString Docs.decoder body of
377 Right docs ->
376 Right docs ->
378− do Dir.createDirectoryIfMissing True home
379− File.writeUtf8 path body
377+ do File.writeUtf8 path body
380 return $ Right docs
378 return $ Right docs
381
379
382 Left _ ->
380 Left _ ->
383− return $ Left $ Exit.DP_Data url body
381+ return $ Left Exit.DP_Data
builder/src/Deps/Registry.hs+7−6
@@ -54,7 +54,11 @@ data KnownVersions =
54
54
55read :: Stuff.PackageCache -> IO (Maybe Registry)
55read :: Stuff.PackageCache -> IO (Maybe Registry)
56read cache =
56read cache =
57− File.readBinary (Stuff.registry cache)
57+ do let path = Stuff.registry cache
58+ exists <- File.exists path
59+ if exists
60+ then File.readBinary path
61+ else return Nothing
58
62
59
63
60
64
@@ -189,14 +193,11 @@ getVersions' name (Registry _ versions) =
189
193
190post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
194post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
191post manager path decoder callback =
195post manager path decoder callback =
192− let
193− url = Website.route path []
194− in
195− Http.post manager url [] Exit.RP_Http $
196+ Http.post manager (Website.route path []) [] Exit.RP_Http $
196 \body ->
197 \body ->
197 case D.fromByteString decoder body of
198 case D.fromByteString decoder body of
198 Right a -> Right <$> callback a
199 Right a -> Right <$> callback a
199− Left _ -> return $ Left $ Exit.RP_Data url body
200+ Left _ -> return $ Left Exit.RP_Data
200
201
201
202
202
203
builder/src/Deps/Solver.hs+29−31
@@ -94,7 +94,6 @@ data Details =
94
94
95verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
95verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96verify cache connection registry constraints =
96verify cache connection registry constraints =
97− Stuff.withRegistryLock cache $
98 case try constraints of
97 case try constraints of
99 Solver solver ->
98 Solver solver ->
100 solver (State cache connection registry Map.empty)
99 solver (State cache connection registry Map.empty)
@@ -131,7 +130,6 @@ data AppSolution =
131
130
132addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
131addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
133addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
132addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134− Stuff.withRegistryLock cache $
135 let
133 let
136 allIndirects = Map.union indirect testIndirect
134 allIndirects = Map.union indirect testIndirect
137 allDirects = Map.union direct testDirect
135 allDirects = Map.union direct testDirect
@@ -313,11 +311,10 @@ getConstraints pkg vsn =
313 back state
311 back state
314
312
315 Online manager ->
313 Online manager ->
316− do let url = Website.metadata pkg vsn "elm.json"
314+ do result <- Http.get manager (Website.metadata pkg vsn "elm.json") [] id (return . Right)
317− result <- Http.get manager url [] id (return . Right)
318 case result of
315 case result of
319 Left httpProblem ->
316 Left httpProblem ->
320− err (Exit.SolverBadHttp pkg vsn httpProblem)
317+ err (Exit.SolverBadHttp httpProblem)
321
318
322 Right body ->
319 Right body ->
323 case D.fromByteString constraintsDecoder body of
320 case D.fromByteString constraintsDecoder body of
@@ -327,9 +324,11 @@ getConstraints pkg vsn =
327 ok (toNewState cs) cs back
324 ok (toNewState cs) cs back
328
325
329 Left _ ->
326 Left _ ->
330− err (Exit.SolverBadHttpData pkg vsn url)
327+ err (Exit.SolverBadHttpData pkg vsn)
331
328
332
329
330+-- TODO write constraintsDecoder to be a bit faster
331+--
333constraintsDecoder :: D.Decoder () Constraints
332constraintsDecoder :: D.Decoder () Constraints
334constraintsDecoder =
333constraintsDecoder =
335 do outline <- D.mapError (const ()) Outline.decoder
334 do outline <- D.mapError (const ()) Outline.decoder
@@ -351,31 +350,30 @@ data Env =
351
350
352initEnv :: IO (Either Exit.RegistryProblem Env)
351initEnv :: IO (Either Exit.RegistryProblem Env)
353initEnv =
352initEnv =
354− do mvar <- newEmptyMVar
353+ do mvar <- newEmptyMVar
355− _ <- forkIO $ putMVar mvar =<< Http.getManager
354+ _ <- forkIO $ putMVar mvar =<< Http.getManager
356− cache <- Stuff.getPackageCache
355+ cache <- Stuff.getPackageCache
357− Stuff.withRegistryLock cache $
358− do maybeRegistry <- Registry.read cache
356+ maybeRegistry <- Registry.read cache
359− manager <- readMVar mvar
357+ manager <- readMVar mvar
360−
358+
361− case maybeRegistry of
359+ case maybeRegistry of
362− Nothing ->
360+ Nothing ->
363− do eitherRegistry <- Registry.fetch manager cache
361+ do eitherRegistry <- Registry.fetch manager cache
364− case eitherRegistry of
362+ case eitherRegistry of
365− Right latestRegistry ->
363+ Right latestRegistry ->
366− return $ Right $ Env cache manager (Online manager) latestRegistry
364+ return $ Right $ Env cache manager (Online manager) latestRegistry
367−
365+
368− Left problem ->
366+ Left problem ->
369− return $ Left $ problem
367+ return $ Left $ problem
370−
368+
371− Just cachedRegistry ->
369+ Just cachedRegistry ->
372− do eitherRegistry <- Registry.update manager cache cachedRegistry
370+ do eitherRegistry <- Registry.update manager cache cachedRegistry
373− case eitherRegistry of
371+ case eitherRegistry of
374− Right latestRegistry ->
372+ Right latestRegistry ->
375− return $ Right $ Env cache manager (Online manager) latestRegistry
373+ return $ Right $ Env cache manager (Online manager) latestRegistry
376−
374+
377− Left _ ->
375+ Left _ ->
378− return $ Right $ Env cache manager Offline cachedRegistry
376+ return $ Right $ Env cache manager Offline cachedRegistry
379
377
380
378
381
379
builder/src/Elm/Details.hs+70−108
@@ -2,7 +2,6 @@
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3module Elm.Details
3module Elm.Details
4 ( Details(..)
4 ( Details(..)
5− , BuildID
6 , ValidOutline(..)
5 , ValidOutline(..)
7 , Local(..)
6 , Local(..)
8 , Foreign(..)
7 , Foreign(..)
@@ -16,26 +15,22 @@ module Elm.Details
16
15
17import Control.Concurrent (forkIO)
16import Control.Concurrent (forkIO)
18import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
17import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
19−import Control.Monad (liftM, liftM2, liftM3)
18+import Control.Monad (liftM, liftM2, liftM4)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
19import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Either as Either
22import qualified Data.Map as Map
20import qualified Data.Map as Map
23import qualified Data.Map.Utils as Map
21import qualified Data.Map.Utils as Map
24import qualified Data.Map.Merge.Strict as Map
22import qualified Data.Map.Merge.Strict as Map
25−import qualified Data.Maybe as Maybe
26import qualified Data.Name as Name
23import qualified Data.Name as Name
27import qualified Data.NonEmptyList as NE
24import qualified Data.NonEmptyList as NE
28import qualified Data.OneOrMore as OneOrMore
25import qualified Data.OneOrMore as OneOrMore
29import qualified Data.Set as Set
26import qualified Data.Set as Set
30import qualified Data.Utf8 as Utf8
27import qualified Data.Utf8 as Utf8
31−import Data.Word (Word64)
32import qualified System.Directory as Dir
28import qualified System.Directory as Dir
33import System.FilePath ((</>), (<.>))
29import System.FilePath ((</>), (<.>))
34
30
35import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
36import qualified AST.Source as Src
32import qualified AST.Source as Src
37import qualified AST.Optimized as Opt
33import qualified AST.Optimized as Opt
38−import qualified BackgroundWriter as BW
39import qualified Compile
34import qualified Compile
40import qualified Deps.Registry as Registry
35import qualified Deps.Registry as Registry
41import qualified Deps.Solver as Solver
36import qualified Deps.Solver as Solver
@@ -68,42 +63,23 @@ data Details =
68 Details
63 Details
69 { _outlineTime :: File.Time
64 { _outlineTime :: File.Time
70 , _outline :: ValidOutline
65 , _outline :: ValidOutline
71− , _buildID :: BuildID
72 , _locals :: Map.Map ModuleName.Raw Local
66 , _locals :: Map.Map ModuleName.Raw Local
73 , _foreigns :: Map.Map ModuleName.Raw Foreign
67 , _foreigns :: Map.Map ModuleName.Raw Foreign
74 , _extras :: Extras
68 , _extras :: Extras
75 }
69 }
76
70
77
71
78−type BuildID = Word64
72+data ValidOutline
73+ = ValidApp (NE.List FilePath)
74+ | ValidPkg Pkg.Name [ModuleName.Raw]
79
75
80
76
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−--
99data Local =
77data Local =
100 Local
78 Local
101 { _path :: FilePath
79 { _path :: FilePath
102 , _time :: File.Time
80 , _time :: File.Time
103 , _deps :: [ModuleName.Raw]
81 , _deps :: [ModuleName.Raw]
104 , _main :: Bool
82 , _main :: Bool
105− , _lastChange :: BuildID
106− , _lastCompile :: BuildID
107 }
83 }
108
84
109
85
@@ -125,14 +101,14 @@ type Interfaces =
125
101
126
102
127loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
103loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
128−loadObjects root (Details _ _ _ _ _ extras) =
104+loadObjects root (Details _ _ _ _ extras) =
129 case extras of
105 case extras of
130 ArtifactsFresh _ o -> newMVar (Just o)
106 ArtifactsFresh _ o -> newMVar (Just o)
131 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
107 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
132
108
133
109
134loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
110loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
135−loadInterfaces root (Details _ _ _ _ _ extras) =
111+loadInterfaces root (Details _ _ _ _ extras) =
136 case extras of
112 case extras of
137 ArtifactsFresh i _ -> newMVar (Just i)
113 ArtifactsFresh i _ -> newMVar (Just i)
138 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
114 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
@@ -142,11 +118,11 @@ loadInterfaces root (Details _ _ _ _ _ extras) =
142-- VERIFY INSTALL -- used by Install
118-- VERIFY INSTALL -- used by Install
143
119
144
120
145−verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
121+verifyInstall :: FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
146−verifyInstall scope root (Solver.Env cache manager connection registry) outline =
122+verifyInstall root (Solver.Env cache manager connection registry) outline =
147 do time <- File.getTime (root </> "elm.json")
123 do time <- File.getTime (root </> "elm.json")
148 let key = Reporting.ignorer
124 let key = Reporting.ignorer
149− let env = Env key scope root cache manager connection registry
125+ let env = Env key root cache manager connection registry
150 case outline of
126 case outline of
151 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
127 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
152 Outline.App app -> Task.run (verifyApp env time app >> return ())
128 Outline.App app -> Task.run (verifyApp env time app >> return ())
@@ -156,28 +132,28 @@ verifyInstall scope root (Solver.Env cache manager connection registry) outline
156-- LOAD -- used by Make, Repl, Reactor
132-- LOAD -- used by Make, Repl, Reactor
157
133
158
134
159−load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
135+load :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)
160−load style scope root =
136+load style root =
161 do newTime <- File.getTime (root </> "elm.json")
137 do newTime <- File.getTime (root </> "elm.json")
162 maybeDetails <- File.readBinary (Stuff.details root)
138 maybeDetails <- File.readBinary (Stuff.details root)
163 case maybeDetails of
139 case maybeDetails of
164 Nothing ->
140 Nothing ->
165− generate style scope root newTime
141+ generate style root newTime
166
142
167− Just details@(Details oldTime _ buildID _ _ _) ->
143+ Just details@(Details oldTime _ _ _ _) ->
168 if oldTime == newTime
144 if oldTime == newTime
169− then return (Right details { _buildID = buildID + 1 })
145+ then return (Right details)
170− else generate style scope root newTime
146+ else generate style root newTime
171
147
172
148
173
149
174-- GENERATE
150-- GENERATE
175
151
176
152
177−generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
153+generate :: Reporting.Style -> FilePath -> File.Time -> IO (Either Exit.Details Details)
178−generate style scope root time =
154+generate style root time =
179 Reporting.trackDetails style $ \key ->
155 Reporting.trackDetails style $ \key ->
180− do result <- initEnv key scope root
156+ do result <- initEnv key root
181 case result of
157 case result of
182 Left exit ->
158 Left exit ->
183 return (Left exit)
159 return (Left exit)
@@ -195,7 +171,6 @@ generate style scope root time =
195data Env =
171data Env =
196 Env
172 Env
197 { _key :: Reporting.DKey
173 { _key :: Reporting.DKey
198− , _scope :: BW.Scope
199 , _root :: FilePath
174 , _root :: FilePath
200 , _cache :: Stuff.PackageCache
175 , _cache :: Stuff.PackageCache
201 , _manager :: Http.Manager
176 , _manager :: Http.Manager
@@ -204,8 +179,8 @@ data Env =
204 }
179 }
205
180
206
181
207−initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
182+initEnv :: Reporting.DKey -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
208−initEnv key scope root =
183+initEnv key root =
209 do mvar <- fork Solver.initEnv
184 do mvar <- fork Solver.initEnv
210 eitherOutline <- Outline.read root
185 eitherOutline <- Outline.read root
211 case eitherOutline of
186 case eitherOutline of
@@ -219,7 +194,7 @@ initEnv key scope root =
219 return $ Left $ Exit.DetailsCannotGetRegistry problem
194 return $ Left $ Exit.DetailsCannotGetRegistry problem
220
195
221 Right (Solver.Env cache manager connection registry) ->
196 Right (Solver.Env cache manager connection registry) ->
222− return $ Right (Env key scope root cache manager connection registry, outline)
197+ return $ Right (Env key root cache manager connection registry, outline)
223
198
224
199
225
200
@@ -235,8 +210,7 @@ verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm)
235 then
210 then
236 do solution <- verifyConstraints env =<< union noDups direct testDirect
211 do solution <- verifyConstraints env =<< union noDups direct testDirect
237 let exposedList = Outline.flattenExposed exposed
212 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
213+ verifyDependencies env time (ValidPkg pkg exposedList) solution direct
240 else
214 else
241 Task.throw $ Exit.DetailsBadElmInPkg elm
215 Task.throw $ Exit.DetailsBadElmInPkg elm
242
216
@@ -266,7 +240,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
266
240
267
241
268verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
242verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
269−verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
243+verifyConstraints (Env _ _ cache _ connection registry) constraints =
270 do result <- Task.io $ Solver.verify cache connection registry constraints
244 do result <- Task.io $ Solver.verify cache connection registry constraints
271 case result of
245 case result of
272 Solver.Ok details -> return details
246 Solver.Ok details -> return details
@@ -312,30 +286,27 @@ fork work =
312
286
313
287
314verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
288verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
315−verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
289+verifyDependencies env@(Env key root _ _ _ _) time outline solution directDeps =
316 Task.eio id $
290 Task.eio id $
317 do Reporting.report key (Reporting.DStart (Map.size solution))
291 do Reporting.report key (Reporting.DStart (Map.size solution))
318 mvar <- newEmptyMVar
292 mvar <- newEmptyMVar
319− mvars <- Stuff.withRegistryLock cache $
320− Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
293+ mvars <- Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
321 putMVar mvar mvars
294 putMVar mvar mvars
322 deps <- traverse readMVar mvars
295 deps <- traverse readMVar mvars
323 case sequence deps of
296 case sequence deps of
324− Left _ ->
297+ Left problem ->
325− do home <- Stuff.getElmHome
298+ error "TODO verifyDependencies" problem
326− return $ Left $ Exit.DetailsBadDeps home $
327− Maybe.catMaybes $ Either.lefts $ Map.elems deps
328
299
329 Right artifacts ->
300 Right artifacts ->
330 let
301 let
331 objs = Map.foldr addObjects Opt.empty artifacts
302 objs = Map.foldr addObjects Opt.empty artifacts
332 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
303 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
333− foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps
304+ foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
334− details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
305+ details = Details time outline Map.empty foreigns (ArtifactsFresh ifaces objs)
335 in
306 in
336− do BW.writeBinary scope (Stuff.objects root) objs
307+ do File.writeBinary (Stuff.objects root) objs
337− BW.writeBinary scope (Stuff.interfaces root) ifaces
308+ File.writeBinary (Stuff.interfaces root) ifaces
338− BW.writeBinary scope (Stuff.details root) details
309+ File.writeBinary (Stuff.details root) details
339 return (Right details)
310 return (Right details)
340
311
341
312
@@ -375,36 +346,44 @@ data Artifacts =
375
346
376
347
377type Dep =
348type Dep =
378− Either (Maybe Exit.DetailsBadDep) Artifacts
349+ Either Problem Artifacts
350+
351+
352+data Problem
353+ = BadDownload Exit.PackageProblem
354+ | BadBuild
355+ | BadDependency
379
356
380
357
381verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
358verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
382−verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
359+verifyDep (Env key _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
360+ let
383− do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
361+ fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
362+ in
384− exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
363+ do exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
385 if exists
364 if exists
386 then
365 then
387 do Reporting.report key Reporting.DCached
366 do Reporting.report key Reporting.DCached
388 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
367 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
389 case maybeCache of
368 case maybeCache of
390 Nothing ->
369 Nothing ->
391− build key cache depsMVar pkg details fingerprint Set.empty
370+ build key cache depsMVar pkg details (Set.singleton fingerprint)
392
371
393 Just (ArtifactCache fingerprints artifacts) ->
372 Just (ArtifactCache fingerprints artifacts) ->
394 if Set.member fingerprint fingerprints
373 if Set.member fingerprint fingerprints
395 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
374 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
396− else build key cache depsMVar pkg details fingerprint fingerprints
375+ else build key cache depsMVar pkg details (Set.insert fingerprint fingerprints)
397 else
376 else
398 do Reporting.report key Reporting.DRequested
377 do Reporting.report key Reporting.DRequested
399 result <- downloadPackage cache manager pkg vsn
378 result <- downloadPackage cache manager pkg vsn
400 case result of
379 case result of
401− Left problem ->
380+ Left p ->
402 do Reporting.report key (Reporting.DFailed pkg vsn)
381 do Reporting.report key (Reporting.DFailed pkg vsn)
403− return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
382+ return (Left (BadDownload p))
404
383
405 Right () ->
384 Right () ->
406 do Reporting.report key (Reporting.DReceived pkg vsn)
385 do Reporting.report key (Reporting.DReceived pkg vsn)
407− build key cache depsMVar pkg details fingerprint Set.empty
386+ build key cache depsMVar pkg details (Set.singleton fingerprint)
408
387
409
388
410
389
@@ -426,17 +405,17 @@ type Fingerprint =
426-- BUILD
405-- BUILD
427
406
428
407
429−build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
408+build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Dep
430−build key cache depsMVar pkg (Solver.Details vsn _) f fs =
409+build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
431 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
410 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
432 case eitherOutline of
411 case eitherOutline of
433 Left _ ->
412 Left _ ->
434 do Reporting.report key Reporting.DBroken
413 do Reporting.report key Reporting.DBroken
435− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
414+ return (Left BadBuild)
436
415
437 Right (Outline.App _) ->
416 Right (Outline.App _) ->
438 do Reporting.report key Reporting.DBroken
417 do Reporting.report key Reporting.DBroken
439− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
418+ return (Left BadBuild)
440
419
441 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
420 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
442 do allDeps <- readMVar depsMVar
421 do allDeps <- readMVar depsMVar
@@ -444,7 +423,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
444 case sequence directDeps of
423 case sequence directDeps of
445 Left _ ->
424 Left _ ->
446 do Reporting.report key Reporting.DBroken
425 do Reporting.report key Reporting.DBroken
447− return $ Left $ Nothing
426+ return (Left BadDependency)
448
427
449 Right directArtifacts ->
428 Right directArtifacts ->
450 do let src = Stuff.package cache pkg vsn </> "src"
429 do let src = Stuff.package cache pkg vsn </> "src"
@@ -459,7 +438,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
459 case sequence maybeStatuses of
438 case sequence maybeStatuses of
460 Nothing ->
439 Nothing ->
461 do Reporting.report key Reporting.DBroken
440 do Reporting.report key Reporting.DBroken
462− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
441+ return (Left BadBuild)
463
442
464 Just statuses ->
443 Just statuses ->
465 do rmvar <- newEmptyMVar
444 do rmvar <- newEmptyMVar
@@ -469,7 +448,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
469 case sequence maybeResults of
448 case sequence maybeResults of
470 Nothing ->
449 Nothing ->
471 do Reporting.report key Reporting.DBroken
450 do Reporting.report key Reporting.DBroken
472− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
451+ return (Left BadBuild)
473
452
474 Just results ->
453 Just results ->
475 let
454 let
@@ -477,7 +456,6 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
477 ifaces = gatherInterfaces exposedDict results
456 ifaces = gatherInterfaces exposedDict results
478 objects = gatherObjects results
457 objects = gatherObjects results
479 artifacts = Artifacts ifaces objects
458 artifacts = Artifacts ifaces objects
480− fingerprints = Set.insert f fs
481 in
459 in
482 do writeDocs cache pkg vsn docsStatus results
460 do writeDocs cache pkg vsn docsStatus results
483 File.writeBinary path (ArtifactCache fingerprints artifacts)
461 File.writeBinary path (ArtifactCache fingerprints artifacts)
@@ -595,7 +573,7 @@ crawlModule foreignDeps mvar pkg src docsStatus name =
595crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
573crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
596crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
574crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
597 do bytes <- File.readUtf8 path
575 do bytes <- File.readUtf8 path
598− case Parse.fromByteString (Parse.Package pkg) bytes of
576+ case Parse.fromByteString pkg bytes of
599 Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
577 Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
600 do deps <- crawlImports foreignDeps mvar pkg src imports
578 do deps <- crawlImports foreignDeps mvar pkg src imports
601 return (Just (SLocal docsStatus deps modul))
579 return (Just (SLocal docsStatus deps modul))
@@ -747,27 +725,24 @@ toDocs result =
747
725
748downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
726downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
749downloadPackage cache manager pkg vsn =
727downloadPackage cache manager pkg vsn =
750− let
751− url = Website.metadata pkg vsn "endpoint.json"
752− in
753 do eitherByteString <-
728 do eitherByteString <-
754− Http.get manager url [] id (return . Right)
729+ Http.get manager (Website.metadata pkg vsn "endpoint.json") [] id (return . Right)
755
730
756 case eitherByteString of
731 case eitherByteString of
757 Left err ->
732 Left err ->
758− return $ Left $ Exit.PP_BadEndpointRequest err
733+ return (Left (Exit.PP_BadEndpointRequest err))
759
734
760 Right byteString ->
735 Right byteString ->
761 case D.fromByteString endpointDecoder byteString of
736 case D.fromByteString endpointDecoder byteString of
762 Left _ ->
737 Left _ ->
763− return $ Left $ Exit.PP_BadEndpointContent url
738+ return (Left Exit.PP_BadEndpointContent)
764
739
765 Right (endpoint, expectedHash) ->
740 Right (endpoint, expectedHash) ->
766− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
741+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
767 \(sha, archive) ->
742 \(sha, archive) ->
768 if expectedHash == Http.shaToChars sha
743 if expectedHash == Http.shaToChars sha
769 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
744 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
770− else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
745+ else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
771
746
772
747
773endpointDecoder :: D.Decoder e (String, String)
748endpointDecoder :: D.Decoder e (String, String)
@@ -782,40 +757,27 @@ endpointDecoder =
782
757
783
758
784instance Binary Details where
759instance Binary Details where
785− put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
786− get =
787− do a <- get
788− b <- get
789− c <- get
790− d <- get
791− e <- get
792− return (Details a b c d e ArtifactsCached)
760+ get = do { a <- get; b <- get; c <- get; d <- get; return (Details a b c d ArtifactsCached) }
761+ put (Details a b c d _) = put a >> put b >> put c >> put d
793
762
794
763
795instance Binary ValidOutline where
764instance Binary ValidOutline where
796 put outline =
765 put outline =
797 case outline of
766 case outline of
798− ValidApp a -> putWord8 0 >> put a
767+ ValidApp a -> putWord8 0 >> put a
799− ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
768+ ValidPkg a b -> putWord8 1 >> put a >> put b
800
769
801 get =
770 get =
802 do n <- getWord8
771 do n <- getWord8
803 case n of
772 case n of
804 0 -> liftM ValidApp get
773 0 -> liftM ValidApp get
805− 1 -> liftM3 ValidPkg get get get
774+ 1 -> liftM2 ValidPkg get get
806− _ -> fail "binary encoding of ValidOutline was corrupted"
775+ _ -> error "binary encoding of ValidOutline was corrupted"
807
776
808
777
809instance Binary Local where
778instance Binary Local where
779+ get = liftM4 Local get get get get
810− put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
780+ put (Local a b c d) = put a >> put b >> put c >> put d
811− get =
812− do a <- get
813− b <- get
814− c <- get
815− d <- get
816− e <- get
817− f <- get
818− return (Local a b c d e f)
819
781
820
782
821instance Binary Foreign where
783instance Binary Foreign where
builder/src/Elm/Outline.hs+15−109
@@ -5,7 +5,6 @@ module Elm.Outline
5 , AppOutline(..)
5 , AppOutline(..)
6 , PkgOutline(..)
6 , PkgOutline(..)
7 , Exposed(..)
7 , Exposed(..)
8− , SrcDir(..)
9 , read
8 , read
10 , write
9 , write
11 , encode
10 , encode
@@ -17,14 +16,11 @@ module Elm.Outline
17
16
18
17
19import Prelude hiding (read)
18import Prelude hiding (read)
20−import Control.Monad (filterM, liftM)
19+import Control.Monad (filterM)
21−import Data.Binary (Binary, get, put, getWord8, putWord8)
22import qualified Data.Map as Map
20import qualified Data.Map as Map
23import qualified Data.NonEmptyList as NE
21import qualified Data.NonEmptyList as NE
24−import qualified Data.OneOrMore as OneOrMore
25import Foreign.Ptr (minusPtr)
22import Foreign.Ptr (minusPtr)
26import qualified System.Directory as Dir
23import qualified System.Directory as Dir
27−import qualified System.FilePath as FP
28import System.FilePath ((</>))
24import System.FilePath ((</>))
29
25
30import qualified Elm.Constraint as Con
26import qualified Elm.Constraint as Con
@@ -53,7 +49,7 @@ data Outline
53data AppOutline =
49data AppOutline =
54 AppOutline
50 AppOutline
55 { _app_elm_version :: V.Version
51 { _app_elm_version :: V.Version
56− , _app_source_dirs :: NE.List SrcDir
52+ , _app_source_dirs :: NE.List FilePath
57 , _app_deps_direct :: Map.Map Pkg.Name V.Version
53 , _app_deps_direct :: Map.Map Pkg.Name V.Version
58 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
54 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
59 , _app_test_direct :: Map.Map Pkg.Name V.Version
55 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -79,11 +75,6 @@ data Exposed
79 | ExposedDict [(Json.String, [ModuleName.Raw])]
75 | ExposedDict [(Json.String, [ModuleName.Raw])]
80
76
81
77
82−data SrcDir
83− = AbsoluteSrcDir FilePath
84− | RelativeSrcDir FilePath
85−
86−
87
78
88-- DEFAULTS
79-- DEFAULTS
89
80
@@ -126,7 +117,7 @@ encode outline =
126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
117 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
127 E.object
118 E.object
128 [ "type" ==> E.chars "application"
119 [ "type" ==> E.chars "application"
129− , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
120+ , "source-directories" ==> E.list E.chars (NE.toList srcDirs)
130 , "elm-version" ==> V.encode elm
121 , "elm-version" ==> V.encode elm
131 , "dependencies" ==>
122 , "dependencies" ==>
132 E.object
123 E.object
@@ -174,13 +165,6 @@ encodeDeps encodeValue deps =
174 E.dict Pkg.toJsonString encodeValue deps
165 E.dict Pkg.toJsonString encodeValue deps
175
166
176
167
177−encodeSrcDir :: SrcDir -> E.Value
178−encodeSrcDir srcDir =
179− case srcDir of
180− AbsoluteSrcDir dir -> E.chars dir
181− RelativeSrcDir dir -> E.chars dir
182−
183−
184
168
185-- PARSE AND VERIFY
169-- PARSE AND VERIFY
186
170
@@ -194,72 +178,19 @@ read root =
194
178
195 Right outline ->
179 Right outline ->
196 case outline of
180 case outline of
197− Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
181+ Pkg _ ->
198− return $
199− if Map.notMember Pkg.core deps && pkg /= Pkg.core
200− then Left Exit.OutlineNoPkgCore
201− else Right outline
182+ return $ Right outline
202−
203− App (AppOutline _ srcDirs direct indirect _ _)
204− | Map.notMember Pkg.core direct ->
205− return $ Left Exit.OutlineNoAppCore
206−
207− | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
208− return $ Left Exit.OutlineNoAppJson
209−
210− | otherwise ->
211− do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
212− case map toGiven badDirs of
213− d:ds ->
214− return $ Left (Exit.OutlineHasMissingSrcDirs d ds)
215−
216− [] ->
217− do maybeDups <- detectDuplicates root (NE.toList srcDirs)
218− case maybeDups of
219− Nothing ->
220− return $ Right outline
221−
222− Just (canonicalDir, (dir1,dir2)) ->
223− return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)
224−
225−
226−isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
227−isSrcDirMissing root srcDir =
228− not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
229−
230−
231−toGiven :: SrcDir -> FilePath
232−toGiven srcDir =
233− case srcDir of
234− AbsoluteSrcDir dir -> dir
235− RelativeSrcDir dir -> dir
236
183
184+ App (AppOutline _ srcDirs _ _ _ _) ->
185+ do badDirs <- filterM (isBadSrcDir root) (NE.toList srcDirs)
186+ case badDirs of
187+ [] -> return $ Right outline
188+ d:ds -> return $ Left (Exit.OutlineHasBadSrcDirs d ds)
237
189
238−toAbsolute :: FilePath -> SrcDir -> FilePath
239−toAbsolute root srcDir =
240− case srcDir of
241− AbsoluteSrcDir dir -> dir
242− RelativeSrcDir dir -> root </> dir
243
190
244−
191+isBadSrcDir :: FilePath -> FilePath -> IO Bool
245−detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
192+isBadSrcDir root dir =
246−detectDuplicates root srcDirs =
193+ not <$> Dir.doesDirectoryExist (root </> dir)
247− do pairs <- traverse (toPair root) srcDirs
248− return $ Map.lookupMin $ Map.mapMaybe isDup $
249− Map.fromListWith OneOrMore.more pairs
250−
251−
252−toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
253−toPair root srcDir =
254− do key <- Dir.canonicalizePath (toAbsolute root srcDir)
255− return (key, OneOrMore.one (toGiven srcDir))
256−
257−
258−isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
259−isDup paths =
260− case paths of
261− OneOrMore.One _ -> Nothing
262− OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
263
194
264
195
265
196
@@ -337,16 +268,9 @@ depsDecoder valueDecoder =
337 D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
268 D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
338
269
339
270
340−dirsDecoder :: Decoder (NE.List SrcDir)
271+dirsDecoder :: Decoder (NE.List FilePath)
341dirsDecoder =
272dirsDecoder =
342− fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
273+ fmap Json.toChars <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
343−
344−
345−toSrcDir :: FilePath -> SrcDir
346−toSrcDir path =
347− if FP.isRelative path
348− then RelativeSrcDir path
349− else AbsoluteSrcDir path
350
274
351
275
352
276
@@ -387,21 +311,3 @@ boundParser bound tooLong =
387 if len < bound
311 if len < bound
388 then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
312 then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
389 else cerr row newCol (\_ _ -> tooLong)
313 else cerr row newCol (\_ _ -> tooLong)
390−
391−
392−
393−-- BINARY
394−
395−
396−instance Binary SrcDir where
397− put outline =
398− case outline of
399− AbsoluteSrcDir a -> putWord8 0 >> put a
400− RelativeSrcDir a -> putWord8 1 >> put a
401−
402− get =
403− do n <- getWord8
404− case n of
405− 0 -> liftM AbsoluteSrcDir get
406− 1 -> liftM RelativeSrcDir get
407− _ -> fail "binary encoding of SrcDir was corrupted"
builder/src/File.hs+5−28
@@ -1,7 +1,6 @@
1module File
1module File
2 ( Time
2 ( Time
3 , getTime
3 , getTime
4− , zeroTime
5 , writeBinary
4 , writeBinary
6 , readBinary
5 , readBinary
7 , writeUtf8
6 , writeUtf8
@@ -24,7 +23,6 @@ import qualified Data.ByteString.Builder as B
24import qualified Data.ByteString.Lazy as LBS
23import qualified Data.ByteString.Lazy as LBS
25import qualified Data.Fixed as Fixed
24import qualified Data.Fixed as Fixed
26import qualified Data.List as List
25import qualified Data.List as List
27−import qualified Data.Time.Clock as Time
28import qualified Data.Time.Clock.POSIX as Time
26import qualified Data.Time.Clock.POSIX as Time
29import qualified Foreign.ForeignPtr as FPtr
27import qualified Foreign.ForeignPtr as FPtr
30import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
28import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
@@ -46,15 +44,11 @@ newtype Time = Time Fixed.Pico
46getTime :: FilePath -> IO Time
44getTime :: FilePath -> IO Time
47getTime path =
45getTime path =
48 fmap
46 fmap
47+ (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
49− (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
48+-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
50 (Dir.getModificationTime path)
49 (Dir.getModificationTime path)
51
50
52
51
53−zeroTime :: Time
54−zeroTime =
55− Time 0
56−
57−
58instance Binary.Binary Time where
52instance Binary.Binary Time where
59 put (Time time) = Binary.put time
53 put (Time time) = Binary.put time
60 get = Time <$> Binary.get
54 get = Time <$> Binary.get
@@ -78,21 +72,8 @@ readBinary path =
78 then
72 then
79 do result <- Binary.decodeFileOrFail path
73 do result <- Binary.decodeFileOrFail path
80 case result of
74 case result of
81− Right a ->
82− return (Just a)
75+ Right a -> 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
76+ Left e -> return Nothing
96 else
77 else
97 return Nothing
78 return Nothing
98
79
@@ -190,11 +171,7 @@ writeEntry destination root entry =
190 let
171 let
191 path = drop root (Zip.eRelativePath entry)
172 path = drop root (Zip.eRelativePath entry)
192 in
173 in
193− if List.isPrefixOf "src/" path
174+ if path == "LICENSE" || List.isPrefixOf "src/" path then
194− || path == "LICENSE"
195− || path == "README.md"
196− || path == "elm.json"
197− then
198 if not (null path) && last path == '/'
175 if not (null path) && last path == '/'
199 then Dir.createDirectoryIfMissing True (destination </> path)
176 then Dir.createDirectoryIfMissing True (destination </> path)
200 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
177 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
builder/src/Generate.hsdeleted−211
@@ -1,211 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module Generate
3− ( debug
4− , dev
5− , prod
6− , repl
7− )
8− where
9−
10−
11−import Prelude hiding (cycle, print)
12−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13−import Control.Monad (liftM2)
14−import qualified Data.ByteString.Builder as B
15−import Data.Map ((!))
16−import qualified Data.Map as Map
17−import qualified Data.Maybe as Maybe
18−import qualified Data.Name as N
19−import qualified Data.NonEmptyList as NE
20−
21−import qualified AST.Optimized as Opt
22−import qualified Build
23−import qualified Elm.Compiler.Type.Extract as Extract
24−import qualified Elm.Details as Details
25−import qualified Elm.Interface as I
26−import qualified Elm.ModuleName as ModuleName
27−import qualified Elm.Package as Pkg
28−import qualified File
29−import qualified Generate.JavaScript as JS
30−import qualified Generate.Mode as Mode
31−import qualified Nitpick.Debug as Nitpick
32−import qualified Reporting.Exit as Exit
33−import qualified Reporting.Task as Task
34−import qualified Stuff
35−
36−
37−-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38−-- desireable to have Repl and Reactor to keep foreign objects in memory
39−-- to make things a bit faster?
40−
41−
42−
43−-- GENERATORS
44−
45−
46−type Task a =
47− Task.Task Exit.Generate a
48−
49−
50−debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51−debug root details (Build.Artifacts pkg ifaces roots modules) =
52− do loading <- loadObjects root details modules
53− types <- loadTypes root ifaces modules
54− objects <- finalizeObjects loading
55− let mode = Mode.Dev (Just types)
56− let graph = objectsToGlobalGraph objects
57− let mains = gatherMains pkg objects roots
58− return $ JS.generate mode graph mains
59−
60−
61−dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62−dev root details (Build.Artifacts pkg _ roots modules) =
63− do objects <- finalizeObjects =<< loadObjects root details modules
64− let mode = Mode.Dev Nothing
65− let graph = objectsToGlobalGraph objects
66− let mains = gatherMains pkg objects roots
67− return $ JS.generate mode graph mains
68−
69−
70−prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71−prod root details (Build.Artifacts pkg _ roots modules) =
72− do objects <- finalizeObjects =<< loadObjects root details modules
73− checkForDebugUses objects
74− let graph = objectsToGlobalGraph objects
75− let mode = Mode.Prod (Mode.shortenFieldNames graph)
76− let mains = gatherMains pkg objects roots
77− return $ JS.generate mode graph mains
78−
79−
80−repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81−repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82− do objects <- finalizeObjects =<< loadObjects root details modules
83− let graph = objectsToGlobalGraph objects
84− return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85−
86−
87−
88−-- CHECK FOR DEBUG
89−
90−
91−checkForDebugUses :: Objects -> Task ()
92−checkForDebugUses (Objects _ locals) =
93− case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94− [] -> return ()
95− m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96−
97−
98−
99−-- GATHER MAINS
100−
101−
102−gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103−gatherMains pkg (Objects _ locals) roots =
104− Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105−
106−
107−lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108−lookupMain pkg locals root =
109− let
110− toPair name (Opt.LocalGraph maybeMain _ _) =
111− (,) (ModuleName.Canonical pkg name) <$> maybeMain
112− in
113− case root of
114− Build.Inside name -> toPair name =<< Map.lookup name locals
115− Build.Outside name _ g -> toPair name g
116−
117−
118−
119−-- LOADING OBJECTS
120−
121−
122−data LoadingObjects =
123− LoadingObjects
124− { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125− , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126− }
127−
128−
129−loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130−loadObjects root details modules =
131− Task.io $
132− do mvar <- Details.loadObjects root details
133− mvars <- traverse (loadObject root) modules
134− return $ LoadingObjects mvar (Map.fromList mvars)
135−
136−
137−loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138−loadObject root modul =
139− case modul of
140− Build.Fresh name _ graph ->
141− do mvar <- newMVar (Just graph)
142− return (name, mvar)
143−
144− Build.Cached name _ _ ->
145− do mvar <- newEmptyMVar
146− _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147− return (name, mvar)
148−
149−
150−
151−-- FINALIZE OBJECTS
152−
153−
154−data Objects =
155− Objects
156− { _foreign :: Opt.GlobalGraph
157− , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158− }
159−
160−
161−finalizeObjects :: LoadingObjects -> Task Objects
162−finalizeObjects (LoadingObjects mvar mvars) =
163− Task.eio id $
164− do result <- readMVar mvar
165− results <- traverse readMVar mvars
166− case liftM2 Objects result (sequence results) of
167− Just loaded -> return (Right loaded)
168− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169−
170−
171−objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172−objectsToGlobalGraph (Objects globals locals) =
173− foldr Opt.addLocalGraph globals locals
174−
175−
176−
177−-- LOAD TYPES
178−
179−
180−loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181−loadTypes root ifaces modules =
182− Task.eio id $
183− do mvars <- traverse (loadTypesHelp root) modules
184− let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185− results <- traverse readMVar mvars
186− case sequence results of
187− Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189−
190−
191−loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192−loadTypesHelp root modul =
193− case modul of
194− Build.Fresh name iface _ ->
195− newMVar (Just (Extract.fromInterface name iface))
196−
197− Build.Cached name _ ciMVar ->
198− do cachedInterface <- readMVar ciMVar
199− case cachedInterface of
200− Build.Unneeded ->
201− do mvar <- newEmptyMVar
202− _ <- forkIO $
203− do maybeIface <- File.readBinary (Stuff.elmi root name)
204− putMVar mvar (Extract.fromInterface name <$> maybeIface)
205− return mvar
206−
207− Build.Loaded iface ->
208− newMVar (Just (Extract.fromInterface name iface))
209−
210− Build.Corrupted ->
211− newMVar Nothing
builder/src/Http.hs+1−14
@@ -16,7 +16,6 @@ module Http
16 -- upload
16 -- upload
17 , upload
17 , upload
18 , filePart
18 , filePart
19− , jsonPart
20 , stringPart
19 , stringPart
21 )
20 )
22 where
21 where
@@ -27,7 +26,6 @@ import qualified Codec.Archive.Zip as Zip
27import Control.Exception (SomeException, handle)
26import Control.Exception (SomeException, handle)
28import qualified Data.Binary as Binary
27import qualified Data.Binary as Binary
29import qualified Data.Binary.Get as Binary
28import qualified Data.Binary.Get as Binary
30−import qualified Data.ByteString.Builder as B
31import qualified Data.ByteString.Char8 as BS
29import qualified Data.ByteString.Char8 as BS
32import qualified Data.Digest.Pure.SHA as SHA
30import qualified Data.Digest.Pure.SHA as SHA
33import qualified Data.String as String
31import qualified Data.String as String
@@ -36,10 +34,8 @@ import Network.HTTP.Client
36import Network.HTTP.Client.TLS (tlsManagerSettings)
34import Network.HTTP.Client.TLS (tlsManagerSettings)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
35import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38import Network.HTTP.Types.Method (Method, methodGet, methodPost)
36import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
40import qualified Network.HTTP.Client.MultipartFormData as Multi
37import qualified Network.HTTP.Client.MultipartFormData as Multi
41
38
42−import qualified Json.Encode as Encode
43import qualified Elm.Version as V
39import qualified Elm.Version as V
44
40
45
41
@@ -230,15 +226,6 @@ filePart name filePath =
230 Multi.partFileSource (String.fromString name) filePath
226 Multi.partFileSource (String.fromString name) filePath
231
227
232
228
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−
242stringPart :: String -> String -> Multi.Part
229stringPart :: String -> String -> Multi.Part
243stringPart name string =
230stringPart name string =
244− Multi.partBS (String.fromString name) (BS.pack string)
231+ Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hs+12−15
@@ -33,7 +33,7 @@ import qualified Data.ByteString.Builder as B
33import qualified Data.NonEmptyList as NE
33import qualified Data.NonEmptyList as NE
34import qualified System.Exit as Exit
34import qualified System.Exit as Exit
35import qualified System.Info as Info
35import qualified System.Info as Info
36−import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
36+import System.IO (hFlush, hPutStr, stderr, stdout)
37
37
38import qualified Elm.ModuleName as ModuleName
38import qualified Elm.ModuleName as ModuleName
39import qualified Elm.Package as Pkg
39import qualified Elm.Package as Pkg
@@ -364,10 +364,10 @@ toFinalMessage done result =
364
364
365 Left problem ->
365 Left problem ->
366 case problem of
366 case problem of
367− Exit.BuildBadModules _ _ [] ->
367+ Exit.BuildModuleProblems _ [] ->
368 "Detected problems in 1 module."
368 "Detected problems in 1 module."
369
369
370− Exit.BuildBadModules _ _ (_:ps) ->
370+ Exit.BuildModuleProblems _ (_:ps) ->
371 "Detected problems in " ++ show (2 + length ps) ++ " modules."
371 "Detected problems in " ++ show (2 + length ps) ++ " modules."
372
372
373 Exit.BuildProjectProblem _ ->
373 Exit.BuildProjectProblem _ ->
@@ -446,23 +446,20 @@ reportExceptionsNicely e =
446
446
447
447
448putException :: SomeException -> IO ()
448putException :: SomeException -> IO ()
449−putException e = do
449+putException e =
450− hPutStrLn stderr ""
451 Help.toStderr $ D.stack $
450 Help.toStderr $ D.stack $
452− [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
453− , D.reflow $
451+ [ D.reflow $
454− "I ran into something that bypassed the normal error reporting process!\
452+ "Oh no! I ran into something that bypassed the normal error reporting process!\
455 \ I extracted whatever information I could from the internal error:"
453 \ I extracted whatever information I could from the internal error:"
456 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
454 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
457 , D.reflow $
455 , D.reflow $
458− "These errors are usually pretty confusing, so start by asking around on one of\
456+ "These errors are usually pretty confusing, so start by asking around on Slack\
459− \ forums listed at https://elm-lang.org/community to see if anyone can get you\
460− \ unstuck quickly."
457+ \ or Discourse to see if anyone can get you unstuck quickly."
461− , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"
458+ , "------------------------------------------------------------"
462 , D.reflow $
459 , D.reflow $
463− "If you are feeling up to it, please try to get your code down to the smallest\
460+ "From there, if you are feeling up to it, please try to get your code down to the\
464− \ version that still triggers this message. Ideally in a single Main.elm and\
461+ \ smallest version that still triggers this message. Ideally in a single Main.elm\
465− \ elm.json file."
462+ \ and elm.json file."
466 , D.reflow $
463 , D.reflow $
467 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
464 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
468 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
465 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
builder/src/Reporting/Exit.hs+269−1395
@@ -1,26 +1,36 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Exit
2module Reporting.Exit
3+ ( Init(..)
3− ( Init(..), initToReport
4+ , initToReport
5+ --
6+ , Diff(..)
4− , Diff(..), diffToReport
7+ , diffToReport
5− , Make(..), makeToReport
8+ --
9+ , Bump(..)
6− , Bump(..), bumpToReport
10+ , bumpToReport
7− , Repl(..), replToReport
8− , Publish(..), publishToReport
9− , Install(..), installToReport
10− , Reactor(..), reactorToReport
11 , newPackageOverview
11 , newPackageOverview
12 --
12 --
13+ , Publish(..)
14+ , publishToReport
15+ --
16+ , Install(..)
17+ , installToReport
18+ --
13 , Solver(..)
19 , Solver(..)
20+ --
14 , Outline(..)
21 , Outline(..)
15 , OutlineProblem(..)
22 , OutlineProblem(..)
23+ --
16 , Details(..)
24 , Details(..)
17− , DetailsBadDep(..)
18− , PackageProblem(..)
19 , RegistryProblem(..)
25 , RegistryProblem(..)
26+ , PackageProblem(..)
27+ --
28+ , Make(..)
20 , BuildProblem(..)
29 , BuildProblem(..)
21 , BuildProjectProblem(..)
30 , BuildProjectProblem(..)
31+ , makeToReport
32+ --
22 , DocsProblem(..)
33 , DocsProblem(..)
23− , Generate(..)
24 --
34 --
25 , toString
35 , toString
26 , toStderr
36 , toStderr
@@ -29,56 +39,26 @@ module Reporting.Exit
29 where
39 where
30
40
31
41
32−import qualified Data.ByteString as BS
33−import qualified Data.ByteString.UTF8 as BS_UTF8
34import qualified Data.List as List
42import qualified Data.List as List
35−import qualified Data.Map as Map
36−import qualified Data.Name as N
37import qualified Data.NonEmptyList as NE
43import qualified Data.NonEmptyList as NE
38−import qualified Network.HTTP.Client as HTTP
44+import qualified Data.Utf8 as Utf8
39−import qualified Network.HTTP.Types.Header as HTTP
40−import qualified Network.HTTP.Types.Status as HTTP
41−import qualified System.FilePath as FP
42−import System.FilePath ((</>), (<.>))
43
45
44import qualified Elm.Constraint as C
46import qualified Elm.Constraint as C
45import qualified Elm.Magnitude as M
47import qualified Elm.Magnitude as M
46import qualified Elm.ModuleName as ModuleName
48import qualified Elm.ModuleName as ModuleName
47import qualified Elm.Package as Pkg
49import qualified Elm.Package as Pkg
48import qualified Elm.Version as V
50import qualified Elm.Version as V
49−import qualified File
50import qualified Http
51import qualified Http
51import qualified Json.Decode as Decode
52import qualified Json.Decode as Decode
52import qualified Json.Encode as Encode
53import qualified Json.Encode as Encode
53import qualified Json.String as Json
54import qualified Json.String as Json
54import Parse.Primitives (Row, Col)
55import Parse.Primitives (Row, Col)
55−import qualified Reporting.Annotation as A
56import Reporting.Doc ((<>))
56import Reporting.Doc ((<>))
57import qualified Reporting.Doc as D
57import qualified Reporting.Doc as D
58import qualified Reporting.Error.Import as Import
58import qualified Reporting.Error.Import as Import
59import qualified Reporting.Error.Json as Json
59import qualified Reporting.Error.Json as Json
60import qualified Reporting.Exit.Help as Help
60import qualified Reporting.Exit.Help as Help
61import qualified Reporting.Error as Error
61import qualified Reporting.Error as Error
62−import qualified Reporting.Render.Code as Code
63−
64−
65−
66−-- RENDERERS
67−
68−
69−toString :: Help.Report -> String
70−toString report =
71− Help.toString (Help.reportToDoc report)
72−
73−
74−toStderr :: Help.Report -> IO ()
75−toStderr report =
76− Help.toStderr (Help.reportToDoc report)
77−
78−
79−toJson :: Help.Report -> Encode.Value
80−toJson report =
81− Help.reportToJson report
82
62
83
63
84
64
@@ -109,18 +89,13 @@ initToReport exit =
109
89
110 InitNoOfflineSolution pkgs ->
90 InitNoOfflineSolution pkgs ->
111 Help.report "NO OFFLINE SOLUTION" Nothing
91 Help.report "NO OFFLINE SOLUTION" Nothing
112− "I tried to create an elm.json with the following direct dependencies:"
92+ (error "TODO InitNoOfflineSolution" pkgs)
113− [ D.indent 4 $ D.vcat $
93+ (error "TODO InitNoOfflineSolution" pkgs)
114− map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
94+ -- note about Russia IP addresses?
115− , D.reflow $
95+ -- ask if they are on a plane or train
116− "I could not find compatible versions though, but that may be because I could not\
117− \ connect to https://package.elm-lang.org to get the latest list of packages. Are\
118− \ you able to connect to the internet? Please ask around one of the community\
119− \ forums at https://elm-lang.org/community for help!"
120− ]
121
96
122 InitSolverProblem solver ->
97 InitSolverProblem solver ->
123− toSolverReport solver
98+ error "TODO InitSolverProblem" solver
124
99
125 InitAlreadyExists ->
100 InitAlreadyExists ->
126 Help.report "EXISTING PROJECT" Nothing
101 Help.report "EXISTING PROJECT" Nothing
@@ -131,9 +106,8 @@ initToReport exit =
131 ]
106 ]
132 ]
107 ]
133
108
134− InitRegistryProblem problem ->
109+ InitRegistryProblem _ ->
135− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
110+ error "TODO InitRegistryProblem"
136− "I need the list of published packages before I can start initializing projects"
137
111
138
112
139
113
@@ -148,8 +122,8 @@ data Diff
148 | DiffUnpublished
122 | DiffUnpublished
149 | DiffUnknownPackage Pkg.Name [Pkg.Name]
123 | DiffUnknownPackage Pkg.Name [Pkg.Name]
150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
124 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
151− | DiffDocsProblem V.Version DocsProblem
125+ | DiffDocsProblem DocsProblem
152− | DiffMustHaveLatestRegistry RegistryProblem
126+ | DiffBadRegistry RegistryProblem
153 | DiffBadDetails Details
127 | DiffBadDetails Details
154 | DiffBadBuild BuildProblem
128 | DiffBadBuild BuildProblem
155
129
@@ -162,27 +136,16 @@ diffToReport diff =
162 "I cannot find an elm.json so I am not sure what you want me to diff.\
136 "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!"
137 \ 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:"
138 [ 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"
139+ , D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"
166 ]
140 ]
167
141
168− DiffBadOutline outline ->
169− toOutlineReport outline
170−
171 DiffApplication ->
142 DiffApplication ->
172− Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
143+ Help.report "CANNOT DIFF APPLICATIONS" Nothing
173− "Your elm.json says this project is an application, but `elm diff` only works\
144+ "It looks like you are running `elm diff` on an application, but it\
174− \ with packages. That way there are previously published versions of the API to\
145+ \ only makes sense for packages that have been published. That way\
175− \ diff against!"
146+ \ there is a fixed API to diff against."
176 [ D.reflow $ "If you are just curious to see a diff, try running this command:"
147 [ 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"
148+ , D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"
178− ]
179−
180− DiffNoExposed ->
181− Help.report "NO EXPOSED MODULES" (Just "elm.json")
182− "Your elm.json has no \"exposed-modules\" which means there is no public API at\
183− \ all right now! What am I supposed to diff?"
184− [ D.reflow $
185− "Try adding some modules back to the \"exposed-modules\" field."
186 ]
149 ]
187
150
188 DiffUnpublished ->
151 DiffUnpublished ->
@@ -218,19 +181,11 @@ diffToReport diff =
218 , "Want one of those instead?"
181 , "Want one of those instead?"
219 ]
182 ]
220
183
221− DiffDocsProblem version problem ->
184+ DiffDocsProblem problem ->
222− toDocsProblemReport problem $
185+ error "TODO DiffDocsProblem" problem
223− "I need the docs for " ++ V.toChars version ++ " to compute this diff"
224
186
225− DiffMustHaveLatestRegistry problem ->
187+ DiffBadRegistry problem ->
226− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
188+ error "TODO DiffBadRegistry" problem
227− "I need the latest list of published packages before I do this diff"
228−
229− DiffBadDetails details ->
230− toDetailsReport details
231−
232− DiffBadBuild buildProblem ->
233− toBuildProblemReport buildProblem
234
189
235
190
236
191
@@ -244,26 +199,11 @@ data Bump
244 | BumpUnexpectedVersion V.Version [V.Version]
199 | BumpUnexpectedVersion V.Version [V.Version]
245 | BumpMustHaveLatestRegistry RegistryProblem
200 | BumpMustHaveLatestRegistry RegistryProblem
246 | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
201 | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
247− | BumpBadDetails Details
248− | BumpNoExposed
249− | BumpBadBuild BuildProblem
250
202
251
203
252bumpToReport :: Bump -> Help.Report
204bumpToReport :: Bump -> Help.Report
253bumpToReport bump =
205bumpToReport bump =
254 case bump of
206 case bump of
255− BumpNoOutline ->
256− Help.report "BUMP WHAT?" Nothing
257− "I cannot find an elm.json so I am not sure what you want me to bump."
258− [ D.reflow $
259− "Elm packages always have an elm.json that says current the version number. If\
260− \ you run this command from a directory with an elm.json file, I will try to bump\
261− \ the version in there based on the API changes."
262− ]
263−
264− BumpBadOutline outline ->
265− toOutlineReport outline
266−
267 BumpApplication ->
207 BumpApplication ->
268 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
208 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
269 "Your elm.json says this is an application. That means it cannot be published\
209 "Your elm.json says this is an application. That means it cannot be published\
@@ -287,30 +227,10 @@ bumpToReport bump =
287 ]
227 ]
288
228
289 BumpMustHaveLatestRegistry problem ->
229 BumpMustHaveLatestRegistry problem ->
290− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
230+ error "TODO BumpMustHaveLatestRegistry" 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
231
297− BumpBadDetails details ->
232+ BumpCannotFindDocs name version problem ->
298− toDetailsReport details
233+ error "TODO BumpCannotFindDocs" name version problem
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
234
315
235
316
236
@@ -344,7 +264,6 @@ newPackageOverview =
344data Publish
264data Publish
345 = PublishNoOutline
265 = PublishNoOutline
346 | PublishBadOutline Outline
266 | PublishBadOutline Outline
347− | PublishBadDetails Details
348 | PublishMustHaveLatestRegistry RegistryProblem
267 | PublishMustHaveLatestRegistry RegistryProblem
349 | PublishApplication
268 | PublishApplication
350 | PublishNotInitialVersion V.Version
269 | PublishNotInitialVersion V.Version
@@ -356,43 +275,27 @@ data Publish
356 | PublishNoReadme
275 | PublishNoReadme
357 | PublishShortReadme
276 | PublishShortReadme
358 | PublishNoLicense
277 | PublishNoLicense
359− | PublishBuildProblem BuildProblem
360− | PublishMissingTag V.Version
361− | PublishCannotGetTag V.Version Http.Error
278+ | PublishCannotGetTag Http.Error
362− | PublishCannotGetTagData V.Version String BS.ByteString
363 | PublishCannotGetZip Http.Error
279 | PublishCannotGetZip Http.Error
364− | PublishCannotDecodeZip String
280+ | PublishCannotDecodeZip
365− | PublishCannotGetDocs V.Version V.Version DocsProblem
281+ | PublishCannotGetDocs DocsProblem
366 | PublishCannotRegister Http.Error
282 | PublishCannotRegister Http.Error
283+ | PublishMissingTag V.Version
367 | PublishNoGit
284 | PublishNoGit
368 | PublishLocalChanges V.Version
285 | PublishLocalChanges V.Version
369− --
370− | PublishZipBadDetails Details
371− | PublishZipApplication
372− | PublishZipNoExposed
373− | PublishZipBuildProblem BuildProblem
374
286
375
287
376publishToReport :: Publish -> Help.Report
288publishToReport :: Publish -> Help.Report
377publishToReport publish =
289publishToReport publish =
378 case publish of
290 case publish of
379 PublishNoOutline ->
291 PublishNoOutline ->
380− Help.report "PUBLISH WHAT?" Nothing
292+ error "TODO PublishNoOutline"
381− "I cannot find an elm.json so I am not sure what you want me to publish."
382− [ D.reflow $
383− "Elm packages always have an elm.json that states the version number,\
384− \ dependencies, exposed modules, etc."
385− ]
386
293
387− PublishBadOutline outline ->
294+ PublishBadOutline problem ->
388− toOutlineReport outline
295+ error "TODO PublishBadOutline" problem
389−
390− PublishBadDetails problem ->
391− toDetailsReport problem
392
296
393 PublishMustHaveLatestRegistry problem ->
297 PublishMustHaveLatestRegistry problem ->
394− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
298+ error "TODO PublishMustHaveLatestRegistry" problem
395− "I need the latest list of published packages to make sure this is safe to publish"
396
299
397 PublishApplication ->
300 PublishApplication ->
398 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
301 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
@@ -497,8 +400,7 @@ publishToReport publish =
497 ]
400 ]
498 )
401 )
499 [ D.reflow $
402 [ D.reflow $
500− "Which modules do you want users of the package to have access to? Add their\
403+ "What is the point of a package that has no modules?!"
501− \ names to the \"exposed-modules\" list."
502 ]
404 ]
503
405
504 PublishNoReadme ->
406 PublishNoReadme ->
@@ -524,8 +426,20 @@ publishToReport publish =
524 \ named LICENSE. Add that file and you will be all set!"
426 \ named LICENSE. Add that file and you will be all set!"
525 ]
427 ]
526
428
527− PublishBuildProblem buildProblem ->
429+ PublishCannotGetTag httpError ->
528− toBuildProblemReport buildProblem
430+ error "TODO PublishCannotGetTag" httpError
431+
432+ PublishCannotGetZip httpError ->
433+ error "TODO PublishCannotGetZip" httpError
434+
435+ PublishCannotDecodeZip ->
436+ error "TODO PublishCannotDecodeZip"
437+
438+ PublishCannotGetDocs docsProblem ->
439+ error "TODO PublishCannotGetDocs" docsProblem
440+
441+ PublishCannotRegister httpError ->
442+ error "TODO PublishCannotRegister" httpError
529
443
530 PublishMissingTag version ->
444 PublishMissingTag version ->
531 let vsn = V.toChars version in
445 let vsn = V.toChars version in
@@ -546,70 +460,6 @@ publishToReport publish =
546 , "The -m flag is for a helpful message. Try to make it more informative!"
460 , "The -m flag is for a helpful message. Try to make it more informative!"
547 ]
461 ]
548
462
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 ->
463 PublishNoGit ->
614 Help.report "NO GIT" Nothing
464 Help.report "NO GIT" Nothing
615 "I searched your PATH environment variable for `git` and could not\
465 "I searched your PATH environment variable for `git` and could not\
@@ -639,18 +489,6 @@ publishToReport publish =
639 ++ vsn ++ "` and publish your code from there."
489 ++ vsn ++ "` and publish your code from there."
640 ]
490 ]
641
491
642− PublishZipBadDetails _ ->
643− badZipReport
644−
645− PublishZipApplication ->
646− badZipReport
647−
648− PublishZipNoExposed ->
649− badZipReport
650−
651− PublishZipBuildProblem _ ->
652− badZipReport
653−
654
492
655toBadReadmeReport :: String -> String -> Help.Report
493toBadReadmeReport :: String -> String -> Help.Report
656toBadReadmeReport title summary =
494toBadReadmeReport title summary =
@@ -666,24 +504,12 @@ toBadReadmeReport title summary =
666 \ most common usage scenario. Show people what they can expect if\
504 \ most common usage scenario. Show people what they can expect if\
667 \ they learn more!"
505 \ they learn more!"
668 , D.toSimpleNote $
506 , D.toSimpleNote $
669− "By publishing your package, you are inviting people to invest time in\
507+ "By publishing your package, you are inviting people to invest time\
670− \ understanding your work. Spending an hour on your README to communicate your\
508+ \ in understanding your work. Spending an hour to communicate your\
671− \ knowledge more clearly can save the community days or weeks of time in\
509+ \ knowledge more clearly can save the community days or weeks of time\
672− \ aggregate, and saving time in aggregate is the whole point of publishing\
510+ \ in aggregate, and saving time in aggregate is the whole point of\
673− \ packages! People really appreciate it, and it makes the whole ecosystem feel\
511+ \ publishing packages! People really appreciate it, and it makes the\
674− \ nicer!"
512+ \ whole ecosystem feel nicer!"
675− ]
676−
677−
678−badZipReport :: Help.Report
679−badZipReport =
680− Help.report "PROBLEM VERIFYING PACKAGE" Nothing
681− "Before publishing packages, I download the code from GitHub and try to build it\
682− \ from scratch. That way I can be more confident that it will work for other\
683− \ people too. But I am not able to build it!"
684− [ D.reflow $
685− "I was just able to build your local copy though. Is there some way the version\
686− \ on GitHub could be different?"
687 ]
513 ]
688
514
689
515
@@ -693,80 +519,35 @@ badZipReport =
693
519
694data DocsProblem
520data DocsProblem
695 = DP_Http Http.Error
521 = DP_Http Http.Error
696− | DP_Data String BS.ByteString
522+ | DP_Data
697 | DP_Cache
523 | DP_Cache
698
524
699
525
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
526
735-- INSTALL
527-- INSTALL
736
528
737
529
738data Install
530data Install
739− = InstallNoOutline
531+ = InstallNoProject
740− | InstallBadOutline Outline
741− | InstallBadRegistry RegistryProblem
742 | InstallNoArgs FilePath
532 | InstallNoArgs FilePath
743− | InstallNoOnlineAppSolution Pkg.Name
533+ | InstallNoOnlineSolution
744− | InstallNoOfflineAppSolution Pkg.Name
534+ | InstallNoOfflineSolution
745− | InstallNoOnlinePkgSolution Pkg.Name
746− | InstallNoOfflinePkgSolution Pkg.Name
747 | InstallHadSolverTrouble Solver
535 | InstallHadSolverTrouble Solver
748− | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
536+ | InstallUnknownPackageOnline [Pkg.Name]
749− | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
537+ | InstallUnknownPackageOffline [Pkg.Name]
750− | InstallBadDetails Details
538+ | InstallHasBadDetails Details
751
539
752
540
753installToReport :: Install -> Help.Report
541installToReport :: Install -> Help.Report
754installToReport exit =
542installToReport exit =
755 case exit of
543 case exit of
756− InstallNoOutline ->
544+ InstallNoProject ->
757 Help.report "NEW PROJECT?" Nothing
545 Help.report "NEW PROJECT?" Nothing
758 "Are you trying to start a new project? Try this command instead:"
546 "Are you trying to start a new project? Try this command instead:"
759 [ D.indent 4 $ D.green "elm init"
547 [ D.indent 4 $ D.green "elm init"
760 , D.reflow "It will help you get started!"
548 , D.reflow "It will help you get started!"
761 ]
549 ]
762
550
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 ->
551 InstallNoArgs elmHome ->
771 Help.report "INSTALL WHAT?" Nothing
552 Help.report "INSTALL WHAT?" Nothing
772 "I am expecting commands like:"
553 "I am expecting commands like:"
@@ -790,109 +571,50 @@ installToReport exit =
790 ]
571 ]
791 ]
572 ]
792
573
793− InstallNoOnlineAppSolution pkg ->
574+ InstallNoOnlineSolution ->
794− Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
575+ Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO recommend using solver in `elm reactor`
795− (
576+ "This usually happens if you try to modify dependency constraints by\
796− "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
577+ \ hand. I recommend deleting any dependency you added recently (or all\
797− \ with your existing dependencies."
578+ \ of them if things are bad) and then adding them again with:"
798− )
579+ [ D.indent 4 $ D.green "elm install"
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 $
580 , D.reflow $
804− "This is most likely to happen when a package is not upgraded yet. Maybe a new\
581+ "And do not be afaid to ask for help on Slack if you get stuck!"
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 ]
582 ]
817
583
818− InstallNoOfflineAppSolution pkg ->
584+ InstallNoOfflineSolution ->
819− Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
585+ error "TODO InstallNoOfflineSolution"
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
586
831− InstallNoOnlinePkgSolution pkg ->
587+ InstallHadSolverTrouble solver ->
832− Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
588+ error "TODO InstallHadSolverTrouble" solver
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
589
850− InstallNoOfflinePkgSolution pkg ->
590+ InstallUnknownPackageOnline suggestions ->
851− Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
591+ error "TODO InstallUnknownPackageOnline" suggestions
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
592
863− InstallHadSolverTrouble solver ->
593+ InstallUnknownPackageOffline suggestions ->
864− toSolverReport solver
594+ error "TODO InstallUnknownPackageOffline" suggestions
865
595
866− InstallUnknownPackageOnline pkg suggestions ->
596+ InstallHasBadDetails _ ->
867− Help.docReport "UNKNOWN PACKAGE" Nothing
597+ error "TODO InstallHasBadDetails"
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
598
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
599
894− InstallBadDetails details ->
600+{- TODO detect if library has no 0.19.0 version. Maybe do this on website though?
895− toDetailsReport details
601+ Help.report "OLD DEPENDENCIES" (Just "elm.json")
602+ ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
603+ )
604+ [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
605+ , D.reflow $
606+ "This may be because it is not upgraded yet. It may be because a\
607+ \ better solution came along, so there was no need to upgrade it.\
608+ \ Etc. Try asking around on Slack to learn more about the topic."
609+ , D.toSimpleNote
610+ "Whatever the case, please be kind to the relevant package authors! Having\
611+ \ friendly interactions with users is great motivation, and conversely, getting\
612+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
613+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
614+ \ goals, etc. They face obstacles outside of their technical work you will never\
615+ \ know about, so please assume the best and try to be patient and supportive!"
616+ ]
617+-}
896
618
897
619
898
620
@@ -901,44 +623,8 @@ installToReport exit =
901
623
902data Solver
624data Solver
903 = SolverBadCacheData Pkg.Name V.Version
625 = SolverBadCacheData Pkg.Name V.Version
904− | SolverBadHttpData Pkg.Name V.Version String
626+ | SolverBadHttpData Pkg.Name V.Version
905− | SolverBadHttp Pkg.Name V.Version Http.Error
627+ | SolverBadHttp 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
628
943
629
944
630
@@ -947,11 +633,7 @@ toSolverReport problem =
947
633
948data Outline
634data Outline
949 = OutlineHasBadStructure (Decode.Error OutlineProblem)
635 = OutlineHasBadStructure (Decode.Error OutlineProblem)
950− | OutlineHasMissingSrcDirs FilePath [FilePath]
636+ | OutlineHasBadSrcDirs FilePath [FilePath]
951− | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952− | OutlineNoPkgCore
953− | OutlineNoAppCore
954− | OutlineNoAppJson
955
637
956
638
957data OutlineProblem
639data OutlineProblem
@@ -967,344 +649,97 @@ data OutlineProblem
967 | OP_NoSrcDirs
649 | OP_NoSrcDirs
968
650
969
651
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
652
987− _:_ ->
653+-- DETAILS
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
654
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
655
1027− OutlineNoAppCore ->
656+data Details
1028− Help.report "MISSING DEPENDENCY" (Just "elm.json")
657+ = DetailsCorrupt
1029− "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
658+ | DetailsNoSolution
1030− \ of `List` and `Maybe` do not work without it."
659+ | DetailsNoOfflineSolution
1031− [ D.reflow $
660+ | DetailsSolverProblem Solver
1032− "If you modified your elm.json by hand, try to change it back! And if you are\
661+ | DetailsBadElmInPkg C.Constraint
1033− \ having trouble getting back to a working elm.json, it may be easier to delete it\
662+ | DetailsBadElmInAppOutline V.Version
1034− \ and use `elm init` to start fresh."
663+ | DetailsHandEditedDependencies
1035− ]
664+ | DetailsBadOutline Outline
665+ | DetailsCannotGetRegistry RegistryProblem
666+ | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem
1036
667
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
668
669+data RegistryProblem
670+ = RP_Http Http.Error
671+ | RP_Data
1047
672
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
673
1054− toSnippet title highlight pair =
674+data PackageProblem
1055− Help.jsonReport title (Just path) $
675+ = PP_BadEndpointRequest Http.Error
1056− Code.toSnippet source region highlight pair
676+ | PP_BadEndpointContent
1057− in
677+ | PP_BadArchiveRequest Http.Error
1058− case problem of
678+ | PP_BadArchiveContent
1059− OP_BadType ->
679+ | PP_BadArchiveHash String String
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
680
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
681
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
682
1117− OP_BadConstraint constraintError ->
683+-- MAKE
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
684
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
685
1174− OP_BadModuleHeaderTooLong ->
686+data Make
1175− toSnippet "HEADER TOO LONG" Nothing
687+ = MakeNeedsOutline
1176− ( D.reflow $
688+ | MakeCannotOptimizeAndDebug
1177− "I got stuck while reading your elm.json file. This section header is too long:"
689+ | MakeBlockedByDetailsProblem Details
1178− , D.stack
690+ | MakeAppNeedsFileNames
1179− [ D.fillSep
691+ | MakePkgNeedsExposing
1180− ["I","need","it","to","be"
692+ | MakeMultipleFilesIntoHtml
1181− ,D.green "under",D.green "20",D.green "bytes"
693+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1182− ,"so","it","renders","nicely","on","the","package","website!"
694+ | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
1183− ]
695+ | MakeCannotBuild BuildProblem
1184− , D.toSimpleNote
696+ | MakeCannotLoadArtifacts
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
697
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
698
1210− OP_BadLicense _ suggestions ->
699+data BuildProblem
1211− toSnippet "UNKNOWN LICENSE" Nothing
700+ = BuildModuleProblems Error.Module [Error.Module]
1212− ( D.reflow $
701+ | BuildProjectProblem BuildProjectProblem
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
702
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
703
1245− OP_NoSrcDirs ->
704+data BuildProjectProblem
1246− toSnippet "NO SOURCE DIRECTORIES" Nothing
705+ = BP_PathUnknown FilePath
1247− ( D.reflow $
706+ | BP_WithBadExtension FilePath
1248− "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
707+ | BP_WithAmbiguousSrcDir FilePath FilePath
1249− , D.fillSep
708+ | BP_MainPathDuplicate FilePath FilePath
1250− ["I","need","something","like",D.green "[\"src\"]"
709+ | BP_MainNameDuplicate ModuleName.Raw FilePath FilePath
1251− ,"so","I","know","where","to","look","for","your","modules!"
710+ | BP_CannotLoadDependencies
1252− ]
711+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]
1253− )
712+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
1254
713
1255
714
1256
715
1257−-- DETAILS
716+-- RENDERERS
1258
717
1259
718
1260−data Details
719+toString :: Help.Report -> String
1261− = DetailsNoSolution
720+toString report =
1262− | DetailsNoOfflineSolution
721+ Help.toString (Help.reportToDoc report)
1263− | DetailsSolverProblem Solver
1264− | DetailsBadElmInPkg C.Constraint
1265− | DetailsBadElmInAppOutline V.Version
1266− | DetailsHandEditedDependencies
1267− | DetailsBadOutline Outline
1268− | DetailsCannotGetRegistry RegistryProblem
1269− | DetailsBadDeps FilePath [DetailsBadDep]
1270
722
1271
723
1272−data DetailsBadDep
724+toStderr :: Help.Report -> IO ()
1273− = BD_BadDownload Pkg.Name V.Version PackageProblem
725+toStderr report =
1274− | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)
726+ Help.toStderr (Help.reportToDoc report)
1275
727
1276
728
1277−toDetailsReport :: Details -> Help.Report
729+toJson :: Help.Report -> Encode.Value
1278−toDetailsReport details =
730+toJson report =
1279− case details of
731+ Help.reportToJson report
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
732
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
733
1306− DetailsSolverProblem solver ->
734+
1307− toSolverReport solver
735+-- DETAILS TO REPORT
736+
737+
738+detailsToReport :: Details -> Help.Report
739+detailsToReport details =
740+ case details of
741+ DetailsCorrupt ->
742+ error "TODO DetailsCorrupt"
1308
743
1309 DetailsBadElmInPkg constraint ->
744 DetailsBadElmInPkg constraint ->
1310 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
745 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
@@ -1330,278 +765,32 @@ toDetailsReport details =
1330 ]
765 ]
1331
766
1332 DetailsHandEditedDependencies ->
767 DetailsHandEditedDependencies ->
1333− Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
768+ error "TODO DetailsHandEditedDependencies"
1334− "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
1335− \ party tool) leaving them in an invalid state."
1336− [ D.fillSep
1337− ["Try","to","change","them","back","to","what","they","were","before!"
1338− ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1339− ]
1340− , D.reflow $
1341− "Please ask for help on the community forums if you try those paths and are still\
1342− \ having problems!"
1343− ]
1344
769
1345− DetailsBadOutline outline ->
770+ DetailsBadOutline outlineProblem ->
1346− toOutlineReport outline
771+ toOutlineReport outlineProblem
1347
772
1348 DetailsCannotGetRegistry problem ->
773 DetailsCannotGetRegistry problem ->
1349− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
774+ error "TODO DetailsCannotGetRegistry" problem
1350− "I need the list of published packages to verify your dependencies"
1351−
1352− DetailsBadDeps cacheDir deps ->
1353− case List.sortOn toBadDepRank deps of
1354− [] ->
1355− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1356− "I am not sure what is going wrong though."
1357− [ D.reflow $
1358− "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
1359− \ trying to build again. That will work if some cached files got corrupted\
1360− \ somehow."
1361− , D.reflow $
1362− "If that does not work, go to https://elm-lang.org/community and ask for\
1363− \ help. This is a weird case!"
1364− ]
1365−
1366− d:_ ->
1367− case d of
1368− BD_BadDownload pkg vsn packageProblem ->
1369− toPackageProblemReport pkg vsn packageProblem
1370−
1371− BD_BadBuild pkg vsn fingerprint ->
1372− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1373− "I ran into a compilation error when trying to build the following package:"
1374− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
1375− , D.reflow $
1376− "This probably means it has package constraints that are too wide. It may be\
1377− \ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\
1378− \ over to https://elm-lang.org/community to get help figuring out how to take\
1379− \ this path!"
1380− , D.toSimpleNote $
1381− "To help with the root problem, please report this to the package author along\
1382− \ with the following information:"
1383− , D.indent 4 $ D.vcat $
1384− map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $
1385− Map.toList fingerprint
1386− , D.reflow $
1387− "If you want to help out even more, try building the package locally. That should\
1388− \ give you much more specific information about why this package is failing to\
1389− \ build, which will in turn make it easier for the package author to fix it!"
1390− ]
1391−
1392−
1393−toBadDepRank :: DetailsBadDep -> Int -- lower is better
1394−toBadDepRank badDep =
1395− case badDep of
1396− BD_BadDownload _ _ _ -> 0
1397− BD_BadBuild _ _ _ -> 1
1398−
1399−
1400−
1401−-- PACKAGE PROBLEM
1402−
1403−
1404−data PackageProblem
1405− = PP_BadEndpointRequest Http.Error
1406− | PP_BadEndpointContent String
1407− | PP_BadArchiveRequest Http.Error
1408− | PP_BadArchiveContent String
1409− | PP_BadArchiveHash String String String
1410−
1411−
1412−toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report
1413−toPackageProblemReport pkg vsn problem =
1414− let
1415− thePackage =
1416− Pkg.toChars pkg ++ " " ++ V.toChars vsn
1417− in
1418− case problem of
1419− PP_BadEndpointRequest httpError ->
1420− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1421− "I need to find the latest download link for " ++ thePackage
1422−
1423− PP_BadEndpointContent url ->
1424− Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1425− (
1426− "I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:"
1427− )
1428− [ D.indent 4 $ D.dullyellow $ D.fromChars url
1429− , D.reflow $
1430− "Is something weird with your internet connection. We have gotten reports that\
1431− \ schools, businesses, airports, etc. sometimes intercept requests and add things\
1432− \ to the body or change its contents entirely. Could that be the problem?"
1433− ]
1434
775
1435− PP_BadArchiveRequest httpError ->
776+ DetailsCannotBuildPackage name version problem ->
1436− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
777+ error "TODO DetailsCannotBuildPackage" name version problem
1437− "I was trying to download the source code for " ++ thePackage
1438
778
1439− PP_BadArchiveContent url ->
779+ DetailsNoSolution ->
1440− Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
780+ error "TODO DetailsNoSolution"
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
781
782+ DetailsNoOfflineSolution ->
783+ error "TODO DetailsNoOfflineSolution"
1583
784
785+ DetailsSolverProblem _ ->
786+ error "TODO DetailsSolverProblem"
1584
787
1585−-- MAKE
1586−
1587−
1588−data Make
1589− = MakeNoOutline
1590− | MakeCannotOptimizeAndDebug
1591− | MakeBadDetails Details
1592− | MakeAppNeedsFileNames
1593− | MakePkgNeedsExposing
1594− | MakeMultipleFilesIntoHtml
1595− | MakeNoMain
1596− | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1597− | MakeCannotBuild BuildProblem
1598− | MakeBadGenerate Generate
1599
788
1600
789
1601makeToReport :: Make -> Help.Report
790makeToReport :: Make -> Help.Report
1602makeToReport make =
791makeToReport make =
1603 case make of
792 case make of
1604− MakeNoOutline ->
793+ MakeNeedsOutline ->
1605 Help.report "NO elm.json FILE" Nothing
794 Help.report "NO elm.json FILE" Nothing
1606 "It looks like you are starting a new Elm project. Very exciting! Try running:"
795 "It looks like you are starting a new Elm project. Very exciting! Try running:"
1607 [ D.indent 4 $ D.green $ "elm init"
796 [ D.indent 4 $ D.green $ "elm init"
@@ -1622,344 +811,27 @@ makeToReport make =
1622 \ at once though! Pick just one of those flags and it should work!"
811 \ at once though! Pick just one of those flags and it should work!"
1623 ]
812 ]
1624
813
1625− MakeBadDetails detailsProblem ->
814+ MakeBlockedByDetailsProblem detailsProblem ->
1626− toDetailsReport detailsProblem
815+ detailsToReport detailsProblem
1627
816
1628 MakeAppNeedsFileNames ->
817 MakeAppNeedsFileNames ->
1629 Help.report "NO INPUT" Nothing
818 Help.report "NO INPUT" Nothing
1630− "What should I make though? I need specific files like:"
819+ "What should I make though? I need a specific file like this:"
1631− [ D.vcat
1632− [ D.indent 4 $ D.green "elm make src/Main.elm"
820+ [ 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 $
821+ , D.reflow
1636− "I recommend reading through https://guide.elm-lang.org for guidance on what to\
822+ "However many files you give, I will create one JS file out of them."
1637− \ actually put in those files!"
1638 ]
823 ]
1639
824
1640 MakePkgNeedsExposing ->
825 MakePkgNeedsExposing ->
1641− Help.report "NO INPUT" Nothing
826+ error "TODO MakePkgNeedsExposing"
1642− "What should I make though? I need specific files like:"
1643− [ D.vcat
1644− [ D.indent 4 $ D.green "elm make src/Main.elm"
1645− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1646− ]
1647− , D.reflow $
1648− "You can also entries to the \"exposed-modules\" list in your elm.json file, and\
1649− \ I will try to compile the relevant files."
1650− ]
1651
827
1652 MakeMultipleFilesIntoHtml ->
828 MakeMultipleFilesIntoHtml ->
1653− Help.report "TOO MANY FILES" Nothing
829+ error "TODO MakeMultipleFilesIntoHtml"
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
830
831+ MakeNonMainFilesIntoJavaScript _ _ ->
832+ error "TODO MakeNonMainFilesIntoJavaScript"
1955
833
1956−toGenerateReport :: Generate -> Help.Report
834+ MakeCannotOptimizeDebugValues m ms ->
1957−toGenerateReport problem =
1958− case problem of
1959− GenerateCannotLoadArtifacts ->
1960− corruptCacheReport
1961−
1962− GenerateCannotOptimizeDebugValues m ms ->
1963 Help.report "DEBUG REMNANTS" Nothing
835 Help.report "DEBUG REMNANTS" Nothing
1964 "There are uses of the `Debug` module in the following modules:"
836 "There are uses of the `Debug` module in the following modules:"
1965 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
837 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
@@ -1968,7 +840,7 @@ toGenerateReport problem =
1968 "The issue is that --optimize strips out info needed by `Debug` functions.\
840 "The issue is that --optimize strips out info needed by `Debug` functions.\
1969 \ Here are two examples:"
841 \ Here are two examples:"
1970 , D.indent 4 $ D.reflow $
842 , D.indent 4 $ D.reflow $
1971− "(1) It shortens record field names. This makes the generated JavaScript\
843+ "(1) It shortens record field names. This makes the generated JavaScript is\
1972 \ smaller, but `Debug.toString` cannot know the real field names anymore."
844 \ smaller, but `Debug.toString` cannot know the real field names anymore."
1973 , D.indent 4 $ D.reflow $
845 , D.indent 4 $ D.reflow $
1974 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
846 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
@@ -1981,89 +853,91 @@ toGenerateReport problem =
1981 \ exists!"
853 \ exists!"
1982 ]
854 ]
1983
855
856+ MakeCannotBuild buildProblem ->
857+ case buildProblem of
858+ BuildProjectProblem bp ->
859+ case bp of
860+ BP_PathUnknown _ ->
861+ error "TODO BP_PathUnknown"
1984
862
863+ BP_WithBadExtension _ ->
864+ error "TODO BP_WithBadExtension"
1985
865
1986−-- CORRUPT CACHE
866+ BP_WithAmbiguousSrcDir _ _ ->
867+ error "TODO BP_WithAmbiguousSrcDir"
1987
868
869+ BP_MainPathDuplicate _ _ ->
870+ error "TODO BP_MainPathDuplicate"
1988
871
1989−corruptCacheReport :: Help.Report
872+ BP_MainNameDuplicate _ _ _ ->
1990−corruptCacheReport =
873+ error "TODO BP_MainNameDuplicate"
1991− Help.report "CORRUPT CACHE" Nothing
1992− "It looks like some of the information cached in elm-stuff/ has been corrupted."
1993− [ D.reflow $
1994− "Try deleting your elm-stuff/ directory to get unstuck."
1995− , D.toSimpleNote $
1996− "This almost certainly means that a 3rd party tool (or editor plugin) is\
1997− \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\
1998− \ one by one until you figure out which it is!"
1999− ]
2000
874
875+ BP_CannotLoadDependencies ->
876+ error "TODO BP_CannotLoadDependencies"
2001
877
878+ BP_Cycle name names ->
879+ Help.report "IMPORT CYCLE" Nothing
880+ "Your module imports form a cycle:"
881+ [ D.cycle 4 name names
882+ , D.reflow $
883+ "Learn more about why this is disallowed and how to break cycles here:"
884+ ++ D.makeLink "import-cycles"
885+ ]
2002
886
2003−-- REACTOR
887+ BP_MissingExposed _ ->
888+ error "TODO BP_MissingExposed"
2004
889
890+ BuildModuleProblems p ps ->
891+ Help.compilerReport p ps
2005
892
2006−data Reactor
893+ MakeCannotLoadArtifacts ->
2007− = ReactorNoOutline
894+ error "TODO MakeCannotLoadArtifacts"
2008− | ReactorBadDetails Details
2009− | ReactorBadBuild BuildProblem
2010− | ReactorBadGenerate Generate
2011
895
2012
896
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
897
2023− ReactorBadDetails details ->
898+-- OUTLINE
2024− toDetailsReport details
2025
899
2026− ReactorBadBuild buildProblem ->
2027− toBuildProblemReport buildProblem
2028
900
2029− ReactorBadGenerate generate ->
901+toOutlineReport :: Outline -> Help.Report
2030− toGenerateReport generate
902+toOutlineReport problem =
903+ case problem of
904+ OutlineHasBadSrcDirs dir dirs ->
905+ error "TODO OutlineHasBadSrcDirs" dir dirs
2031
906
907+ OutlineHasBadStructure decodeError ->
908+ error "TODO OutlineHasBadStructure" decodeError toOutlineProblemReport
2032
909
2033
910
2034−-- REPL
911+toOutlineProblemReport :: OutlineProblem -> Help.Report
912+toOutlineProblemReport problem =
913+ case problem of
914+ OP_BadType ->
915+ error "TODO OP_BadType"
2035
916
917+ OP_BadPkgName row col ->
918+ error "TODO OP_BadPkgName" row col
2036
919
2037−data Repl
920+ OP_BadVersion row col ->
2038− = ReplBadDetails Details
921+ error "TODO OP_BadVersion" row col
2039− | ReplBadInput BS.ByteString Error.Error
2040− | ReplBadLocalDeps FilePath Error.Module [Error.Module]
2041− | ReplProjectProblem BuildProjectProblem
2042− | ReplBadGenerate Generate
2043− | ReplBadCache
2044− | ReplBlocked
2045
922
923+ OP_BadConstraint constraintError ->
924+ error "TODO OP_BadConstraint" constraintError
2046
925
2047−replToReport :: Repl -> Help.Report
926+ OP_BadModuleName row col ->
2048−replToReport problem =
927+ error "TODO OP_BadModuleName" row col
2049− case problem of
2050− ReplBadDetails details ->
2051− toDetailsReport details
2052
928
2053− ReplBadInput source err ->
929+ OP_BadModuleHeaderTooLong ->
2054− Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
930+ error "TODO OP_BadModuleHeaderTooLong"
2055
931
2056− ReplBadLocalDeps root e es ->
932+ OP_BadDependencyName row col ->
2057− Help.compilerReport root e es
933+ error "TODO OP_BadDependencyName"
2058
934
2059− ReplProjectProblem projectProblem ->
935+ OP_BadLicense badLicense suggestions ->
2060− toProjectProblemReport projectProblem
936+ error "TODO OP_BadLicense" badLicense suggestions
2061
937
2062− ReplBadGenerate generate ->
938+ OP_BadSummaryTooLong ->
2063− toGenerateReport generate
939+ error "TODO OP_BadSummaryTooLong"
2064
940
2065− ReplBadCache ->
941+ OP_NoSrcDirs ->
2066− corruptCacheReport
942+ error "TODO OP_NoSrcDirs"
2067
943
2068− ReplBlocked ->
2069− corruptCacheReport
builder/src/Reporting/Exit/Assets.hsnew file+227
@@ -0,0 +1,227 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Assets
3+ ( Exit(..)
4+ , ElmJsonProblem(..)
5+ , toReport
6+ , BadElmJsonContent(..)
7+ , badContentToDocs
8+ )
9+ where
10+
11+
12+import qualified Data.Text as Text
13+
14+import qualified Elm.Package as Pkg
15+import Reporting.Doc ((<>))
16+import qualified Reporting.Doc as D
17+import qualified Reporting.Exit.Help as Help
18+
19+
20+
21+-- EXITS
22+
23+
24+data Exit
25+ = BadElmJson ElmJsonProblem
26+ | CorruptElmJson Pkg.Name Pkg.Version
27+ | CorruptDocumentation Pkg.Name Pkg.Version
28+ | CorruptBinary FilePath FilePath
29+
30+
31+
32+-- ELM JSON PROBLEM
33+
34+
35+data ElmJsonProblem
36+ = BadJson D.Doc
37+ | BadSrcDir FilePath
38+ | NoPkgCore
39+ | NoAppCore
40+ | NoAppJson
41+
42+
43+
44+-- TO REPORT
45+
46+
47+toReport :: Exit -> Help.Report
48+toReport exit =
49+ case exit of
50+ CorruptElmJson pkg vsn ->
51+ corruptJsonToReport "elm.json" pkg vsn
52+
53+ CorruptDocumentation pkg vsn ->
54+ corruptJsonToReport "docs.json" pkg vsn
55+
56+ CorruptBinary elmHome path ->
57+ Help.report "CORRUPT BINARY" (Just path)
58+ ("The binary data at " ++ path ++ " is corrupt.")
59+ [ D.reflow "Elm caches build artifacts in the following directories:"
60+ , D.dullyellow $ D.indent 4 $ D.vcat $
61+ [ D.fromString elmHome
62+ , "elm-stuff/"
63+ ]
64+ , D.reflow
65+ "Maybe you recently installed a command line tool or editor plugin that messes\
66+ \ with them? They definitely should not be doing that, but you never know! So\
67+ \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
68+ \ help reveal the corrupting influence."
69+ ]
70+
71+ BadElmJson problem ->
72+ elmJsonProblemToReport problem
73+
74+
75+
76+-- CORRUPT JSON
77+
78+
79+corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
80+corruptJsonToReport path pkg vsn =
81+ Help.report "CORRUPT JSON" Nothing
82+ ( "The " ++ path ++ " for " ++ Pkg.toString pkg
83+ ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
84+ )
85+ [ D.reflow $
86+ "I removed it from my file cache, so if it was some transient\
87+ \ error it should be fixed if you try the same thing again.\
88+ \ Please report this if it seems like an Elm problem though!"
89+ ]
90+
91+
92+
93+-- BAD ELM JSON
94+
95+
96+elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
97+elmJsonProblemToReport problem =
98+ case problem of
99+ BadJson doc ->
100+ Help.jsonReport "BAD JSON" (Just "elm.json") doc
101+
102+ BadSrcDir dir ->
103+ Help.report "BAD JSON" (Just "elm.json")
104+ "The \"source-directories\" in your elm.json lists the following directory:"
105+ [ D.indent 4 (D.dullyellow (D.fromString dir))
106+ , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
107+ ]
108+
109+ NoPkgCore ->
110+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
111+ "A package must have \"elm/core\" as a dependency. Try running:"
112+ [ D.indent 4 $ D.green $ "elm install elm/core"
113+ , D.reflow "I need it for the default imports that make `List` and `Maybe` available."
114+ ]
115+
116+ NoAppCore ->
117+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
118+ "An application must have \"elm/core\" as a dependency. Try running:"
119+ [ D.indent 4 $ D.green $ "elm install elm/core"
120+ , D.reflow "It has some supporting code that is needed by every Elm application!"
121+ ]
122+
123+ NoAppJson ->
124+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
125+ "An application must have \"elm/json\" as a dependency. Try running:"
126+ [ D.indent 4 $ D.green $ "elm install elm/json"
127+ , D.reflow "It helps me handle flags and ports."
128+ ]
129+
130+
131+
132+-- PROBLEM TO DOCS
133+
134+
135+data BadElmJsonContent
136+ = BadType Text.Text
137+ | BadPkgName String
138+ | BadVersion Text.Text
139+ | BadConstraint String
140+ | BadModuleName Text.Text
141+ | BadModuleHeaderTooLong Text.Text
142+ | BadDependencyName Text.Text
143+ | BadLicense Text.Text [Text.Text]
144+ | BadDirectoryNotString
145+ | BadSummaryTooLong
146+
147+
148+badContentToDocs :: BadElmJsonContent -> [D.Doc]
149+badContentToDocs badContent =
150+ case badContent of
151+ BadType _ ->
152+ ["The","only","valid","types","of","elm.json","are"
153+ ,D.green "\"application\"","and",D.green "\"package\"" <> "."
154+ ]
155+
156+ BadPkgName problem ->
157+ map D.fromString (words problem)
158+
159+ BadVersion txt ->
160+ ["You","provided",D.red (D.fromString (show txt))
161+ ,"which","is","not","a","valid","version.","I","need","something","like"
162+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
163+ ]
164+
165+ BadConstraint problem ->
166+ map D.fromString (words ("It is not a valid constraint. " ++ problem))
167+
168+ BadModuleName name ->
169+ ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
170+ ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
171+ ]
172+
173+ BadModuleHeaderTooLong header ->
174+ ["The",D.fromString (show header),"header","is","too","long."
175+ ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
176+ ,"to","ensure","that","formatting","is","nice","on","the","package","website."
177+ ]
178+
179+ BadDependencyName name ->
180+ ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
181+ ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
182+ ,"the","package","website,","and","installing","it","with","the"
183+ ,D.green "`elm install`","command","instead."
184+ ]
185+
186+ BadLicense _given suggestions ->
187+ case suggestions of
188+ [] ->
189+ ["I","need","an","OSI","approved","SPDX","license,","like"
190+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
191+ ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
192+ ]
193+
194+ code:codes ->
195+ ["I","need","an","OSI","approved","SPDX","license."]
196+ ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
197+ ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
198+
199+ BadDirectoryNotString ->
200+ ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
201+ ]
202+
203+ BadSummaryTooLong ->
204+ ["Your","summary","is","too","long.","I","need","it","to"
205+ ,"be",D.green "under",D.green "80",D.green "characters."
206+ ]
207+
208+
209+oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
210+oneOf code codes =
211+ let
212+ toDoc spdx =
213+ D.green (D.fromString (show spdx))
214+ in
215+ case codes of
216+ [] ->
217+ [toDoc code]
218+
219+ [code2] ->
220+ [toDoc code,"or",toDoc code2]
221+
222+ _:_ ->
223+ let
224+ these = code : init codes
225+ final = last codes
226+ in
227+ map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Exit/Crawl.hsnew file+345
@@ -0,0 +1,345 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Crawl
3+ ( Exit(..)
4+ , Problem(..)
5+ , Origin(..)
6+ , SrcDirs(..)
7+ , toReport
8+ )
9+ where
10+
11+
12+import qualified Data.Char as Char
13+import qualified Data.Map as Map
14+import qualified Data.Time.Clock as Time
15+
16+import qualified Elm.Compiler as Compiler
17+import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Package as Pkg
19+import qualified Elm.Version as V
20+import Reporting.Doc ((<+>), (<>))
21+import qualified Reporting.Doc as D
22+import qualified Reporting.Exit.Compile as Compile
23+import qualified Reporting.Exit.Help as Help
24+
25+
26+
27+-- EXIT
28+
29+
30+data Exit
31+ = RootFileNotFound FilePath
32+ | RootModuleNameDuplicate ModuleName.Raw [FilePath]
33+ | RootNameless FilePath
34+ | DependencyProblems Problem [Problem]
35+ | BadKernelHeader FilePath
36+
37+
38+data Problem
39+ = ModuleNotFound Origin ModuleName.Raw SrcDirs
40+ | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]
41+ | BadHeader FilePath Time.UTCTime String Compiler.Error
42+ | ModuleNameReservedForKernel Origin ModuleName.Raw
43+ | ModuleNameMissing FilePath ModuleName.Raw
44+ | ModuleNameMismatch
45+ FilePath
46+ ModuleName.Raw -- expected
47+ ModuleName.Raw -- actual
48+ | PortsInPackage FilePath ModuleName.Raw
49+ | EffectsUnexpected FilePath ModuleName.Raw
50+
51+
52+data Origin
53+ = ElmJson
54+ | File FilePath
55+ | Module FilePath ModuleName.Raw
56+
57+
58+data SrcDirs
59+ = App [FilePath]
60+ | Pkg
61+
62+
63+
64+-- TO REPORT
65+
66+
67+toReport :: Exit -> Help.Report
68+toReport exit =
69+ case exit of
70+ RootFileNotFound path ->
71+ Help.report "FILE NOT FOUND" Nothing
72+ "You want me to compile this file:"
73+ [ D.indent 4 $ D.dullyellow $ D.fromChars path
74+ , "I cannot find it though! Is there a typo?"
75+ ]
76+
77+ RootModuleNameDuplicate name paths ->
78+ Help.report "DUPLICATE NAMES" Nothing
79+ "I am trying to compile multiple modules with the same name:"
80+ [ D.indent 4 $ D.dullyellow $ D.vcat $
81+ map D.fromChars paths
82+ , D.fillSep $
83+ [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
84+ , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."
85+ , "Change", "them", "to", "have", "unique", "names", "and", "you"
86+ , "should", "be", "all", "set!"
87+ ]
88+ ]
89+
90+ RootNameless path ->
91+ namelessToDoc path "Main"
92+
93+ DependencyProblems problem otherProblems ->
94+ case otherProblems of
95+ [] ->
96+ problemToReport problem
97+
98+ _ ->
99+ problemToReport problem
100+ -- error "TODO handle multiple dependency errors"
101+
102+ BadKernelHeader filePath ->
103+ Help.report "BAD KERNEL HEADER" Nothing
104+ "I ran into a bad header in this file:"
105+ [ D.indent 4 $ D.dullyellow $ D.fromChars filePath
106+ , D.reflow $
107+ "NOTE: Kernel code is only available to core Elm libraries to ensure\
108+ \ the portability and security of the Elm ecosystem. This restriction\
109+ \ also makes it possible to improve code gen (i.e. performance) without\
110+ \ disrupting the ecosystem."
111+ ]
112+
113+
114+
115+-- PROBLEM TO REPORT
116+
117+
118+problemToReport :: Problem -> Help.Report
119+problemToReport problem =
120+ case problem of
121+ ModuleNotFound origin name srcDirs ->
122+ notFoundToDoc origin name srcDirs
123+
124+ ModuleAmbiguous origin child paths pkgs ->
125+ ambiguousToDoc origin child paths pkgs
126+
127+ BadHeader path time source compilerError ->
128+ let
129+ compilerExit =
130+ Compile.Exit "???" path time source [compilerError]
131+ in
132+ Help.compilerReport compilerExit []
133+
134+ ModuleNameMissing path name ->
135+ namelessToDoc path name
136+
137+ ModuleNameMismatch path expected actual ->
138+ Help.report "MODULE NAME MISMATCH" (Just path)
139+ ( "The file at " ++ path ++ " has a typo in the module name. It says:"
140+ )
141+ [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"
142+ , "Looks like a typo or copy/paste error. Instead it needs to say:"
143+ , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"
144+ , "Make the change and you should be all set!"
145+ ]
146+
147+ ModuleNameReservedForKernel origin name ->
148+ kernelNameToDoc origin name
149+
150+ PortsInPackage path name ->
151+ badTagToDoc path name "port" "port-modules" $
152+ "Packages cannot have any `port` modules."
153+
154+ EffectsUnexpected path name ->
155+ badTagToDoc path name "effect" "effect-modules" $
156+ "Creating `effect` modules is relatively experimental. There are a\
157+ \ couple in @elm repos right now, but we have decided to be very\
158+ \ cautious in expanding its usage."
159+
160+
161+badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report
162+badTagToDoc path name tag hintName summary =
163+ Help.report
164+ ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
165+ (Just path)
166+ summary
167+ [ D.fillSep $
168+ [ "Get", "rid", "of", "all", "the"
169+ , D.red (D.fromChars tag)
170+ , "stuff", "in"
171+ , D.dullyellow (D.fromChars (ModuleName.nameToChars name))
172+ , "to", "proceed."
173+ ]
174+ , D.toSimpleNote $
175+ "You can learn the reasoning behind this design choice at "
176+ ++ D.makeLink hintName
177+ ]
178+
179+
180+
181+-- NAMELESS
182+
183+
184+namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report
185+namelessToDoc path name =
186+ Help.report "UNNAMED MODULE" (Just path)
187+ ( "The `" ++ ModuleName.nameToChars name
188+ ++ "` module must start with a line like this:"
189+ )
190+ [ D.indent 4 $ D.dullyellow $ D.fromChars $
191+ "module " ++ ModuleName.nameToChars name ++ " exposing (..)"
192+ , D.reflow $
193+ "Try adding that as the first line of your file!"
194+ , D.toSimpleNote $
195+ "It is best to replace (..) with an explicit list of types and\
196+ \ functions you want to expose. If you know a value is only used\
197+ \ WITHIN this module, it is extra easy to refactor. This kind of\
198+ \ information is great, especially as your project grows!"
199+ ]
200+
201+
202+
203+-- NOT FOUND
204+
205+
206+notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report
207+notFoundToDoc origin child srcDirs =
208+ case origin of
209+ ElmJson ->
210+ Help.report "MODULE NOT FOUND" (Just "elm.json")
211+ "Your elm.json says your project has the following module:"
212+ [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child
213+ , D.reflow $
214+ "When creating packages, all modules must live in the src/ directory."
215+ ]
216+
217+ File path ->
218+ Help.report "UNKNOWN IMPORT" (Just path)
219+ ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")
220+ (notFoundDetails child srcDirs)
221+
222+ Module path parent ->
223+ Help.report "UNKNOWN IMPORT" (Just path)
224+ ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")
225+ (notFoundDetails child srcDirs)
226+
227+
228+notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]
229+notFoundDetails child srcDirs =
230+ let
231+ simulatedCode =
232+ D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child
233+ in
234+ case Map.lookup child Pkg.suggestions of
235+ Just pkg ->
236+ [ simulatedCode
237+ , D.reflow $
238+ "Do you want the one from the " ++ Pkg.toChars pkg
239+ ++ " package? If so, run this command to add that dependency to your elm.json file:"
240+ , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg
241+ , case srcDirs of
242+ Pkg ->
243+ D.reflow $
244+ "If you want a local file, make sure the `"
245+ ++ ModuleName.nameToChars child
246+ ++ "` module is in your src/ directory."
247+
248+ App _ ->
249+ D.reflow $
250+ "If you want a local file, make sure the `"
251+ ++ ModuleName.nameToChars child
252+ ++ "` module is in one of the \"source-directories\" listed in your elm.json file."
253+ ]
254+
255+ Nothing ->
256+ [ simulatedCode
257+ , "I cannot find that module! Is there a typo in the module name?"
258+ , D.reflow $
259+ case srcDirs of
260+ Pkg ->
261+ "When creating a package, all modules must live in the src/ directory."
262+
263+ App [] ->
264+ "The \"source-directories\" field of your elm.json is empty, so I only\
265+ \ searched in packages. Maybe you need to add a \"src\" directory there?"
266+
267+ App [dir] ->
268+ "The \"source-directories\" field of your elm.json tells me to only look in the "
269+ ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
270+
271+ App (dir:_:_) ->
272+ "The \"source-directories\" field of your elm.json tells me to look in directories like "
273+ ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
274+ ]
275+
276+
277+ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report
278+ambiguousToDoc origin child paths pkgs =
279+ let
280+ pkgToString (Pkg.Canonical pkg vsn) =
281+ "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
282+
283+ makeReport maybePath summary yellowString =
284+ Help.report "AMBIGUOUS IMPORT" maybePath summary
285+ [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString
286+ , D.reflow $
287+ "I found multiple module with that name though:"
288+ , D.indent 4 $ D.dullyellow $ D.vcat $
289+ map D.fromChars $ paths ++ map pkgToString pkgs
290+ , D.reflow $
291+ if null paths then
292+ "It looks like the name clash is in your dependencies, which is\
293+ \ out of your control. Elm does not support this scenario right\
294+ \ now, but it may be worthwhile. Please open an issue describing\
295+ \ your scenario so we can gather more usage information!"
296+ else
297+ "Which is the right one? Try renaming your modules to have unique names."
298+ ]
299+ in
300+ case origin of
301+ ElmJson ->
302+ makeReport
303+ Nothing
304+ "Your elm.json wants the following module:"
305+ (ModuleName.nameToChars child)
306+
307+ File path ->
308+ makeReport
309+ (Just path)
310+ ("The file at " ++ path ++ " has an ambiguous import:")
311+ ("import " ++ ModuleName.nameToChars child)
312+
313+ Module path parent ->
314+ makeReport
315+ (Just path)
316+ ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")
317+ ("import " ++ ModuleName.nameToChars child)
318+
319+
320+kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report
321+kernelNameToDoc origin kernelName =
322+ let
323+ (maybePath, statement) =
324+ case origin of
325+ ElmJson ->
326+ ( Nothing
327+ , "Your elm.json says your project has the following module:"
328+ )
329+
330+ File path ->
331+ ( Just path
332+ , "This file is trying to import the following module:"
333+ )
334+
335+ Module path parent ->
336+ ( Just path
337+ , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"
338+ )
339+ in
340+ Help.report "BAD MODULE NAME" maybePath statement
341+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName
342+ , D.reflow $
343+ "But names like that are reserved for internal use.\
344+ \ Switch to a name outside of the Elm/Kernel/ namespace."
345+ ]
builder/src/Reporting/Exit/Deps.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Deps
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Constraint as Con
10+import qualified Elm.Package as Pkg
11+import qualified Elm.Version as V
12+import Reporting.Doc ((<>))
13+import qualified Reporting.Doc as D
14+import qualified Reporting.Exit.Help as Help
15+
16+
17+
18+-- EXITS
19+
20+
21+data Exit
22+ = CorruptVersionCache FilePath Pkg.Name
23+ | PackageNotFound Pkg.Name [Pkg.Name]
24+ -- verify
25+ | PkgBadElm Con.Constraint
26+ | AppBadElm V.Version
27+ | AppMissingTrans [(Pkg.Name, V.Version)]
28+ | BadDeps
29+ | BuildFailure FilePath Pkg.Name V.Version
30+
31+
32+
33+-- TO DOC
34+
35+
36+toReport :: Exit -> Help.Report
37+toReport exit =
38+ case exit of
39+ CorruptVersionCache elmHome pkg ->
40+ Help.report "CORRUPT CACHE" Nothing
41+ ( "I ran into an unknown package while exploring dependencies:"
42+ )
43+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg
44+ , D.reflow $
45+ "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
46+ \ Maybe some program is messing with it? It is just cached files,\
47+ \ so you can delete it and see if that fixes the issue."
48+ ]
49+
50+ PackageNotFound package suggestions ->
51+ Help.docReport "PACKAGE NOT FOUND" Nothing
52+ ( D.fillSep
53+ ["I","cannot","find","a"
54+ ,D.red (D.fromUtf8 (Pkg.toString package))
55+ ,"package","on","the","package","website."
56+ ]
57+ )
58+ [ "Maybe you want one of these instead?"
59+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
60+ , "But check <https://package.elm-lang.org> to see all possibilities!"
61+ ]
62+
63+ PkgBadElm constraint ->
64+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
65+ "Your elm.json says this package needs a version of Elm in this range:"
66+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint
67+ , D.fillSep
68+ [ "But", "you", "are", "using", "Elm"
69+ , D.red (D.fromUtf8 (V.toString V.compiler))
70+ , "right", "now."
71+ ]
72+ ]
73+
74+ AppBadElm version ->
75+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
76+ "Your elm.json says this application needs a different version of Elm."
77+ [ D.fillSep
78+ [ "It", "requires"
79+ , D.green (D.fromUtf8 (V.toString version)) <> ","
80+ , "but", "you", "are", "using"
81+ , D.red (D.fromUtf8 (V.toString V.compiler))
82+ , "right", "now."
83+ ]
84+ ]
85+
86+ AppMissingTrans missingDeps ->
87+ let
88+ toEntry (pkg, vsn) =
89+ "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""
90+ in
91+ Help.report "MISSING DEPENDENCIES" (Just "elm.json")
92+ "Your elm.json is missing some \"indirect\" dependencies:"
93+ [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps
94+ , D.fillSep
95+ ["This","usually","means","you","are","editing","elm.json","by","hand."
96+ ,"It","is","much","more","reliable","to","use","the"
97+ ,D.green "elm install","command","instead."
98+ ]
99+ ]
100+
101+ BadDeps ->
102+ Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")
103+ "The dependencies in your elm.json are not compatible."
104+ [ D.fillSep
105+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
106+ ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"
107+ ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."
108+ ]
109+ , D.reflow $
110+ "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
111+ \ you try those paths and still cannot figure it out!"
112+ ]
113+
114+ BuildFailure elmHome pkg vsn ->
115+ Help.report "CORRUPT DEPENDENCY" Nothing
116+ "I ran into a problem while building the following package:"
117+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
118+ , D.fillSep
119+ ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
120+ ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"
121+ ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
122+ ]
123+ ]
builder/src/Reporting/Exit/Help.hs+5−5
@@ -29,7 +29,7 @@ import qualified Reporting.Error as Error
29
29
30
30
31data Report
31data Report
32− = CompilerReport FilePath Error.Module [Error.Module]
32+ = CompilerReport Error.Module [Error.Module]
33 | Report
33 | Report
34 { _title :: String
34 { _title :: String
35 , _path :: Maybe FilePath
35 , _path :: Maybe FilePath
@@ -52,7 +52,7 @@ jsonReport =
52 Report
52 Report
53
53
54
54
55−compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
55+compilerReport :: Error.Module -> [Error.Module] -> Report
56compilerReport =
56compilerReport =
57 CompilerReport
57 CompilerReport
58
58
@@ -64,8 +64,8 @@ compilerReport =
64reportToDoc :: Report -> D.Doc
64reportToDoc :: Report -> D.Doc
65reportToDoc report_ =
65reportToDoc report_ =
66 case report_ of
66 case report_ of
67− CompilerReport root e es ->
67+ CompilerReport e es ->
68− Error.toDoc root e es
68+ Error.toDoc e es
69
69
70 Report title maybePath message ->
70 Report title maybePath message ->
71 let
71 let
@@ -94,7 +94,7 @@ reportToDoc report_ =
94reportToJson :: Report -> E.Value
94reportToJson :: Report -> E.Value
95reportToJson report_ =
95reportToJson report_ =
96 case report_ of
96 case report_ of
97− CompilerReport _ e es ->
97+ CompilerReport e es ->
98 E.object
98 E.object
99 [ "type" ==> E.chars "compile-errors"
99 [ "type" ==> E.chars "compile-errors"
100 , "errors" ==> E.list Error.toJson (e:es)
100 , "errors" ==> E.list Error.toJson (e:es)
builder/src/Reporting/Exit/Http.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Http
3+ ( Exit(..)
4+ , toReport
5+ , BadJson(..)
6+ , badJsonToDocs
7+ )
8+ where
9+
10+
11+import qualified Data.Text as Text
12+
13+import Reporting.Doc ((<>))
14+import qualified Reporting.Doc as D
15+import qualified Reporting.Exit.Help as Help
16+
17+
18+
19+-- EXITS
20+
21+
22+data Exit
23+ = Unknown String
24+ | BadJson String D.Doc
25+ | BadZipData
26+ | BadZipSha String String
27+
28+
29+
30+-- TO REPORT
31+
32+
33+toReport :: String -> Exit -> Help.Report
34+toReport url exit =
35+ let
36+ urlDoc =
37+ D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"
38+ in
39+ case exit of
40+ Unknown message ->
41+ Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
42+ [ urlDoc
43+ , D.stack
44+ [ "Here is the error message I was able to extract:"
45+ , D.indent 4 $ D.reflow message
46+ ]
47+ ]
48+
49+ BadJson path doc ->
50+ Help.jsonReport "UNEXPECTED JSON" (Just path) doc
51+
52+ BadZipData ->
53+ Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
54+ [ urlDoc
55+ , D.reflow $
56+ "If it is a transient issue, it should be fixed if you try this\
57+ \ again. If it seems like an Elm problem, please report it though!"
58+ ]
59+
60+ BadZipSha expectedHash actualHash ->
61+ Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
62+ [ urlDoc
63+ , D.reflow "I check the hash the zip, and it seems off:"
64+ , D.vcat $ map D.fromString $
65+ [ " Expected: " ++ expectedHash
66+ , " Actual: " ++ actualHash
67+ ]
68+ , D.reflow $
69+ "This usually means that the package author moved the version\
70+ \ tag, so report it to them and see if that is the issue. Folks\
71+ \ on Elm slack can probably help as well."
72+ ]
73+
74+
75+
76+-- BAD JSON
77+
78+
79+data BadJson
80+ = BadNewPkg Text.Text
81+ | BadAllPkg Text.Text String
82+ | BadAllVsn Text.Text
83+
84+
85+badJsonToDocs :: BadJson -> [D.Doc]
86+badJsonToDocs badJson =
87+ case badJson of
88+ BadNewPkg txt ->
89+ ["I","ran","into",D.red (D.fromString (show txt)) <> ","
90+ ,"but","I","need","entries","like"
91+ ,D.green "\"elm/core@6.0.0\"" <> "."
92+ ]
93+
94+ BadAllPkg txt suggestion ->
95+ ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
96+ ]
97+ ++ map D.fromString (words suggestion)
98+
99+ BadAllVsn txt ->
100+ ["You","provided",D.red (D.fromString (show txt))
101+ ,"which","is","not","a","valid","version.","I","need","something","like"
102+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
103+ ]
104+
builder/src/Reporting/Task.hs−17
@@ -3,10 +3,8 @@ module Reporting.Task
3 ( Task
3 ( Task
4 , run
4 , run
5 , throw
5 , throw
6− , mapError
7 --
6 --
8 , io
7 , io
9− , mio
10 , eio
8 , eio
11 )
9 )
12 where
10 where
@@ -33,12 +31,6 @@ throw x =
33 Task $ \_ err -> err x
31 Task $ \_ err -> err x
34
32
35
33
36−mapError :: (x -> y) -> Task x a -> Task y a
37−mapError func (Task task) =
38− Task $ \ok err ->
39− task ok (err . func)
40−
41−
42
34
43-- IO
35-- IO
44
36
@@ -49,15 +41,6 @@ io work =
49 Task $ \ok _ -> work >>= ok
41 Task $ \ok _ -> work >>= ok
50
42
51
43
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−
61eio :: (x -> y) -> IO (Either x a) -> Task y a
44eio :: (x -> y) -> IO (Either x a) -> Task y a
62eio func work =
45eio func work =
63 Task $ \ok err ->
46 Task $ \ok err ->
builder/src/Stuff.hs+9−8
@@ -8,8 +8,8 @@ module Stuff
8 , elmo
8 , elmo
9 , temp
9 , temp
10 , findRoot
10 , findRoot
11− , withRootLock
11+ , withProjectLock
12− , withRegistryLock
12+ , withCacheLock
13 , PackageCache
13 , PackageCache
14 , getPackageCache
14 , getPackageCache
15 , registry
15 , registry
@@ -120,16 +120,17 @@ findRootHelp dirs =
120-- LOCKS
120-- LOCKS
121
121
122
122
123−withRootLock :: FilePath -> IO a -> IO a
123+withProjectLock :: FilePath -> IO a -> IO a
124−withRootLock root work =
124+withProjectLock root work =
125 do let dir = stuff root
125 do let dir = stuff root
126 Dir.createDirectoryIfMissing True dir
126 Dir.createDirectoryIfMissing True dir
127− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
127+ Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)
128
128
129
129
130−withRegistryLock :: PackageCache -> IO a -> IO a
130+withCacheLock :: PackageCache -> IO a -> IO a
131−withRegistryLock (PackageCache dir) work =
131+withCacheLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
132+ Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)
133+
133
134
134
135
135
136
cabal.configdeleted−2
@@ -1,2 +0,0 @@
1−profiling: False
2−library-profiling: True
compiler/src/AST/Canonical.hs+2−2
@@ -342,7 +342,7 @@ instance Binary CtorOpts where
342 0 -> return Normal
342 0 -> return Normal
343 1 -> return Enum
343 1 -> return Enum
344 2 -> return Unbox
344 2 -> return Unbox
345− _ -> fail "binary encoding of CtorOpts was corrupted"
345+ _ -> error "binary encoding of CtorOpts was corrupted"
346
346
347
347
348instance Binary Annotation where
348instance Binary Annotation where
@@ -393,7 +393,7 @@ instance Binary AliasType where
393 case n of
393 case n of
394 0 -> liftM Holey get
394 0 -> liftM Holey get
395 1 -> liftM Filled get
395 1 -> liftM Filled get
396− _ -> fail "binary encoding of AliasType was corrupted"
396+ _ -> error "binary encoding of AliasType was corrupted"
397
397
398
398
399instance Binary FieldType where
399instance Binary FieldType where
compiler/src/AST/Optimized.hs+9−9
@@ -135,7 +135,7 @@ data GlobalGraph =
135data LocalGraph =
135data LocalGraph =
136 LocalGraph
136 LocalGraph
137 { _l_main :: Maybe Main
137 { _l_main :: Maybe Main
138− , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
138+ , _l_nodes :: Map.Map Global Node -- TODO profile switching Global to Name
139 , _l_fields :: Map.Map Name Int
139 , _l_fields :: Map.Map Name Int
140 }
140 }
141
141
@@ -308,7 +308,7 @@ instance Binary Expr where
308 24 -> pure Unit
308 24 -> pure Unit
309 25 -> liftM3 Tuple get get get
309 25 -> liftM3 Tuple get get get
310 26 -> liftM3 Shader get get get
310 26 -> liftM3 Shader get get get
311− _ -> fail "problem getting Opt.Expr binary"
311+ _ -> error "problem getting Opt.Expr binary"
312
312
313
313
314instance Binary Def where
314instance Binary Def where
@@ -322,7 +322,7 @@ instance Binary Def where
322 case word of
322 case word of
323 0 -> liftM2 Def get get
323 0 -> liftM2 Def get get
324 1 -> liftM3 TailDef get get get
324 1 -> liftM3 TailDef get get get
325− _ -> fail "problem getting Opt.Def binary"
325+ _ -> error "problem getting Opt.Def binary"
326
326
327
327
328instance Binary Destructor where
328instance Binary Destructor where
@@ -345,7 +345,7 @@ instance Binary Path where
345 1 -> liftM2 Field get get
345 1 -> liftM2 Field get get
346 2 -> liftM Unbox get
346 2 -> liftM Unbox get
347 3 -> liftM Root get
347 3 -> liftM Root get
348− _ -> fail "problem getting Opt.Path binary"
348+ _ -> error "problem getting Opt.Path binary"
349
349
350
350
351instance (Binary a) => Binary (Decider a) where
351instance (Binary a) => Binary (Decider a) where
@@ -361,7 +361,7 @@ instance (Binary a) => Binary (Decider a) where
361 0 -> liftM Leaf get
361 0 -> liftM Leaf get
362 1 -> liftM3 Chain get get get
362 1 -> liftM3 Chain get get get
363 2 -> liftM3 FanOut get get get
363 2 -> liftM3 FanOut get get get
364− _ -> fail "problem getting Opt.Decider binary"
364+ _ -> error "problem getting Opt.Decider binary"
365
365
366
366
367instance Binary Choice where
367instance Binary Choice where
@@ -375,7 +375,7 @@ instance Binary Choice where
375 case word of
375 case word of
376 0 -> liftM Inline get
376 0 -> liftM Inline get
377 1 -> liftM Jump get
377 1 -> liftM Jump get
378− _ -> fail "problem getting Opt.Choice binary"
378+ _ -> error "problem getting Opt.Choice binary"
379
379
380
380
381
381
@@ -400,7 +400,7 @@ instance Binary Main where
400 case word of
400 case word of
401 0 -> return Static
401 0 -> return Static
402 1 -> liftM2 Dynamic get get
402 1 -> liftM2 Dynamic get get
403− _ -> fail "problem getting Opt.Main binary"
403+ _ -> error "problem getting Opt.Main binary"
404
404
405
405
406instance Binary Node where
406instance Binary Node where
@@ -432,7 +432,7 @@ instance Binary Node where
432 8 -> liftM2 Kernel get get
432 8 -> liftM2 Kernel get get
433 9 -> liftM2 PortIncoming get get
433 9 -> liftM2 PortIncoming get get
434 10 -> liftM2 PortOutgoing get get
434 10 -> liftM2 PortOutgoing get get
435− _ -> fail "problem getting Opt.Node binary"
435+ _ -> error "problem getting Opt.Node binary"
436
436
437
437
438instance Binary EffectsType where
438instance Binary EffectsType where
@@ -448,4 +448,4 @@ instance Binary EffectsType where
448 0 -> return Cmd
448 0 -> return Cmd
449 1 -> return Sub
449 1 -> return Sub
450 2 -> return Fx
450 2 -> return Fx
451− _ -> fail "problem getting Opt.EffectsType binary"
451+ _ -> error "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hs+5−5
@@ -195,15 +195,15 @@ newtype Comment =
195
195
196data Exposing
196data Exposing
197 = Open
197 = Open
198− | Explicit [Exposed]
198+ | Explicit [A.Located Exposed]
199
199
200
200
201data Exposed
201data Exposed
202− = Lower (A.Located Name)
202+ = Lower Name
203− | Upper (A.Located Name) Privacy
203+ | Upper Name Privacy
204− | Operator A.Region Name
204+ | Operator Name
205
205
206
206
207data Privacy
207data Privacy
208− = Public A.Region
208+ = Public
209 | Private
209 | Private
compiler/src/AST/Utils/Binop.hs+6−5
@@ -41,11 +41,12 @@ instance Binary Precedence where
41instance Binary Associativity where
41instance Binary Associativity where
42 get =
42 get =
43 do n <- getWord8
43 do n <- getWord8
44+ return $
44− case n of
45+ case n of
45− 0 -> return Left
46+ 0 -> Left
46− 1 -> return Non
47+ 1 -> Non
47− 2 -> return Right
48+ 2 -> Right
48− _ -> fail "Error reading valid associativity from serialized string"
49+ _ -> error "Error reading valid associativity from serialized string"
49
50
50 put assoc =
51 put assoc =
51 putWord8 $
52 putWord8 $
compiler/src/AST/Utils/Shader.hs−2
@@ -74,11 +74,9 @@ escape chars =
74 []
74 []
75
75
76 c:cs
76 c:cs
77− | c == '\r' -> escape cs
78 | c == '\n' -> '\\' : 'n' : escape cs
77 | c == '\n' -> '\\' : 'n' : escape cs
79 | c == '\"' -> '\\' : '"' : escape cs
78 | c == '\"' -> '\\' : '"' : escape cs
80 | c == '\'' -> '\\' : '\'' : escape cs
79 | c == '\'' -> '\\' : '\'' : escape cs
81− | c == '\\' -> '\\' : '\\' : escape cs
82 | otherwise -> c : escape cs
80 | otherwise -> c : escape cs
83
81
84
82
compiler/src/AST/Utils/Type.hs+1
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module AST.Utils.Type
3module AST.Utils.Type
3 ( delambda
4 ( delambda
4 , dealias
5 , dealias
compiler/src/Canonicalize/Environment.hs+20−50
@@ -4,8 +4,6 @@ module Canonicalize.Environment
4 ( Env(..)
4 ( Env(..)
5 , Exposed
5 , Exposed
6 , Qualified
6 , Qualified
7− , Info(..)
8− , mergeInfo
9 , Var(..)
7 , Var(..)
10 , Type(..)
8 , Type(..)
11 , Ctor(..)
9 , Ctor(..)
@@ -22,8 +20,8 @@ module Canonicalize.Environment
22
20
23import qualified Data.Map.Merge.Strict as Map
21import qualified Data.Map.Merge.Strict as Map
24import qualified Data.Map.Strict as Map
22import qualified Data.Map.Strict as Map
23+import qualified Data.Map.Strict.Internal as I
25import qualified Data.Name as Name
24import qualified Data.Name as Name
26−import qualified Data.OneOrMore as OneOrMore
27
25
28import qualified AST.Utils.Binop as Binop
26import qualified AST.Utils.Binop as Binop
29import qualified AST.Canonical as Can
27import qualified AST.Canonical as Can
@@ -60,34 +58,11 @@ data Env =
60
58
61
59
62type Exposed a =
60type Exposed a =
63− Map.Map Name.Name (Info a)
61+ Map.Map Name.Name (Map.Map ModuleName.Canonical a)
64
62
65
63
66type Qualified a =
64type Qualified a =
67− Map.Map Name.Name (Map.Map Name.Name (Info a))
65+ Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))
68−
69−
70−
71−-- INFO
72−
73−
74−data Info a
75− = Specific ModuleName.Canonical a
76− | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77−
78−
79−mergeInfo :: Info a -> Info a -> Info a
80−mergeInfo info1 info2 =
81− case info1 of
82− Specific h1 _ ->
83− case info2 of
84− Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)
85− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86−
87− Ambiguous h1 hs1 ->
88− case info2 of
89− Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
91
66
92
67
93
68
@@ -97,8 +72,7 @@ mergeInfo info1 info2 =
97data Var
72data Var
98 = Local A.Region
73 = Local A.Region
99 | TopLevel A.Region
74 | TopLevel A.Region
100− | Foreign ModuleName.Canonical Can.Annotation
75+ | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
101− | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
102
76
103
77
104
78
@@ -165,10 +139,7 @@ addLocalLeft _ region =
165addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
139addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
166addLocalBoth name region var =
140addLocalBoth name region var =
167 case var of
141 case var of
168− Foreign _ _ ->
142+ Foreign _ ->
169− Result.ok (Local region)
170−
171− Foreigns _ _ ->
172 Result.ok (Local region)
143 Result.ok (Local region)
173
144
174 Local parentRegion ->
145 Local parentRegion ->
@@ -179,18 +150,17 @@ addLocalBoth name region var =
179
150
180
151
181
152
182−
183-- FIND TYPE
153-- FIND TYPE
184
154
185
155
186findType :: A.Region -> Env -> Name.Name -> Result i w Type
156findType :: A.Region -> Env -> Name.Name -> Result i w Type
187findType region (Env _ _ ts _ _ _ qts _) name =
157findType region (Env _ _ ts _ _ _ qts _) name =
188 case Map.lookup name ts of
158 case Map.lookup name ts of
189− Just (Specific _ tipe) ->
159+ Just (I.Bin 1 _ tipe _ _) ->
190 Result.ok tipe
160 Result.ok tipe
191
161
192− Just (Ambiguous h hs) ->
162+ Just homes ->
193− Result.throw (Error.AmbiguousType region Nothing name h hs)
163+ Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
194
164
195 Nothing ->
165 Nothing ->
196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
166 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -201,11 +171,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
201 case Map.lookup prefix qts of
171 case Map.lookup prefix qts of
202 Just qualified ->
172 Just qualified ->
203 case Map.lookup name qualified of
173 case Map.lookup name qualified of
204− Just (Specific _ tipe) ->
174+ Just (I.Bin 1 _ tipe _ _) ->
205 Result.ok tipe
175 Result.ok tipe
206
176
207− Just (Ambiguous h hs) ->
177+ Just homes ->
208− Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
178+ Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
209
179
210 Nothing ->
180 Nothing ->
211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
181 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -221,11 +191,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
221findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
191findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
192findCtor region (Env _ _ _ cs _ _ _ qcs) name =
223 case Map.lookup name cs of
193 case Map.lookup name cs of
224− Just (Specific _ ctor) ->
194+ Just (I.Bin 1 _ ctor _ _) ->
225 Result.ok ctor
195 Result.ok ctor
226
196
227− Just (Ambiguous h hs) ->
197+ Just homes ->
228− Result.throw (Error.AmbiguousVariant region Nothing name h hs)
198+ Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
229
199
230 Nothing ->
200 Nothing ->
231 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
201 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -236,11 +206,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
236 case Map.lookup prefix qcs of
206 case Map.lookup prefix qcs of
237 Just qualified ->
207 Just qualified ->
238 case Map.lookup name qualified of
208 case Map.lookup name qualified of
239− Just (Specific _ pattern) ->
209+ Just (I.Bin 1 _ pattern _ _) ->
240 Result.ok pattern
210 Result.ok pattern
241
211
242− Just (Ambiguous h hs) ->
212+ Just homes ->
243− Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
213+ Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
244
214
245 Nothing ->
215 Nothing ->
246 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
216 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -256,11 +226,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
256findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
226findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
257findBinop region (Env _ _ _ _ binops _ _ _) name =
227findBinop region (Env _ _ _ _ binops _ _ _) name =
258 case Map.lookup name binops of
228 case Map.lookup name binops of
259− Just (Specific _ binop) ->
229+ Just (I.Bin 1 _ binop _ _) ->
260 Result.ok binop
230 Result.ok binop
261
231
262− Just (Ambiguous h hs) ->
232+ Just homes ->
263− Result.throw (Error.AmbiguousBinop region name h hs)
233+ Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
264
234
265 Nothing ->
235 Nothing ->
266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
236 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 =
105
105
106insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
106insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
107insert name region value dict =
107insert name region value dict =
108− Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
108+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
109
109
110
110
111union :: Dict a -> Dict a -> Dict a
111union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+37−49
@@ -35,14 +35,7 @@ type Result i w a =
35createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
35createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
36createInitialEnv home ifaces imports =
36createInitialEnv home ifaces imports =
37 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
37 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
38− Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
38+ Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
39−
40−
41−infoToVar :: Env.Info Can.Annotation -> Env.Var
42−infoToVar info =
43− case info of
44− Env.Specific home tipe -> Env.Foreign home tipe
45− Env.Ambiguous h hs -> Env.Foreigns h hs
46
39
47
40
48
41
@@ -68,7 +61,7 @@ emptyState =
68
61
69emptyTypes :: Env.Exposed Env.Type
62emptyTypes :: Env.Exposed Env.Type
70emptyTypes =
63emptyTypes =
71− Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
64+ Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
72
65
73
66
74
67
@@ -109,8 +102,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
109 (Map.mapMaybeWithKey (unionToType home) unions)
102 (Map.mapMaybeWithKey (unionToType home) unions)
110 (Map.mapMaybeWithKey (aliasToType home) aliases)
103 (Map.mapMaybeWithKey (aliasToType home) aliases)
111
104
112− !vars = Map.map (Env.Specific home) defs
105+ !vars = Map.map (Map.singleton home) defs
113− !types = Map.map (Env.Specific home . fst) rawTypeInfo
106+ !types = Map.map (Map.singleton home . fst) rawTypeInfo
114 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
107 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
115
108
116 !qvs2 = addQualified prefix vars qvs
109 !qvs2 = addQualified prefix vars qvs
@@ -136,7 +129,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
136
129
137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
130addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
138addExposed =
131addExposed =
139− Map.unionWith Env.mergeInfo
132+ Map.unionWith Map.union
140
133
141
134
142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
135addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -157,7 +150,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
157unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
150unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
158 let
151 let
159 addCtor dict (Can.Ctor ctor index _ args) =
152 addCtor dict (Can.Ctor ctor index _ args) =
160− Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
153+ Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
161 in
154 in
162 ( Env.Union (length vars) home
155 ( Env.Union (length vars) home
163 , List.foldl' addCtor Map.empty ctors
156 , List.foldl' addCtor Map.empty ctors
@@ -188,7 +181,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
188 (Can.TAlias home name avars (Can.Filled tipe))
181 (Can.TAlias home name avars (Can.Filled tipe))
189 (Can.fieldsToList fields)
182 (Can.fieldsToList fields)
190 in
183 in
191− Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
184+ Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
192
185
193 _ ->
186 _ ->
194 Map.empty
187 Map.empty
@@ -199,9 +192,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
199-- BINOP
192-- BINOP
200
193
201
194
202−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
195+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
203binopToBinop home op (I.Binop name annotation associativity precedence) =
196binopToBinop home op (I.Binop name annotation associativity precedence) =
204− Env.Specific home (Env.Binop op home name annotation associativity precedence)
197+ Map.singleton home (Env.Binop op home name annotation associativity precedence)
205
198
206
199
207
200
@@ -214,19 +207,19 @@ addExposedValue
214 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
207 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
215 -> Map.Map Name.Name I.Binop
208 -> Map.Map Name.Name I.Binop
216 -> State
209 -> State
217− -> Src.Exposed
210+ -> A.Located Src.Exposed
218 -> Result i w State
211 -> Result i w State
219−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
212+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
220 case exposed of
213 case exposed of
221− Src.Lower (A.At region name) ->
214+ Src.Lower name ->
222 case Map.lookup name vars of
215 case Map.lookup name vars of
223 Just info ->
216 Just info ->
224− Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
217+ Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
225
218
226 Nothing ->
219 Nothing ->
227 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
220 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
228
221
229− Src.Upper (A.At region name) privacy ->
222+ Src.Upper name privacy ->
230 case privacy of
223 case privacy of
231 Src.Private ->
224 Src.Private ->
232 case Map.lookup name types of
225 case Map.lookup name types of
@@ -234,43 +227,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
234 case tipe of
227 case tipe of
235 Env.Union _ _ ->
228 Env.Union _ _ ->
236 let
229 let
237− !ts2 = Map.insert name (Env.Specific home tipe) ts
230+ !ts2 = Map.insert name (Map.singleton home tipe) ts
238 in
231 in
239 Result.ok (State vs ts2 cs bs qvs qts qcs)
232 Result.ok (State vs ts2 cs bs qvs qts qcs)
240
233
241 Env.Alias _ _ _ _ ->
234 Env.Alias _ _ _ _ ->
242 let
235 let
243− !ts2 = Map.insert name (Env.Specific home tipe) ts
236+ !ts2 = Map.insert name (Map.singleton home tipe) ts
244 !cs2 = addExposed cs ctors
237 !cs2 = addExposed cs ctors
245 in
238 in
246 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
239 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
247
240
248 Nothing ->
241 Nothing ->
249− case checkForCtorMistake name types of
242+ case Map.lookup name (toCtors types) of
250− tipe:_ ->
243+ Just tipe ->
251 Result.throw $ Error.ImportCtorByName region name tipe
244 Result.throw $ Error.ImportCtorByName region name tipe
252
245
253− [] ->
246+ Nothing ->
254 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
247 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
255
248
256− Src.Public dotDotRegion ->
249+ Src.Public ->
257 case Map.lookup name types of
250 case Map.lookup name types of
258 Just (tipe, ctors) ->
251 Just (tipe, ctors) ->
259 case tipe of
252 case tipe of
260 Env.Union _ _ ->
253 Env.Union _ _ ->
261 let
254 let
262− !ts2 = Map.insert name (Env.Specific home tipe) ts
255+ !ts2 = Map.insert name (Map.singleton home tipe) ts
263 !cs2 = addExposed cs ctors
256 !cs2 = addExposed cs ctors
264 in
257 in
265 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
258 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
266
259
267 Env.Alias _ _ _ _ ->
260 Env.Alias _ _ _ _ ->
268− Result.throw (Error.ImportOpenAlias dotDotRegion name)
261+ Result.throw (Error.ImportOpenAlias region name)
269
262
270 Nothing ->
263 Nothing ->
271 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
264 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
272
265
273− Src.Operator region op ->
266+ Src.Operator op ->
274 case Map.lookup op binops of
267 case Map.lookup op binops of
275 Just binop ->
268 Just binop ->
276 let
269 let
@@ -282,23 +275,18 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
282 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
275 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
283
276
284
277
278+
285−checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
279+toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
286−checkForCtorMistake givenName types =
280+toCtors types =
287− Map.foldr addMatches [] types
281+ Map.foldr addCtors Map.empty types
288 where
282 where
289− addMatches (_, exposedCtors) matches =
283+ addCtors (_, exposedCtors) dict =
290− Map.foldrWithKey addMatch matches exposedCtors
284+ Map.foldrWithKey addCtor dict exposedCtors
291−
285+
292− addMatch ctorName info matches =
286+ addCtor ctorName homes dict =
293− if ctorName /= givenName
294− then matches
295− else
296− case info of
287+ case Map.elems homes of
297− Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
288+ [Env.Ctor _ tipeName _ _ _] ->
298− tipeName : matches
289+ Map.insert ctorName tipeName dict
299−
290+
300− Env.Specific _ (Env.RecordCtor _ _ _) ->
291+ _ ->
301− matches
292+ dict
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
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112 do arity <- checkUnionFreeVars union
112 do arity <- checkUnionFreeVars union
113− let one = Env.Specific home (Env.Union arity home)
113+ let one = Map.singleton home (Env.Union arity home)
114 Result.ok $ Map.insert name one types
114 Result.ok $ Map.insert name one types
115
115
116
116
@@ -133,7 +133,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134 do args <- checkAliasFreeVars alias
134 do args <- checkAliasFreeVars alias
135 ctype <- Type.canonicalize env tipe
135 ctype <- Type.canonicalize env tipe
136− let one = Env.Specific home (Env.Alias (length args) home args ctype)
136+ let one = Map.singleton home (Env.Alias (length args) home args ctype)
137 let ts1 = Map.insert name one ts
137 let ts1 = Map.insert name one ts
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139
139
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs
281 )
281 )
282
282
283
283
284−type CtorDups = Dups.Dict (Env.Info Env.Ctor)
284+type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
285
285
286
286
287
287
@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297 ,
297 ,
298 case ctipe of
298 case ctipe of
299 Can.TRecord fields Nothing ->
299 Can.TRecord fields Nothing ->
300− Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
300+ Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
301
301
302 _ ->
302 _ ->
303 Dups.none
303 Dups.none
@@ -351,5 +351,5 @@ toOpts ctors =
351
351
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Env.Specific home $
354+ Dups.one name region $ Map.singleton home $
355 Env.Ctor home typeName union index args
355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+7−6
@@ -14,6 +14,7 @@ import Control.Monad (foldM)
14import qualified Data.Graph as Graph
14import qualified Data.Graph as Graph
15import qualified Data.List as List
15import qualified Data.List as List
16import qualified Data.Map.Strict as Map
16import qualified Data.Map.Strict as Map
17+import qualified Data.Map.Strict.Internal as I
17import qualified Data.Name as Name
18import qualified Data.Name as Name
18
19
19import qualified AST.Canonical as Can
20import qualified AST.Canonical as Can
@@ -695,15 +696,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
695 Env.TopLevel _ ->
696 Env.TopLevel _ ->
696 logVar name (Can.VarTopLevel localHome name)
697 logVar name (Can.VarTopLevel localHome name)
697
698
698− Env.Foreign home annotation ->
699+ Env.Foreign (I.Bin 1 home annotation _ _) ->
699 Result.ok $
700 Result.ok $
700 if home == ModuleName.debug then
701 if home == ModuleName.debug then
701 Can.VarDebug localHome name annotation
702 Can.VarDebug localHome name annotation
702 else
703 else
703 Can.VarForeign home name annotation
704 Can.VarForeign home name annotation
704
705
705− Env.Foreigns h hs ->
706+ Env.Foreign homes ->
706− Result.throw (Error.AmbiguousVar region Nothing name h hs)
707+ Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
707
708
708 Nothing ->
709 Nothing ->
709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
710 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -714,15 +715,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
714 case Map.lookup prefix qvs of
715 case Map.lookup prefix qvs of
715 Just qualified ->
716 Just qualified ->
716 case Map.lookup name qualified of
717 case Map.lookup name qualified of
717− Just (Env.Specific home annotation) ->
718+ Just (I.Bin 1 home annotation _ _) ->
718 Result.ok $
719 Result.ok $
719 if home == ModuleName.debug then
720 if home == ModuleName.debug then
720 Can.VarDebug localHome name annotation
721 Can.VarDebug localHome name annotation
721 else
722 else
722 Can.VarForeign home name annotation
723 Can.VarForeign home name annotation
723
724
724− Just (Env.Ambiguous h hs) ->
725+ Just homes ->
725− Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
726+ Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
726
727
727 Nothing ->
728 Nothing ->
728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
729 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
compiler/src/Canonicalize/Module.hs+7−7
@@ -236,11 +236,11 @@ checkExposed
236 -> Map.Map Name.Name alias
236 -> Map.Map Name.Name alias
237 -> Map.Map Name.Name binop
237 -> Map.Map Name.Name binop
238 -> Can.Effects
238 -> Can.Effects
239− -> Src.Exposed
239+ -> A.Located Src.Exposed
240 -> Result i w (Dups.Dict (A.Located Can.Export))
240 -> Result i w (Dups.Dict (A.Located Can.Export))
241−checkExposed values unions aliases binops effects exposed =
241+checkExposed values unions aliases binops effects (A.At region exposed) =
242 case exposed of
242 case exposed of
243− Src.Lower (A.At region name) ->
243+ Src.Lower name ->
244 if Map.member name values then
244 if Map.member name values then
245 ok name region Can.ExportValue
245 ok name region Can.ExportValue
246 else
246 else
@@ -252,23 +252,23 @@ checkExposed values unions aliases binops effects exposed =
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
253 ports ++ Map.keys values
253 ports ++ Map.keys values
254
254
255− Src.Operator region name ->
255+ Src.Operator name ->
256 if Map.member name binops then
256 if Map.member name binops then
257 ok name region Can.ExportBinop
257 ok name region Can.ExportBinop
258 else
258 else
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
260 Map.keys binops
260 Map.keys binops
261
261
262− Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
262+ Src.Upper name Src.Public ->
263 if Map.member name unions then
263 if Map.member name unions then
264 ok name region Can.ExportUnionOpen
264 ok name region Can.ExportUnionOpen
265 else if Map.member name aliases then
265 else if Map.member name aliases then
266− Result.throw $ Error.ExportOpenAlias dotDotRegion name
266+ Result.throw $ Error.ExportOpenAlias region name
267 else
267 else
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
269 Map.keys unions ++ Map.keys aliases
269 Map.keys unions ++ Map.keys aliases
270
270
271− Src.Upper (A.At region name) Src.Private ->
271+ Src.Upper name Src.Private ->
272 if Map.member name unions then
272 if Map.member name unions then
273 ok name region Can.ExportUnionClosed
273 ok name region Can.ExportUnionClosed
274 else if Map.member name aliases then
274 else if Map.member name aliases then
compiler/src/Canonicalize/Pattern.hs+2−3
@@ -8,7 +8,6 @@ module Canonicalize.Pattern
8 where
8 where
9
9
10
10
11−import qualified Data.List as List
12import qualified Data.Map.Strict as Map
11import qualified Data.Map.Strict as Map
13import qualified Data.Name as Name
12import qualified Data.Name as Name
14
13
@@ -174,8 +173,8 @@ logVar name region value =
174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
175logFields fields value =
174logFields fields value =
176 let
175 let
177− addField dict (A.At region name) =
176+ addField (A.At region name) dict =
178 Dups.insert name region region dict
177 Dups.insert name region region dict
179 in
178 in
180 Result.Result $ \bindings warnings _ ok ->
179 Result.Result $ \bindings warnings _ ok ->
181− ok (List.foldl' addField bindings fields) warnings value
180+ ok (foldr addField bindings fields) warnings value
compiler/src/Data/Name.hs+60−60
@@ -19,6 +19,7 @@ module Data.Name
19 , isAppendableType
19 , isAppendableType
20 , isCompappendType
20 , isCompappendType
21 , fromVarIndex
21 , fromVarIndex
22+ , fromReplCount
22 , fromWords
23 , fromWords
23 , fromManyNames
24 , fromManyNames
24 , fromTypeVariable
25 , fromTypeVariable
@@ -31,7 +32,7 @@ module Data.Name
31 , shader, debug, debugger, bitwise, basics
32 , shader, debug, debugger, bitwise, basics
32 , utils, negate, true, false, value
33 , utils, negate, true, false, value
33 , node, program, _main, _Main, dollar, identity
34 , node, program, _main, _Main, dollar, identity
34− , replModule, replValueToPrint
35+ , replModule
35 )
36 )
36 where
37 where
37
38
@@ -44,14 +45,19 @@ import qualified Data.Coerce as Coerce
44import qualified Data.List as List
45import qualified Data.List as List
45import qualified Data.String as Chars
46import qualified Data.String as Chars
46import qualified Data.Utf8 as Utf8
47import qualified Data.Utf8 as Utf8
48+import Foreign.Ptr (plusPtr, minusPtr)
47import GHC.Exts
49import GHC.Exts
48− ( Int(I#), Ptr
50+ ( Int(I#), Ptr(Ptr)
51+ , RealWorld
49 , MutableByteArray#
52 , MutableByteArray#
50 , isTrue#
53 , isTrue#
51 , newByteArray#
54 , newByteArray#
52 , sizeofByteArray#
55 , sizeofByteArray#
56+ , writeWord8OffAddr#
57+ , copyByteArrayToAddr#
53 , unsafeFreezeByteArray#
58 , unsafeFreezeByteArray#
54 )
59 )
60+import GHC.IO
55import GHC.ST (ST(ST), runST)
61import GHC.ST (ST(ST), runST)
56import GHC.Prim
62import GHC.Prim
57import GHC.Word (Word8(W8#))
63import GHC.Word (Word8(W8#))
@@ -202,11 +208,11 @@ fromVarIndex :: Int -> Name
202fromVarIndex n =
208fromVarIndex n =
203 runST
209 runST
204 (
210 (
205− do let !size = 2 + getIndexSize n
211+ do let !size = getIndexSize n
206 mba <- newByteArray size
212 mba <- newByteArray size
207 writeWord8 mba 0 0x5F {- _ -}
213 writeWord8 mba 0 0x5F {- _ -}
208 writeWord8 mba 1 0x76 {- v -}
214 writeWord8 mba 1 0x76 {- v -}
209− writeDigitsAtEnd mba size n
215+ writeDigits mba (size - 1) n
210 freeze mba
216 freeze mba
211 )
217 )
212
218
@@ -214,20 +220,19 @@ fromVarIndex n =
214{-# INLINE getIndexSize #-}
220{-# INLINE getIndexSize #-}
215getIndexSize :: Int -> Int
221getIndexSize :: Int -> Int
216getIndexSize n
222getIndexSize n
217− | n < 10 = 1
223+ | n < 10 = 3
218− | n < 100 = 2
224+ | n < 100 = 4
219− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
225+ | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
220
226
221
227
222
228
223−writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
229+writeDigits :: MBA s -> Int -> Int -> ST s ()
224−writeDigitsAtEnd !mba !oldOffset !n =
230+writeDigits !mba !offset !n =
225 do let (q,r) = quotRem n 10
231 do let (q,r) = quotRem n 10
226− let !newOffset = oldOffset - 1
227− writeWord8 mba newOffset (0x30 + fromIntegral r)
232+ writeWord8 mba offset (0x30 + fromIntegral r)
228 if q <= 0
233 if q <= 0
229 then return ()
234 then return ()
230− else writeDigitsAtEnd mba newOffset q
235+ else writeDigits mba (offset-1) q
231
236
232
237
233
238
@@ -250,7 +255,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
250 mba <- newByteArray size
255 mba <- newByteArray size
251 copyToMBA name mba
256 copyToMBA name mba
252 writeWord8 mba (I# len#) 0x5F {- _ -}
257 writeWord8 mba (I# len#) 0x5F {- _ -}
253− writeDigitsAtEnd mba size index
258+ writeDigits mba (size - 1) index
254 freeze mba
259 freeze mba
255 )
260 )
256 else
261 else
@@ -259,7 +264,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
259 do let !size = I# len# + getIndexSize index
264 do let !size = I# len# + getIndexSize index
260 mba <- newByteArray size
265 mba <- newByteArray size
261 copyToMBA name mba
266 copyToMBA name mba
262− writeDigitsAtEnd mba size index
267+ writeDigits mba (size - 1) index
263 freeze mba
268 freeze mba
264 )
269 )
265
270
@@ -278,61 +283,61 @@ fromTypeVariableScheme scheme =
278 freeze mba
283 freeze mba
279 else
284 else
280 do let (extra, letter) = quotRem scheme 26
285 do let (extra, letter) = quotRem scheme 26
281− let !size = 1 + getIndexSize extra
286+ let !size = getIndexSize extra
282 mba <- newByteArray size
287 mba <- newByteArray size
283 writeWord8 mba 0 (0x61 + fromIntegral letter)
288 writeWord8 mba 0 (0x61 + fromIntegral letter)
284− writeDigitsAtEnd mba size extra
289+ writeDigits mba (size - 1) extra
285 freeze mba
290 freeze mba
286 )
291 )
287
292
288
293
289
294
295+-- FROM REPL COUNT
296+
297+
298+fromReplCount :: Int -> Name
299+fromReplCount n =
300+ Utf8.fromChars ("repl_value_" ++ show n)
301+
302+
303+
290-- FROM MANY NAMES
304-- FROM MANY NAMES
291−--
292−-- Creating a unique name by combining all the subnames can create names
293−-- longer than 256 bytes relatively easily. So instead, the first given name
294−-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295−--
296−-- This should be a unique name since 0.19 disallows shadowing. It would not
297−-- be possible for multiple top-level cycles to include values with the same
298−-- name, so the important thing is to make the cycle name distinct from the
299−-- normal name. Same logic for destructuring patterns like (x,y)
300
305
301
306
302fromManyNames :: [Name] -> Name
307fromManyNames :: [Name] -> Name
303fromManyNames names =
308fromManyNames names =
304− case names of
309+ let
305− [] ->
306− blank
307− -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)
308− -- but maybe unused patterns should be stripped out instead
309−
310− Utf8.Utf8 ba# : _ ->
311− let
312− len# = sizeofByteArray# ba#
310+ !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
313− in
311+ in
314− runST
312+ runST
315− (
313+ (
316− ST $ \s ->
314+ ST $ \s ->
317− case newByteArray# (len# +# 3#) s of
315+ case newByteArray# size# s of
316+ (# s, mba# #) ->
317+ case writeNames mba# 0# names s of
318− (# s, mba# #) ->
318+ s ->
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
319+ case unsafeFreezeByteArray# mba# s of
328− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
320+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329− )
321+ )
330
322
331
323
332−{-# NOINLINE blank #-}
324+writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
333−blank :: Name
325+writeNames mba# !offset# names s =
334−blank =
326+ case names of
335− fromWords [0x5F,0x4D,0x24] {-_M$-}
327+ [] ->
328+ s
329+
330+ (Utf8.Utf8 ba#) : names ->
331+ case writeWord8Array# mba# offset# 0x24## {- $ -} s of
332+ s ->
333+ let
334+ !offset1# = offset# +# 1#
335+ !len# = sizeofByteArray# ba#
336+ !newOffset# = offset1# +# len#
337+ in
338+ case copyByteArray# ba# 0# mba# offset1# len# s of
339+ s ->
340+ writeNames mba# newOffset# names s
336
341
337
342
338
343
@@ -603,8 +608,3 @@ identity = fromChars "identity"
603{-# NOINLINE replModule #-}
608{-# NOINLINE replModule #-}
604replModule :: Name
609replModule :: Name
605replModule = fromChars "Elm_Repl"
610replModule = fromChars "Elm_Repl"
606−
607−
608−{-# NOINLINE replValueToPrint #-}
609−replValueToPrint :: Name
610−replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hs+2−6
@@ -52,12 +52,8 @@ instance Foldable List where
52-- SORT BY
52-- SORT BY
53
53
54
54
55−sortBy :: (Ord b) => (a -> b) -> List a -> List a
55+sortBy :: (a -> a -> Ordering) -> List a -> List a
56−sortBy toRank (List x xs) =
56+sortBy comparison (List x xs) =
57− let
58− comparison a b =
59− compare (toRank a) (toRank b)
60− in
61 case List.sortBy comparison xs of
57 case List.sortBy comparison xs of
62 [] ->
58 [] ->
63 List x []
59 List x []
compiler/src/Data/Utf8.hs+4−6
@@ -63,7 +63,7 @@ import GHC.Exts
63import GHC.IO
63import GHC.IO
64import GHC.ST (ST(ST), runST)
64import GHC.ST (ST(ST), runST)
65import GHC.Prim
65import GHC.Prim
66−import GHC.Word (Word8(W8#))
66+import GHC.Word (Word8(W8#), Word16(W16#))
67
67
68import qualified Parse.Primitives as P
68import qualified Parse.Primitives as P
69
69
@@ -261,9 +261,7 @@ instance Eq (Utf8 t) where
261
261
262
262
263-- COMPARE
263-- COMPARE
264−--
264+
265−-- TODO: is it fine to sort by length and only compare bytes on length ties?
266−--
267
265
268instance Ord (Utf8 t) where
266instance Ord (Utf8 t) where
269 compare (Utf8 ba1#) (Utf8 ba2#) =
267 compare (Utf8 ba1#) (Utf8 ba2#) =
@@ -457,7 +455,7 @@ toEscapedBuilderHelp before after !name@(Utf8 ba#) k =
457 !bLen = minusPtr bEnd bOffset
455 !bLen = minusPtr bEnd bOffset
458 in
456 in
459 if len <= bLen then
457 if len <= bLen then
460− do -- PERF test if writing word-by-word is faster
458+ do -- TODO test if writing word-by-word is faster
461 copyToPtr name offset bOffset len
459 copyToPtr name offset bOffset len
462 escape before after bOffset name offset len 0
460 escape before after bOffset name offset len 0
463 let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
461 let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
@@ -567,7 +565,7 @@ data MBA s =
567 MBA# (MutableByteArray# s)
565 MBA# (MutableByteArray# s)
568
566
569
567
570−newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
568+newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
571newByteArray (I# len#) =
569newByteArray (I# len#) =
572 ST $ \s ->
570 ST $ \s ->
573 case newByteArray# len# s of
571 case newByteArray# len# s of
compiler/src/Elm/Compiler/Imports.hs+3−3
@@ -49,14 +49,14 @@ closed =
49
49
50typeOpen :: Name.Name -> Src.Exposing
50typeOpen :: Name.Name -> Src.Exposing
51typeOpen name =
51typeOpen name =
52− Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
52+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]
53
53
54
54
55typeClosed :: Name.Name -> Src.Exposing
55typeClosed :: Name.Name -> Src.Exposing
56typeClosed name =
56typeClosed name =
57− Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
57+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
58
58
59
59
60operator :: Name.Name -> Src.Exposing
60operator :: Name.Name -> Src.Exposing
61operator op =
61operator op =
62− Src.Explicit [ Src.Operator A.zero op ]
62+ Src.Explicit [ A.At A.zero (Src.Operator op) ]
compiler/src/Elm/Compiler/Type/Extract.hs+1−1
@@ -87,7 +87,7 @@ toPublicName (ModuleName.Canonical _ home) name =
87
87
88newtype Types =
88newtype Types =
89 Types (Map.Map ModuleName.Canonical Types_)
89 Types (Map.Map ModuleName.Canonical Types_)
90− -- PERF profile Opt.Global representation
90+ -- TODO profile Opt.Global representation
91 -- current representation needs less allocation
91 -- current representation needs less allocation
92 -- but maybe the lookup is much worse
92 -- but maybe the lookup is much worse
93
93
compiler/src/Elm/Constraint.hs+1−1
@@ -216,7 +216,7 @@ instance Binary Op where
216 case n of
216 case n of
217 0 -> return Less
217 0 -> return Less
218 1 -> return LessOrEqual
218 1 -> return LessOrEqual
219− _ -> fail "binary encoding of Op was corrupted"
219+ _ -> error "binary encoding of Op was corrupted"
220
220
221
221
222
222
compiler/src/Elm/Docs.hs+3−3
@@ -346,9 +346,9 @@ chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
346chompDocs names =
346chompDocs names =
347 do name <-
347 do name <-
348 P.addLocation $
348 P.addLocation $
349− P.oneOf E.Name
349+ P.oneOf E.Export
350− [ Var.lower E.Name
350+ [ Var.lower E.Export
351− , Var.upper E.Name
351+ , Var.upper E.Export
352 , chompOperator
352 , chompOperator
353 ]
353 ]
354
354
compiler/src/Elm/Interface.hs+3−3
@@ -215,7 +215,7 @@ instance Binary Union where
215 0 -> liftM OpenUnion get
215 0 -> liftM OpenUnion get
216 1 -> liftM ClosedUnion get
216 1 -> liftM ClosedUnion get
217 2 -> liftM PrivateUnion get
217 2 -> liftM PrivateUnion get
218− _ -> fail "binary encoding of Union was corrupted"
218+ _ -> error "binary encoding of Union was corrupted"
219
219
220
220
221instance Binary Alias where
221instance Binary Alias where
@@ -229,7 +229,7 @@ instance Binary Alias where
229 case n of
229 case n of
230 0 -> liftM PublicAlias get
230 0 -> liftM PublicAlias get
231 1 -> liftM PrivateAlias get
231 1 -> liftM PrivateAlias get
232− _ -> fail "binary encoding of Alias was corrupted"
232+ _ -> error "binary encoding of Alias was corrupted"
233
233
234
234
235instance Binary Binop where
235instance Binary Binop where
@@ -251,4 +251,4 @@ instance Binary DependencyInterface where
251 case n of
251 case n of
252 0 -> liftM Public get
252 0 -> liftM Public get
253 1 -> liftM3 Private get get get
253 1 -> liftM3 Private get get get
254− _ -> fail "binary encoding of DependencyInterface was corrupted"
254+ _ -> error "binary encoding of DependencyInterface was corrupted"
compiler/src/Elm/Kernel.hs+9−9
@@ -15,7 +15,7 @@ import qualified Data.ByteString.Internal as B
15import qualified Data.List as List
15import qualified Data.List as List
16import qualified Data.Map as Map
16import qualified Data.Map as Map
17import qualified Data.Name as Name
17import qualified Data.Name as Name
18−import Data.Word (Word8)
18+import Data.Word (Word8, Word16)
19import Foreign.Ptr (Ptr, plusPtr, minusPtr)
19import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20import Foreign.ForeignPtr (ForeignPtr)
20import Foreign.ForeignPtr (ForeignPtr)
21import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
21import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
@@ -128,7 +128,7 @@ parseChunks vtable enums fields =
128 cerr row col toError
128 cerr row col toError
129
129
130
130
131−chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
131+chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
132chompChunks vs es fs src pos end row col lastPos revChunks =
132chompChunks vs es fs src pos end row col lastPos revChunks =
133 if pos >= end then
133 if pos >= end then
134 let !js = toByteString src lastPos end in
134 let !js = toByteString src lastPos end in
@@ -168,7 +168,7 @@ toByteString src pos end =
168
168
169
169
170-- relies on external checks in chompChunks
170-- relies on external checks in chompChunks
171−chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
171+chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
172chompTag vs es fs src pos end row col revChunks =
172chompTag vs es fs src pos end row col revChunks =
173 let
173 let
174 (# newPos, newCol #) = Var.chompInnerChars pos end col
174 (# newPos, newCol #) = Var.chompInnerChars pos end col
@@ -319,19 +319,19 @@ toNames exposing =
319 map toName exposedList
319 map toName exposedList
320
320
321
321
322−toName :: Src.Exposed -> Name.Name
322+toName :: A.Located Src.Exposed -> Name.Name
323−toName exposed =
323+toName (A.At _ exposed) =
324 case exposed of
324 case exposed of
325− Src.Lower (A.At _ name) ->
325+ Src.Lower name ->
326 name
326 name
327
327
328− Src.Upper (A.At _ name) Src.Private ->
328+ Src.Upper name Src.Private ->
329 name
329 name
330
330
331− Src.Upper _ (Src.Public _) ->
331+ Src.Upper _ Src.Public ->
332 error "cannot have Maybe(..) syntax in kernel code header"
332 error "cannot have Maybe(..) syntax in kernel code header"
333
333
334− Src.Operator _ _ ->
334+ Src.Operator _ ->
335 error "cannot use binops in kernel code"
335 error "cannot use binops in kernel code"
336
336
337
337
compiler/src/Elm/Licenses.hs+25−25
@@ -83,61 +83,63 @@ check givenCode =
83osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
83osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
84osiApprovedSpdxLicenses =
84osiApprovedSpdxLicenses =
85 Map.fromList
85 Map.fromList
86− [ "0BSD" ==> "BSD Zero Clause License"
87− , "AAL" ==> "Attribution Assurance License"
88− , "AFL-1.1" ==> "Academic Free License v1.1"
86+ [ "AFL-1.1" ==> "Academic Free License v1.1"
89 , "AFL-1.2" ==> "Academic Free License v1.2"
87 , "AFL-1.2" ==> "Academic Free License v1.2"
90 , "AFL-2.0" ==> "Academic Free License v2.0"
88 , "AFL-2.0" ==> "Academic Free License v2.0"
91 , "AFL-2.1" ==> "Academic Free License v2.1"
89 , "AFL-2.1" ==> "Academic Free License v2.1"
92 , "AFL-3.0" ==> "Academic Free License v3.0"
90 , "AFL-3.0" ==> "Academic Free License v3.0"
93− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
91+ , "APL-1.0" ==> "Adaptive Public License 1.0"
94 , "Apache-1.1" ==> "Apache License 1.1"
92 , "Apache-1.1" ==> "Apache License 1.1"
95 , "Apache-2.0" ==> "Apache License 2.0"
93 , "Apache-2.0" ==> "Apache License 2.0"
96− , "APL-1.0" ==> "Adaptive Public License 1.0"
97 , "APSL-1.0" ==> "Apple Public Source License 1.0"
94 , "APSL-1.0" ==> "Apple Public Source License 1.0"
98 , "APSL-1.1" ==> "Apple Public Source License 1.1"
95 , "APSL-1.1" ==> "Apple Public Source License 1.1"
99 , "APSL-1.2" ==> "Apple Public Source License 1.2"
96 , "APSL-1.2" ==> "Apple Public Source License 1.2"
100 , "APSL-2.0" ==> "Apple Public Source License 2.0"
97 , "APSL-2.0" ==> "Apple Public Source License 2.0"
101 , "Artistic-1.0" ==> "Artistic License 1.0"
98 , "Artistic-1.0" ==> "Artistic License 1.0"
102− , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
103 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
99 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
100+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
104 , "Artistic-2.0" ==> "Artistic License 2.0"
101 , "Artistic-2.0" ==> "Artistic License 2.0"
102+ , "AAL" ==> "Attribution Assurance License"
103+ , "BSL-1.0" ==> "Boost Software License 1.0"
105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
104 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
105 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
107− , "BSL-1.0" ==> "Boost Software License 1.0"
106+ , "0BSD" ==> "BSD Zero Clause License"
108− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
107 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
111 , "CNRI-Python" ==> "CNRI Python License"
108 , "CNRI-Python" ==> "CNRI Python License"
109+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
110 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
113 , "CPL-1.0" ==> "Common Public License 1.0"
111 , "CPL-1.0" ==> "Common Public License 1.0"
112+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
113 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
114+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
115 , "ECL-1.0" ==> "Educational Community License v1.0"
115 , "ECL-1.0" ==> "Educational Community License v1.0"
116 , "ECL-2.0" ==> "Educational Community License v2.0"
116 , "ECL-2.0" ==> "Educational Community License v2.0"
117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
119 , "Entessa" ==> "Entessa Public License v1.0"
119 , "Entessa" ==> "Entessa Public License v1.0"
120− , "EPL-1.0" ==> "Eclipse Public License 1.0"
121 , "EUDatagrid" ==> "EU DataGrid Software License"
120 , "EUDatagrid" ==> "EU DataGrid Software License"
122 , "EUPL-1.1" ==> "European Union Public License 1.1"
121 , "EUPL-1.1" ==> "European Union Public License 1.1"
123 , "Fair" ==> "Fair License"
122 , "Fair" ==> "Fair License"
124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
123 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
124+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
127+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
128+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
129+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
127 , "HPND" ==> "Historic Permission Notice and Disclaimer"
130 , "HPND" ==> "Historic Permission Notice and Disclaimer"
131+ , "IPL-1.0" ==> "IBM Public License v1.0"
128 , "Intel" ==> "Intel Open Source License"
132 , "Intel" ==> "Intel Open Source License"
129 , "IPA" ==> "IPA Font License"
133 , "IPA" ==> "IPA Font License"
130− , "IPL-1.0" ==> "IBM Public License v1.0"
131 , "ISC" ==> "ISC License"
134 , "ISC" ==> "ISC License"
132− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
135+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
133− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
136 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
136− , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
137 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
137 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
138− , "LPL-1.0" ==> "Lucent Public License Version 1.0"
138+ , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
139 , "LPL-1.02" ==> "Lucent Public License v1.02"
139 , "LPL-1.02" ==> "Lucent Public License v1.02"
140+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"
140− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
141+ , "MS-PL" ==> "Microsoft Public License"
142+ , "MS-RL" ==> "Microsoft Reciprocal License"
141 , "MirOS" ==> "MirOS Licence"
143 , "MirOS" ==> "MirOS Licence"
142 , "MIT" ==> "MIT License"
144 , "MIT" ==> "MIT License"
143 , "Motosoto" ==> "Motosoto License"
145 , "Motosoto" ==> "Motosoto License"
@@ -145,40 +147,38 @@ osiApprovedSpdxLicenses =
145 , "MPL-1.1" ==> "Mozilla Public License 1.1"
147 , "MPL-1.1" ==> "Mozilla Public License 1.1"
146 , "MPL-2.0" ==> "Mozilla Public License 2.0"
148 , "MPL-2.0" ==> "Mozilla Public License 2.0"
147 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
149 , "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"
150 , "Multics" ==> "Multics License"
150 , "Multics" ==> "Multics License"
151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
152 , "Naumen" ==> "Naumen Public License"
152 , "Naumen" ==> "Naumen Public License"
153− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
154 , "NGPL" ==> "Nethack General Public License"
153 , "NGPL" ==> "Nethack General Public License"
155 , "Nokia" ==> "Nokia Open Source License"
154 , "Nokia" ==> "Nokia Open Source License"
156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
155 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
157 , "NTP" ==> "NTP License"
156 , "NTP" ==> "NTP License"
158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
157 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159− , "OFL-1.1" ==> "SIL Open Font License 1.1"
160 , "OGTSL" ==> "Open Group Test Suite License"
158 , "OGTSL" ==> "Open Group Test Suite License"
161− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
162 , "OSL-1.0" ==> "Open Software License 1.0"
159 , "OSL-1.0" ==> "Open Software License 1.0"
163 , "OSL-2.0" ==> "Open Software License 2.0"
160 , "OSL-2.0" ==> "Open Software License 2.0"
164 , "OSL-2.1" ==> "Open Software License 2.1"
161 , "OSL-2.1" ==> "Open Software License 2.1"
165 , "OSL-3.0" ==> "Open Software License 3.0"
162 , "OSL-3.0" ==> "Open Software License 3.0"
163+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
166 , "PHP-3.0" ==> "PHP License v3.0"
164 , "PHP-3.0" ==> "PHP License v3.0"
167 , "PostgreSQL" ==> "PostgreSQL License"
165 , "PostgreSQL" ==> "PostgreSQL License"
168 , "Python-2.0" ==> "Python License 2.0"
166 , "Python-2.0" ==> "Python License 2.0"
169 , "QPL-1.0" ==> "Q Public License 1.0"
167 , "QPL-1.0" ==> "Q Public License 1.0"
168+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
169 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
170 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
173 , "RSCPL" ==> "Ricoh Source Code Public License"
171 , "RSCPL" ==> "Ricoh Source Code Public License"
172+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
174 , "SimPL-2.0" ==> "Simple Public License 2.0"
173 , "SimPL-2.0" ==> "Simple Public License 2.0"
175− , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176 , "Sleepycat" ==> "Sleepycat License"
174 , "Sleepycat" ==> "Sleepycat License"
175+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"
177 , "SPL-1.0" ==> "Sun Public License v1.0"
176 , "SPL-1.0" ==> "Sun Public License v1.0"
177+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
178 , "UPL-1.0" ==> "Universal Permissive License v1.0"
178 , "UPL-1.0" ==> "Universal Permissive License v1.0"
179+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
179 , "VSL-1.0" ==> "Vovida Software License v1.0"
180 , "VSL-1.0" ==> "Vovida Software License v1.0"
180 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
182 , "Xnet" ==> "X.Net License"
182 , "Xnet" ==> "X.Net License"
183 , "Zlib" ==> "zlib License"
183 , "Zlib" ==> "zlib License"
184 , "ZPL-2.0" ==> "Zope Public License 2.0"
184 , "ZPL-2.0" ==> "Zope Public License 2.0"
compiler/src/Elm/ModuleName.hs+7−2
@@ -7,13 +7,12 @@ module Elm.ModuleName
7 --
7 --
8 , encode
8 , encode
9 , decoder
9 , decoder
10− , parser
11 --
10 --
12 , Canonical(..)
11 , Canonical(..)
13 , basics, char, string
12 , basics, char, string
14 , maybe, result, list, array, dict, tuple
13 , maybe, result, list, array, dict, tuple
15 , platform, cmd, sub
14 , platform, cmd, sub
16− , debug
15+ , debug, bitwise
17 , virtualDom
16 , virtualDom
18 , jsonDecode, jsonEncode
17 , jsonDecode, jsonEncode
19 , webgl, texture, vector2, vector3, vector4, matrix4
18 , webgl, texture, vector2, vector3, vector4, matrix4
@@ -23,6 +22,7 @@ module Elm.ModuleName
23
22
24import Control.Monad (liftM2)
23import Control.Monad (liftM2)
25import Data.Binary (Binary(..))
24import Data.Binary (Binary(..))
25+import qualified Data.Char as Char
26import qualified Data.Name as Name
26import qualified Data.Name as Name
27import qualified Data.Utf8 as Utf8
27import qualified Data.Utf8 as Utf8
28import Data.Word (Word8)
28import Data.Word (Word8)
@@ -226,6 +226,11 @@ debug :: Canonical
226debug = Canonical Pkg.core Name.debug
226debug = Canonical Pkg.core Name.debug
227
227
228
228
229+{-# NOINLINE bitwise #-}
230+bitwise :: Canonical
231+bitwise = Canonical Pkg.core Name.bitwise
232+
233+
229
234
230-- HTML
235-- HTML
231
236
compiler/src/Elm/Package.hs+15−5
@@ -31,6 +31,7 @@ module Elm.Package
31import Control.Monad (liftM2)
31import Control.Monad (liftM2)
32import Data.Binary (Binary, get, put)
32import Data.Binary (Binary, get, put)
33import qualified Data.Coerce as Coerce
33import qualified Data.Coerce as Coerce
34+import Data.Function (on)
34import qualified Data.List as List
35import qualified Data.List as List
35import qualified Data.Map as Map
36import qualified Data.Map as Map
36import qualified Data.Name as Name
37import qualified Data.Name as Name
@@ -58,7 +59,6 @@ data Name =
58 { _author :: !Author
59 { _author :: !Author
59 , _project :: !Project
60 , _project :: !Project
60 }
61 }
61− deriving (Ord)
62
62
63
63
64type Author = Utf8.Utf8 AUTHOR
64type Author = Utf8.Utf8 AUTHOR
@@ -236,10 +236,12 @@ nearbyNames (Name author1 project1) possibleNames =
236 authorDist = authorDistance (Utf8.toChars author1)
236 authorDist = authorDistance (Utf8.toChars author1)
237 projectDist = projectDistance (Utf8.toChars project1)
237 projectDist = projectDistance (Utf8.toChars project1)
238
238
239− nameDistance (Name author2 project2) =
239+ addDistance name@(Name author2 project2) =
240− authorDist author2 + projectDist project2
240+ ( authorDist author2 + projectDist project2, name )
241 in
241 in
242− take 4 $ List.sortOn nameDistance possibleNames
242+ map snd $ take 4 $
243+ List.sortBy (compare `on` fst) $
244+ map addDistance possibleNames
243
245
244
246
245authorDistance :: [Char] -> Author -> Int
247authorDistance :: [Char] -> Author -> Int
@@ -268,11 +270,19 @@ instance Eq Canonical where
268 version1 == version2 && package1 == package2
270 version1 == version2 && package1 == package2
269
271
270
272
273+instance Ord Name where
274+ compare (Name author1 project1) (Name author2 project2) =
275+ case compare project1 project2 of
276+ LT -> LT
277+ EQ -> compare author1 author2
278+ GT -> GT
279+
280+
271
281
272-- BINARY
282-- BINARY
273
283
274
284
275−instance Binary Name where -- PERF try storing as a Word16
285+instance Binary Name where -- TODO try storing as a Word16
276 get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
286 get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
277 put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
287 put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
278
288
compiler/src/Elm/String.hs+1
@@ -108,6 +108,7 @@ writeChunks mba offset chunks =
108 writeChunks mba newOffset chunks
108 writeChunks mba newOffset chunks
109
109
110
110
111+-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
111writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112writeCode mba offset code =
113writeCode mba offset code =
113 do writeWord8 mba offset 0x5C {- \ -}
114 do writeWord8 mba offset 0x5C {- \ -}
compiler/src/Generate/Html.hs+10−11
@@ -29,23 +29,22 @@ sandwich moduleName javascript =
29
29
30<body>
30<body>
31
31
32−<pre id="elm"></pre>
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>
33
39
34<script>
40<script>
35−try {
36|] <> javascript <> [r|
41|] <> javascript <> [r|
37
42
43+try {
38 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
44 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
39−}
40−catch (e)
45+} catch (e) {
41−{
42 // display initialization errors (e.g. bad flags, infinite recursion)
46 // display initialization errors (e.g. bad flags, infinite recursion)
43− var header = document.createElement("h1");
44− header.style.fontFamily = "monospace";
45− header.innerText = "Initialization Error";
46− var pre = document.getElementById("elm");
47+ document.getElementById("elm").innerText = e;
47− document.body.insertBefore(header, pre);
48− pre.innerText = e;
49 throw e;
48 throw e;
50}
49}
51</script>
50</script>
compiler/src/Generate/JavaScript.hs+10−46
@@ -2,7 +2,6 @@
2module Generate.JavaScript
2module Generate.JavaScript
3 ( generate
3 ( generate
4 , generateForRepl
4 , generateForRepl
5− , generateForReplEndpoint
6 )
5 )
7 where
6 where
8
7
@@ -86,9 +85,7 @@ generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _
86 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
85 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
87 evalState = addGlobal mode graph debugState (Opt.Global home name)
86 evalState = addGlobal mode graph debugState (Opt.Global home name)
88 in
87 in
89− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90− <> Functions.functions
91− <> stateToBuilder evalState
88+ stateToBuilder evalState
92 <> print ansi localizer home name tipe
89 <> print ansi localizer home name tipe
93
90
94
91
@@ -100,47 +97,14 @@ print ansi localizer home name tipe =
100 tipeDoc = RT.canToDoc localizer RT.None tipe
97 tipeDoc = RT.canToDoc localizer RT.None tipe
101 bool = if ansi then "true" else "false"
98 bool = if ansi then "true" else "false"
102 in
99 in
103− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
100+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
104− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
101+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
105− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
102+ \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\
103+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
107− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
104+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
108− \} else {\n\
105+ \} else {\n\
109− \ _print(' : ' + _type);\n\
106+ \ _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"
107+ \}\n"
144
108
145
109
146
110
@@ -292,7 +256,7 @@ generateCycle mode (Opt.Global home _) names values functions =
292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
256 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
293 <> drawCycle names
257 <> drawCycle names
294 <> "\\n\\nThese errors are very tricky, so read "
258 <> "\\n\\nThese errors are very tricky, so read "
295− <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
259+ <> B.stringUtf8 (D.makeNakedLink "halting-problem")
296 <> " to learn how to fix it!"
260 <> " to learn how to fix it!"
297 ]
261 ]
298
262
compiler/src/Generate/Mode.hs+1
@@ -49,6 +49,7 @@ shortenFieldNames (Opt.GlobalGraph _ frequencies) =
49
49
50addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
50addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
51addToBuckets field frequency buckets =
51addToBuckets field frequency buckets =
52+ -- TODO try using an IntMap for buckets
52 Map.insertWith (++) frequency [field] buckets
53 Map.insertWith (++) frequency [field] buckets
53
54
54
55
compiler/src/Json/Decode.hs+72−77
@@ -24,7 +24,6 @@ module Json.Decode
24 , Problem(..)
24 , Problem(..)
25 , DecodeExpectation(..)
25 , DecodeExpectation(..)
26 , ParseError(..)
26 , ParseError(..)
27− , StringProblem(..)
28 )
27 )
29 where
28 where
30
29
@@ -32,7 +31,7 @@ module Json.Decode
32import qualified Data.ByteString.Internal as B
31import qualified Data.ByteString.Internal as B
33import qualified Data.Map as Map
32import qualified Data.Map as Map
34import qualified Data.NonEmptyList as NE
33import qualified Data.NonEmptyList as NE
35−import Data.Word (Word8)
34+import Data.Word (Word8, Word16)
36import Foreign.Ptr (Ptr, plusPtr, minusPtr)
35import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
36import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
38
37
@@ -40,7 +39,6 @@ import qualified Json.String as Json
40import qualified Parse.Keyword as K
39import qualified Parse.Keyword as K
41import qualified Parse.Primitives as P
40import qualified Parse.Primitives as P
42import Parse.Primitives (Row, Col)
41import Parse.Primitives (Row, Col)
43−import qualified Reporting.Annotation as A
44
42
45
43
46
44
@@ -51,10 +49,10 @@ fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
51fromByteString (Decoder decode) src =
49fromByteString (Decoder decode) src =
52 case P.fromByteString pFile BadEnd src of
50 case P.fromByteString pFile BadEnd src of
53 Right ast ->
51 Right ast ->
54− decode ast Right (Left . DecodeProblem src)
52+ decode ast Right (Left . DecodeProblem)
55
53
56 Left problem ->
54 Left problem ->
57− Left (ParseProblem src problem)
55+ Left (ParseProblem problem)
58
56
59
57
60
58
@@ -77,8 +75,8 @@ newtype Decoder x a =
77
75
78
76
79data Error x
77data Error x
80− = DecodeProblem B.ByteString (Problem x)
78+ = DecodeProblem (Problem x)
81− | ParseProblem B.ByteString ParseError
79+ | ParseProblem ParseError
82
80
83
81
84
82
@@ -89,8 +87,8 @@ data Problem x
89 = Field B.ByteString (Problem x)
87 = Field B.ByteString (Problem x)
90 | Index Int (Problem x)
88 | Index Int (Problem x)
91 | OneOf (Problem x) [Problem x]
89 | OneOf (Problem x) [Problem x]
92− | Failure A.Region x
90+ | Failure x
93− | Expecting A.Region DecodeExpectation
91+ | Expecting DecodeExpectation
94
92
95
93
96data DecodeExpectation
94data DecodeExpectation
@@ -157,26 +155,26 @@ instance Monad (Decoder x) where
157
155
158string :: Decoder x Json.String
156string :: Decoder x Json.String
159string =
157string =
160− Decoder $ \(A.At region ast) ok err ->
158+ Decoder $ \ast ok err ->
161 case ast of
159 case ast of
162 String snippet ->
160 String snippet ->
163 ok (Json.fromSnippet snippet)
161 ok (Json.fromSnippet snippet)
164
162
165 _ ->
163 _ ->
166− err (Expecting region TString)
164+ err (Expecting TString)
167
165
168
166
169customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
167customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
170customString parser toBadEnd =
168customString parser toBadEnd =
171− Decoder $ \(A.At region ast) ok err ->
169+ Decoder $ \ast ok err ->
172 case ast of
170 case ast of
173 String snippet ->
171 String snippet ->
174 case P.fromSnippet parser toBadEnd snippet of
172 case P.fromSnippet parser toBadEnd snippet of
175 Right a -> ok a
173 Right a -> ok a
176− Left x -> err (Failure region x)
174+ Left x -> err (Failure x)
177
175
178 _ ->
176 _ ->
179− err (Expecting region TString)
177+ err (Expecting TString)
180
178
181
179
182
180
@@ -185,7 +183,7 @@ customString parser toBadEnd =
185
183
186bool :: Decoder x Bool
184bool :: Decoder x Bool
187bool =
185bool =
188− Decoder $ \(A.At region ast) ok err ->
186+ Decoder $ \ast ok err ->
189 case ast of
187 case ast of
190 TRUE ->
188 TRUE ->
191 ok True
189 ok True
@@ -194,7 +192,7 @@ bool =
194 ok False
192 ok False
195
193
196 _ ->
194 _ ->
197− err (Expecting region TBool)
195+ err (Expecting TBool)
198
196
199
197
200
198
@@ -203,13 +201,13 @@ bool =
203
201
204int :: Decoder x Int
202int :: Decoder x Int
205int =
203int =
206− Decoder $ \(A.At region ast) ok err ->
204+ Decoder $ \ast ok err ->
207 case ast of
205 case ast of
208 Int n ->
206 Int n ->
209 ok n
207 ok n
210
208
211 _ ->
209 _ ->
212− err (Expecting region TInt)
210+ err (Expecting TInt)
213
211
214
212
215
213
@@ -218,13 +216,13 @@ int =
218
216
219list :: Decoder x a -> Decoder x [a]
217list :: Decoder x a -> Decoder x [a]
220list decoder =
218list decoder =
221− Decoder $ \(A.At region ast) ok err ->
219+ Decoder $ \ast ok err ->
222 case ast of
220 case ast of
223 Array asts ->
221 Array asts ->
224 listHelp decoder ok err 0 asts []
222 listHelp decoder ok err 0 asts []
225
223
226 _ ->
224 _ ->
227− err (Expecting region TArray)
225+ err (Expecting TArray)
228
226
229
227
230listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
228listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
@@ -259,7 +257,7 @@ nonEmptyList decoder x =
259
257
260pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
258pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
261pair (Decoder decodeA) (Decoder decodeB) =
259pair (Decoder decodeA) (Decoder decodeB) =
262− Decoder $ \(A.At region ast) ok err ->
260+ Decoder $ \ast ok err ->
263 case ast of
261 case ast of
264 Array vs ->
262 Array vs ->
265 case vs of
263 case vs of
@@ -276,10 +274,10 @@ pair (Decoder decodeA) (Decoder decodeB) =
276 decodeA astA ok0 err0
274 decodeA astA ok0 err0
277
275
278 _ ->
276 _ ->
279− err (Expecting region (TArrayPair (length vs)))
277+ err (Expecting (TArrayPair (length vs)))
280
278
281 _ ->
279 _ ->
282− err (Expecting region TArray)
280+ err (Expecting TArray)
283
281
284
282
285
283
@@ -297,13 +295,13 @@ dict keyDecoder valueDecoder =
297
295
298pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
296pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
299pairs keyDecoder valueDecoder =
297pairs keyDecoder valueDecoder =
300− Decoder $ \(A.At region ast) ok err ->
298+ Decoder $ \ast ok err ->
301 case ast of
299 case ast of
302 Object kvs ->
300 Object kvs ->
303 pairsHelp keyDecoder valueDecoder ok err kvs []
301 pairsHelp keyDecoder valueDecoder ok err kvs []
304
302
305 _ ->
303 _ ->
306− err (Expecting region TObject)
304+ err (Expecting TObject)
307
305
308
306
309pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
307pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
@@ -315,7 +313,7 @@ pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decod
315 (snippet, ast) : kvs ->
313 (snippet, ast) : kvs ->
316 case P.fromSnippet keyParser toBadEnd snippet of
314 case P.fromSnippet keyParser toBadEnd snippet of
317 Left x ->
315 Left x ->
318− err (Failure (snippetToRegion snippet) x)
316+ err (Failure x)
319
317
320 Right key ->
318 Right key ->
321 let
319 let
@@ -327,18 +325,13 @@ pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decod
327 decodeA ast ok' err'
325 decodeA ast ok' err'
328
326
329
327
330−snippetToRegion :: P.Snippet -> A.Region
331−snippetToRegion (P.Snippet _ _ len row col) =
332− A.Region (A.Position row col) (A.Position row (col + fromIntegral len))
333−
334−
335
328
336-- FIELDS
329-- FIELDS
337
330
338
331
339field :: B.ByteString -> Decoder x a -> Decoder x a
332field :: B.ByteString -> Decoder x a -> Decoder x a
340field key (Decoder decodeA) =
333field key (Decoder decodeA) =
341− Decoder $ \(A.At region ast) ok err ->
334+ Decoder $ \ast ok err ->
342 case ast of
335 case ast of
343 Object kvs ->
336 Object kvs ->
344 case findField key kvs of
337 case findField key kvs of
@@ -350,10 +343,10 @@ field key (Decoder decodeA) =
350 decodeA value ok err'
343 decodeA value ok err'
351
344
352 Nothing ->
345 Nothing ->
353− err (Expecting region (TObjectWith key))
346+ err (Expecting (TObjectWith key))
354
347
355 _ ->
348 _ ->
356− err (Expecting region TObject)
349+ err (Expecting TObject)
357
350
358
351
359findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
352findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
@@ -417,8 +410,8 @@ oneOfError problems prob ps =
417
410
418failure :: x -> Decoder x a
411failure :: x -> Decoder x a
419failure x =
412failure x =
420− Decoder $ \(A.At region _) _ err ->
413+ Decoder $ \_ _ err ->
421− err (Failure region x)
414+ err (Failure x)
422
415
423
416
424
417
@@ -437,22 +430,18 @@ mapError func (Decoder decodeA) =
437mapErrorHelp :: (x -> y) -> Problem x -> Problem y
430mapErrorHelp :: (x -> y) -> Problem x -> Problem y
438mapErrorHelp func problem =
431mapErrorHelp func problem =
439 case problem of
432 case problem of
440− Field k p -> Field k (mapErrorHelp func p)
433+ Field k p -> Field k (mapErrorHelp func p)
441− Index i p -> Index i (mapErrorHelp func p)
434+ Index i p -> Index i (mapErrorHelp func p)
442− OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
435+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
443− Failure r x -> Failure r (func x)
436+ Failure x -> Failure (func x)
444− Expecting r e -> Expecting r e
437+ Expecting e -> Expecting e
445
438
446
439
447
440
448-- AST
441-- AST
449
442
450
443
451−type AST =
452− A.Located AST_
453−
454−
455−data AST_
444+data AST
456 = Array [AST]
445 = Array [AST]
457 | Object [(P.Snippet, AST)]
446 | Object [(P.Snippet, AST)]
458 | String P.Snippet
447 | String P.Snippet
@@ -471,14 +460,21 @@ type Parser a =
471
460
472
461
473data ParseError
462data ParseError
474− = Start Row Col
463+ = ObjectStart Row Col
475− | ObjectField Row Col
464+ | ObjectMore Row Col
476− | ObjectColon Row Col
477 | ObjectEnd Row Col
465 | ObjectEnd Row Col
466+ | ArrayStart Row Col
467+ | ArrayMore Row Col
478 | ArrayEnd Row Col
468 | ArrayEnd Row Col
469+ | StringStart Row Col
479 | StringProblem StringProblem Row Col
470 | StringProblem StringProblem Row Col
471+ | IntStart Row Col
480 | NoLeadingZeros Row Col
472 | NoLeadingZeros Row Col
481 | NoFloats Row Col
473 | NoFloats Row Col
474+ | Bool Row Col
475+ | Null Row Col
476+ | Value Row Col
477+ | Colon Row Col
482 | BadEnd Row Col
478 | BadEnd Row Col
483
479
484-- PIndex Int ParseError Row Col
480-- PIndex Int ParseError Row Col
@@ -506,15 +502,14 @@ pFile =
506
502
507pValue :: Parser AST
503pValue :: Parser AST
508pValue =
504pValue =
509− P.addLocation $
510− P.oneOf Start
505+ P.oneOf Value
511− [ String <$> pString Start
506+ [ String <$> pString
512 , pObject
507 , pObject
513 , pArray
508 , pArray
514 , pInt
509 , pInt
515− , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
510+ , K.k4 0x74 0x72 0x75 0x65 Bool >> return TRUE
516− , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
511+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Bool >> return FALSE
517− , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
512+ , K.k4 0x6E 0x75 0x6C 0x6C Null >> return NULL
518 ]
513 ]
519
514
520
515
@@ -522,11 +517,11 @@ pValue =
522-- OBJECT
517-- OBJECT
523
518
524
519
525−pObject :: Parser AST_
520+pObject :: Parser AST
526pObject =
521pObject =
527− do P.word1 0x7B {- { -} Start
522+ do P.word1 0x7B {- { -} ObjectStart
528 spaces
523 spaces
529− P.oneOf ObjectField
524+ P.oneOf ObjectMore
530 [ do entry <- pField
525 [ do entry <- pField
531 spaces
526 spaces
532 pObjectHelp [entry]
527 pObjectHelp [entry]
@@ -535,11 +530,11 @@ pObject =
535 ]
530 ]
536
531
537
532
538−pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
533+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST
539pObjectHelp revEntries =
534pObjectHelp revEntries =
540− P.oneOf ObjectEnd
535+ P.oneOf ObjectMore
541 [
536 [
542− do P.word1 0x2C {-,-} ObjectEnd
537+ do P.word1 0x2C {-,-} ObjectMore
543 spaces
538 spaces
544 entry <- pField
539 entry <- pField
545 spaces
540 spaces
@@ -552,9 +547,9 @@ pObjectHelp revEntries =
552
547
553pField :: Parser (P.Snippet, AST)
548pField :: Parser (P.Snippet, AST)
554pField =
549pField =
555− do key <- pString ObjectField
550+ do key <- pString
556 spaces
551 spaces
557− P.word1 0x3A {-:-} ObjectColon
552+ P.word1 0x3A {-:-} Colon
558 spaces
553 spaces
559 value <- pValue
554 value <- pValue
560 return (key, value)
555 return (key, value)
@@ -564,11 +559,11 @@ pField =
564-- ARRAY
559-- ARRAY
565
560
566
561
567−pArray :: Parser AST_
562+pArray :: Parser AST
568pArray =
563pArray =
569− do P.word1 0x5B {-[-} Start
564+ do P.word1 0x5B {-[-} ArrayStart
570 spaces
565 spaces
571− P.oneOf Start
566+ P.oneOf ArrayMore
572 [ do entry <- pValue
567 [ do entry <- pValue
573 spaces
568 spaces
574 pArrayHelp 1 [entry]
569 pArrayHelp 1 [entry]
@@ -577,11 +572,11 @@ pArray =
577 ]
572 ]
578
573
579
574
580−pArrayHelp :: Int -> [AST] -> Parser AST_
575+pArrayHelp :: Int -> [AST] -> Parser AST
581pArrayHelp !len revEntries =
576pArrayHelp !len revEntries =
582− P.oneOf ArrayEnd
577+ P.oneOf ArrayMore
583 [
578 [
584− do P.word1 0x2C {-,-} ArrayEnd
579+ do P.word1 0x2C {-,-} ArrayMore
585 spaces
580 spaces
586 entry <- pValue
581 entry <- pValue
587 spaces
582 spaces
@@ -596,8 +591,8 @@ pArrayHelp !len revEntries =
596-- STRING
591-- STRING
597
592
598
593
599−pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
594+pString :: Parser P.Snippet
600−pString start =
595+pString =
601 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
596 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
597 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
603
598
@@ -622,7 +617,7 @@ pString start =
622 cerr newRow newCol (StringProblem problem)
617 cerr newRow newCol (StringProblem problem)
623
618
624 else
619 else
625− eerr row col start
620+ eerr row col StringStart
626
621
627
622
628data StringStatus
623data StringStatus
@@ -630,7 +625,7 @@ data StringStatus
630 | BadString StringProblem
625 | BadString StringProblem
631
626
632
627
633−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
628+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
634pStringHelp pos end row col =
629pStringHelp pos end row col =
635 if pos >= end then
630 if pos >= end then
636 (# BadString BadStringEnd, pos, row, col #)
631 (# BadString BadStringEnd, pos, row, col #)
@@ -708,7 +703,7 @@ spaces =
708 cok () newState
703 cok () newState
709
704
710
705
711−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
706+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
712eatSpaces pos end row col =
707eatSpaces pos end row col =
713 if pos >= end then
708 if pos >= end then
714 (# pos, row, col #)
709 (# pos, row, col #)
@@ -727,16 +722,16 @@ eatSpaces pos end row col =
727-- INTS
722-- INTS
728
723
729
724
730−pInt :: Parser AST_
725+pInt :: Parser AST
731pInt =
726pInt =
732 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
727 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
733 if pos >= end then
728 if pos >= end then
734− eerr row col Start
729+ eerr row col IntStart
735
730
736 else
731 else
737 let !word = P.unsafeIndex pos in
732 let !word = P.unsafeIndex pos in
738 if not (isDecimalDigit word) then
733 if not (isDecimalDigit word) then
739− eerr row col Start
734+ eerr row col IntStart
740
735
741 else if word == 0x30 {-0-} then
736 else if word == 0x30 {-0-} then
742
737
compiler/src/Json/Encode.hs+3−4
@@ -104,22 +104,21 @@ list encodeEntry entries =
104-- CHARS
104-- CHARS
105
105
106
106
107−chars :: [Char] -> Value -- PERF can this be done better? Look for examples.
107+chars :: [Char] -> Value -- TODO can this be done better? Look for examples.
108chars chrs =
108chars chrs =
109 String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')
109 String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')
110
110
111
111
112−escape :: [Char] -> [Char]
112+escape :: [Char] -> [Char] -- TODO is this correct?
113escape chrs =
113escape chrs =
114 case chrs of
114 case chrs of
115 [] ->
115 [] ->
116 []
116 []
117
117
118 c:cs
118 c:cs
119− | c == '\r' -> '\\' : 'r' : escape cs
120 | c == '\n' -> '\\' : 'n' : escape cs
119 | c == '\n' -> '\\' : 'n' : escape cs
121 | c == '\"' -> '\\' : '"' : escape cs
120 | c == '\"' -> '\\' : '"' : escape cs
122− | c == '\\' -> '\\' : '\\' : escape cs
121+ | c == '\'' -> '\\' : '\'' : escape cs
123 | otherwise -> c : escape cs
122 | otherwise -> c : escape cs
124
123
125
124
compiler/src/Json/String.hs+2−1
@@ -37,7 +37,7 @@ import qualified Parse.Primitives as P
37
37
38
38
39-- INVARIANT: any Json.String is appropriately escaped already
39-- INVARIANT: any Json.String is appropriately escaped already
40−-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
40+-- TODO: is this the right representation for Json.String? Maybe ByteString instead?
41--
41--
42type String =
42type String =
43 Utf8.Utf8 JSON_STRING
43 Utf8.Utf8 JSON_STRING
@@ -116,6 +116,7 @@ chompChunks pos end start revChunks =
116 case word of
116 case word of
117 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
117 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
118 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
118 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
119+ 0x27 {-'-} -> chompEscape 0x27 {-'-} pos end start revChunks
119 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
120 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
120 0x0D {-\r-} ->
121 0x0D {-\r-} ->
121 let
122 let
compiler/src/Optimize/DecisionTree.hs+2−2
@@ -618,7 +618,7 @@ instance Binary Test where
618 5 -> liftM IsStr get
618 5 -> liftM IsStr get
619 6 -> liftM IsInt get
619 6 -> liftM IsInt get
620 7 -> liftM IsBool get
620 7 -> liftM IsBool get
621− _ -> fail "problem getting DecisionTree.Test binary"
621+ _ -> error "problem getting DecisionTree.Test binary"
622
622
623
623
624instance Binary Path where
624instance Binary Path where
@@ -634,4 +634,4 @@ instance Binary Path where
634 0 -> liftM2 Index get get
634 0 -> liftM2 Index get get
635 1 -> liftM Unbox get
635 1 -> liftM Unbox get
636 2 -> pure Empty
636 2 -> pure Empty
637− _ -> fail "problem getting DecisionTree.Path binary"
637+ _ -> error "problem getting DecisionTree.Path binary"
compiler/src/Optimize/Port.hs+1−1
@@ -58,7 +58,7 @@ toEncoder tipe =
58 | name == Name.array -> encodeArray arg
58 | name == Name.array -> encodeArray arg
59
59
60 _ ->
60 _ ->
61− error "toEncoder: bad custom type"
61+ error "toEncoder: bad union type"
62
62
63 Can.TRecord _ (Just _) ->
63 Can.TRecord _ (Just _) ->
64 error "toEncoder: bad record"
64 error "toEncoder: bad record"
compiler/src/Parse/Docs.hsnew file+275
@@ -0,0 +1,275 @@
1+module Parse.Docs
2+ ( Docs(..)
3+ , parser
4+ )
5+ where
6+
7+
8+
9+-- DOCS
10+
11+
12+data Docs =
13+ Docs
14+ { _exposed :: [A.Located Name.Name]
15+ , _overview :: Utf8.String
16+ , _listed :: [A.Located Name.Name]
17+ , _comments :: Map.Map Name.Name Utf8.String
18+ }
19+
20+
21+
22+-- PARSER
23+
24+
25+parser :: Parser Docs
26+parser =
27+ error "TODO implement docs parser"
28+
29+
30+chompUntilDocs :: Parser Bool
31+chompUntilDocs =
32+ P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33+ let
34+ (# isStart, newOffset, newRow, newCol #) =
35+ eatDocs fp offset terminal row col
36+
37+ !newState =
38+ P.State fp newOffset terminal indent newRow newCol ctx
39+ in
40+ cok isStart newState
41+
42+
43+eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44+eatDocs fp offset terminal row col =
45+ if offset >= terminal then
46+ (# False, offset, row, col #)
47+
48+ else if isDocsStart fp offset terminal then
49+ (# True, offset + 5, row, col + 5 #)
50+
51+ else
52+ let !word = P.unsafeIndex fp offset in
53+ if word == 0x0A {- \n -} then
54+ eatDocs fp (offset + 1) terminal (row + 1) 1
55+
56+ else
57+ let !newOffset = offset + P.getCharWidth fp offset terminal word in
58+ eatDocs fp newOffset terminal row (col + 1)
59+
60+
61+isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62+isDocsStart =
63+ let (B.PS dfp doff dlen) = docsStart in
64+ P.isSubstring dfp doff dlen
65+
66+
67+{-# NOINLINE docsStart #-}
68+docsStart :: B.ByteString
69+docsStart =
70+ "@docs"
71+
72+
73+chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74+chompOverview names =
75+ do isDocs <- chompUntilDocs
76+ if isDocs
77+ then chompOverviewHelp names
78+ else return names
79+
80+
81+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82+chompOverviewHelp names =
83+ do pos <- getPosition
84+ (SPos spos) <- whitespace
85+ if pos == spos
86+ then chompOverview names
87+ else chompOverview =<< chompDocs names
88+
89+
90+chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91+chompDocs names =
92+ do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93+ spos <- whitespace
94+ oneOf SE.XXX
95+ [ do checkSpace spos
96+ word1 0x2C {-,-} SE.XXX
97+ spaces
98+ chompDocs (name:names)
99+ , return (name:names)
100+ ]
101+
102+
103+chompBinop :: Parser Name.Name
104+chompBinop =
105+ do word1 0x28 {-(-} SE.XXX
106+ name <- Symbol.binop
107+ word1 0x29 {-)-} SE.XXX
108+ return name
109+
110+
111+
112+
113+-- CHECK NAMES
114+
115+
116+type Result i w a =
117+ Result.Result i w E.Error a
118+
119+
120+type Dups =
121+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122+
123+
124+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125+checkNames exports names =
126+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127+ let overlap = Map.size (Map.intersection docs exports)
128+ if Map.size exports == overlap && overlap == Map.size docs
129+ then Result.ok ()
130+ else
131+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133+ Result.ok ()
134+
135+
136+addName :: Dups -> A.Located Name.Name -> Dups
137+addName dict (A.At region name) =
138+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139+
140+
141+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142+isUnique name regions =
143+ case regions of
144+ OneOrMore.One region ->
145+ Result.ok region
146+
147+ OneOrMore.More _ _ ->
148+ let (r1:r2:_) = OneOrMore.toList regions in
149+ Result.throw (E.Duplicate name r1 r2)
150+
151+
152+onlyInDocs :: Name.Name -> A.Region -> Result i w a
153+onlyInDocs name region =
154+ Result.throw $ E.OnlyInDocs name region
155+
156+
157+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158+onlyInExports name (A.At region _) =
159+ Result.throw $ E.OnlyInExports name region
160+
161+
162+
163+-- CHECK EXPORTS
164+
165+
166+data Info =
167+ Info
168+ { _iComments :: Map.Map Name.Name Comment
169+ , _iValues :: Types
170+ , _iUnions :: Map.Map Name.Name Can.Union
171+ , _iAliases :: Map.Map Name.Name Can.Alias
172+ , _iBinops :: Map.Map Name.Name Can.Binop
173+ , _iEffects :: Can.Effects
174+ }
175+
176+
177+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178+checkExport info name (A.At region export) =
179+ case export of
180+ Can.ExportValue ->
181+ do tipe <- getType name info
182+ comment <- getComment region name info
183+ Result.ok $ \m ->
184+ m { _values = Map.insert name (Value comment tipe) (_values m) }
185+
186+ Can.ExportBinop ->
187+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188+ tipe <- getType realName info
189+ comment <- getComment region realName info
190+ Result.ok $ \m ->
191+ m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192+
193+ Can.ExportAlias ->
194+ do let (Can.Alias tvars tipe) = _iAliases info ! name
195+ comment <- getComment region name info
196+ Result.ok $ \m ->
197+ m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198+
199+ Can.ExportUnionOpen ->
200+ do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201+ comment <- getComment region name info
202+ Result.ok $ \m ->
203+ m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204+
205+ Can.ExportUnionClosed ->
206+ do let (Can.Union tvars _ _ _) = _iUnions info ! name
207+ comment <- getComment region name info
208+ Result.ok $ \m ->
209+ m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210+
211+ Can.ExportPort ->
212+ do tipe <- getType name info
213+ comment <- getComment region name info
214+ Result.ok $ \m ->
215+ m { _values = Map.insert name (Value comment tipe) (_values m) }
216+
217+
218+getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219+getComment region name info =
220+ case Map.lookup name (_iComments info) of
221+ Nothing ->
222+ Result.throw (E.NoComment name region)
223+
224+ Just comment ->
225+ Result.ok comment
226+
227+
228+getType :: Name.Name -> Info -> Result i w Type.Type
229+getType name info =
230+ case _iValues info ! name of
231+ A.At defRegion Nothing ->
232+ Result.throw (E.NoAnnotation name defRegion)
233+
234+ A.At _ (Just tipe) ->
235+ Result.ok (Extract.fromType tipe)
236+
237+
238+dector :: Can.Ctor -> (Name.Name, [Type.Type])
239+dector (Can.Ctor name _ _ args) =
240+ ( name, map Extract.fromType args )
241+
242+
243+
244+-- GATHER TYPES
245+
246+
247+type Types =
248+ Map.Map Name.Name (A.Located (Maybe Can.Type))
249+
250+
251+gatherTypes :: Can.Decls -> Types -> Types
252+gatherTypes decls types =
253+ case decls of
254+ Can.Declare def subDecls ->
255+ gatherTypes subDecls (addDef types def)
256+
257+ Can.DeclareRec defs subDecls ->
258+ gatherTypes subDecls (List.foldl' addDef types defs)
259+
260+ Can.SaveTheEnvironment ->
261+ types
262+
263+
264+addDef :: Types -> Can.Def -> Types
265+addDef types def =
266+ case def of
267+ Can.Def (A.At region name) _ _ ->
268+ Map.insert name (A.At region Nothing) types
269+
270+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271+ let
272+ tipe =
273+ foldr Can.TLambda resultType (map snd typedArgs)
274+ in
275+ Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+32−40
@@ -128,46 +128,38 @@ chompListEnd start entries =
128tuple :: A.Position -> Parser E.Expr Src.Expr
128tuple :: A.Position -> Parser E.Expr Src.Expr
129tuple start@(A.Position row col) =
129tuple start@(A.Position row col) =
130 inContext E.Tuple (word1 0x28 {-(-} E.Start) $
130 inContext E.Tuple (word1 0x28 {-(-} E.Start) $
131− do before <- getPosition
132− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
133− after <- getPosition
134− if before /= after
135− then
136− do (entry, end) <- specialize E.TupleExpr expression
137− Space.checkIndent end E.TupleIndentEnd
138− chompTupleEnd start entry []
139− else
140− oneOf E.TupleIndentExpr1
131+ oneOf E.TupleIndentExpr1
141− [
132+ [
142− do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
133+ do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
143− if op == "-"
134+ if op == "-"
144− then
135+ then
145− oneOf E.TupleOperatorClose
136+ oneOf E.TupleOperatorClose
146− [
137+ [
147− do word1 0x29 {-)-} E.TupleOperatorClose
138+ do word1 0x29 {-)-} E.TupleOperatorClose
148− addEnd start (Src.Op op)
139+ addEnd start (Src.Op op)
149− ,
140+ ,
150− do (entry, end) <-
141+ do (entry, end) <-
151− specialize E.TupleExpr $
142+ specialize E.TupleExpr $
152− do negatedExpr@(A.At (A.Region _ end) _) <- term
143+ do negatedExpr@(A.At (A.Region _ end) _) <- term
153− Space.chomp E.Space
144+ Space.chomp E.Space
154− let exprStart = A.Position row (col + 2)
145+ let exprStart = A.Position row (col + 2)
155− let expr = A.at exprStart end (Src.Negate negatedExpr)
146+ let expr = A.at exprStart end (Src.Negate negatedExpr)
156− chompExprEnd exprStart (State [] expr [] end)
147+ chompExprEnd exprStart (State [] expr [] end)
157− Space.checkIndent end E.TupleIndentEnd
148+ Space.checkIndent end E.TupleIndentEnd
158− chompTupleEnd start entry []
149+ chompTupleEnd start entry []
159− ]
150+ ]
160− else
151+ else
161− do word1 0x29 {-)-} E.TupleOperatorClose
152+ do word1 0x29 {-)-} E.TupleOperatorClose
162− addEnd start (Src.Op op)
153+ addEnd start (Src.Op op)
163− ,
154+ ,
164− do word1 0x29 {-)-} E.TupleIndentExpr1
155+ do word1 0x29 {-)-} E.TupleIndentExpr1
165− addEnd start Src.Unit
156+ addEnd start Src.Unit
166− ,
157+ ,
158+ do Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
167− do (entry, end) <- specialize E.TupleExpr expression
159+ (entry, end) <- specialize E.TupleExpr expression
168− Space.checkIndent end E.TupleIndentEnd
160+ Space.checkIndent end E.TupleIndentEnd
169− chompTupleEnd start entry []
161+ chompTupleEnd start entry []
170− ]
162+ ]
171
163
172
164
173chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
165chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
compiler/src/Parse/Module.hs+60−110
@@ -2,10 +2,7 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Module
3module Parse.Module
4 ( fromByteString
4 ( fromByteString
5− , ProjectType(..)
6− , isKernel
7 , chompImports
5 , chompImports
8− , chompImport
9 )
6 )
10 where
7 where
11
8
@@ -31,37 +28,14 @@ import qualified Reporting.Error.Syntax as E
31-- FROM BYTE STRING
28-- FROM BYTE STRING
32
29
33
30
34−fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module
31+fromByteString :: Pkg.Name -> BS.ByteString -> Either E.Error Src.Module
35−fromByteString projectType source =
32+fromByteString pkg source =
36− case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of
33+ case P.fromByteString (chompModule pkg) E.ModuleBadEnd source of
37− Right modul -> checkModule projectType modul
34+ Right modul -> checkModule modul
38 Left err -> Left (E.ParseError err)
35 Left err -> Left (E.ParseError err)
39
36
40
37
41
38
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
62−
63−
64−
65-- MODULE
39-- MODULE
66
40
67
41
@@ -74,11 +48,11 @@ data Module =
74 }
48 }
75
49
76
50
77−chompModule :: ProjectType -> Parser E.Module Module
51+chompModule :: Pkg.Name -> Parser E.Module Module
78−chompModule projectType =
52+chompModule pkg =
79 do header <- chompHeader
53 do header <- chompHeader
80− imports <- chompImports (if isCore projectType then [] else Imports.defaults)
54+ imports <- chompImports (if pkg == Pkg.core then [] else Imports.defaults)
81− infixes <- if isKernel projectType then chompInfixes [] else return []
55+ infixes <- if Pkg.isKernel pkg then chompInfixes [] else return []
82 decls <- specialize E.Declarations $ chompDecls []
56 decls <- specialize E.Declarations $ chompDecls []
83 return (Module header imports infixes decls)
57 return (Module header imports infixes decls)
84
58
@@ -87,15 +61,15 @@ chompModule projectType =
87-- CHECK MODULE
61-- CHECK MODULE
88
62
89
63
90−checkModule :: ProjectType -> Module -> Either E.Error Src.Module
64+checkModule :: Module -> Either E.Error Src.Module
91−checkModule projectType (Module maybeHeader imports infixes decls) =
65+checkModule (Module maybeHeader imports infixes decls) =
92 let
66 let
93 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
67 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
94 in
68 in
95 case maybeHeader of
69 case maybeHeader of
96 Just (Header name effects exports docs) ->
70 Just (Header name effects exports docs) ->
97 Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
71 Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
98− <$> checkEffects projectType ports effects
72+ <$> checkEffects ports effects
99
73
100 Nothing ->
74 Nothing ->
101 Right $
75 Right $
@@ -105,37 +79,23 @@ checkModule projectType (Module maybeHeader imports infixes decls) =
105 _:_ -> Src.Ports ports
79 _:_ -> Src.Ports ports
106
80
107
81
108−checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
82+checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects
109−checkEffects projectType ports effects =
83+checkEffects ports effects =
110 case effects of
84 case effects of
111 NoEffects region ->
85 NoEffects region ->
112 case ports of
86 case ports of
113− [] ->
114− Right Src.NoEffects
87+ [] -> Right Src.NoEffects
115−
116− Src.Port name _ : _ ->
117− case projectType of
118− Package _ -> Left (E.NoPortsInPackage name)
119− Application -> Left (E.UnexpectedPort region)
88+ _:_ -> Left (E.UnexpectedPort region)
120
89
121 Ports region ->
90 Ports region ->
122− case projectType of
123− Package _ ->
124− Left (E.NoPortModulesInPackage region)
125−
126− Application ->
127− case ports of
91+ case ports of
128− [] -> Left (E.NoPorts region)
92+ [] -> Left (E.NoPorts region)
129− _:_ -> Right (Src.Ports ports)
93+ _:_ -> Right (Src.Ports ports)
130
94
131 Manager region manager ->
95 Manager region manager ->
132− if isKernel projectType then
133− case ports of
96+ case ports of
134− [] -> Right (Src.Manager region manager)
97+ [] -> Right (Src.Manager region manager)
135− _:_ -> Left (E.UnexpectedPort region)
98+ _:_ -> Left (E.UnexpectedPort region)
136− else
137− Left (E.NoEffectsOutsideKernel region)
138−
139
99
140
100
141categorizeDecls :: [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] )
101categorizeDecls :: [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] )
@@ -372,33 +332,28 @@ spaces_em =
372
332
373
333
374chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
334chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
375−chompImports is =
335+chompImports imports =
376 oneOfWithFallback
336 oneOfWithFallback
377− [ do i <- chompImport
337+ [ do Keyword.import_ E.ImportStart
338+ Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
339+ name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
340+ Space.chomp E.ModuleSpace
341+ oneOf E.ImportEnd
342+ [ do Space.checkFreshLine E.ImportEnd
378− chompImports (i:is)
343+ chompImports $
344+ Src.Import name Nothing (Src.Explicit []) : imports
345+ , do Space.checkIndent end E.ImportEnd
346+ oneOf E.ImportAs
347+ [ chompAs name imports
348+ , chompExposing name Nothing imports
349+ ]
350+ ]
379 ]
351 ]
380− (reverse is)
352+ (reverse imports)
381−
382−
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
353
399
354
400−chompAs :: A.Located Name.Name -> Parser E.Module Src.Import
355+chompAs :: A.Located Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
401−chompAs name =
356+chompAs name imports =
402 do Keyword.as_ E.ImportAs
357 do Keyword.as_ E.ImportAs
403 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
358 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
404 alias <- Var.upper E.ImportAlias
359 alias <- Var.upper E.ImportAlias
@@ -406,19 +361,21 @@ chompAs name =
406 Space.chomp E.ModuleSpace
361 Space.chomp E.ModuleSpace
407 oneOf E.ImportEnd
362 oneOf E.ImportEnd
408 [ do Space.checkFreshLine E.ImportEnd
363 [ do Space.checkFreshLine E.ImportEnd
364+ chompImports $
409− return $ Src.Import name (Just alias) (Src.Explicit [])
365+ Src.Import name (Just alias) (Src.Explicit []) : imports
410 , do Space.checkIndent end E.ImportEnd
366 , do Space.checkIndent end E.ImportEnd
411− chompExposing name (Just alias)
367+ chompExposing name (Just alias) imports
412 ]
368 ]
413
369
414
370
415−chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import
371+chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
416−chompExposing name maybeAlias =
372+chompExposing name maybeAlias imports =
417 do Keyword.exposing_ E.ImportExposing
373 do Keyword.exposing_ E.ImportExposing
418 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
374 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
419 exposed <- specialize E.ImportExposingList exposing
375 exposed <- specialize E.ImportExposingList exposing
420 freshLine E.ImportEnd
376 freshLine E.ImportEnd
377+ chompImports $
421− return $ Src.Import name maybeAlias exposed
378+ Src.Import name maybeAlias exposed : imports
422
379
423
380
424
381
@@ -434,18 +391,18 @@ exposing =
434 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
391 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
435 word1 0x29 {-)-} E.ExposingEnd
392 word1 0x29 {-)-} E.ExposingEnd
436 return Src.Open
393 return Src.Open
437− , do exposed <- chompExposed
394+ , do exposed <- addLocation chompExposed
438 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
395 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
439 exposingHelp [exposed]
396 exposingHelp [exposed]
440 ]
397 ]
441
398
442
399
443−exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing
400+exposingHelp :: [A.Located Src.Exposed] -> Parser E.Exposing Src.Exposing
444exposingHelp revExposed =
401exposingHelp revExposed =
445 oneOf E.ExposingEnd
402 oneOf E.ExposingEnd
446 [ do word1 0x2C {-,-} E.ExposingEnd
403 [ do word1 0x2C {-,-} E.ExposingEnd
447 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
404 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
448− exposed <- chompExposed
405+ exposed <- addLocation chompExposed
449 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
406 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
450 exposingHelp (exposed:revExposed)
407 exposingHelp (exposed:revExposed)
451 , do word1 0x29 {-)-} E.ExposingEnd
408 , do word1 0x29 {-)-} E.ExposingEnd
@@ -455,21 +412,16 @@ exposingHelp revExposed =
455
412
456chompExposed :: Parser E.Exposing Src.Exposed
413chompExposed :: Parser E.Exposing Src.Exposed
457chompExposed =
414chompExposed =
458− do start <- getPosition
459− oneOf E.ExposingValue
415+ oneOf E.ExposingValue
460− [ do name <- Var.lower E.ExposingValue
416+ [ Src.Lower <$> Var.lower E.ExposingValue
461− end <- getPosition
462− return $ Src.Lower $ A.at start end name
463− , do word1 0x28 {-(-} E.ExposingValue
417+ , do word1 0x28 {-(-} E.ExposingValue
464− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
418+ op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
465− word1 0x29 {-)-} E.ExposingOperatorRightParen
419+ word1 0x29 {-)-} E.ExposingOperatorRightParen
466− end <- getPosition
467− return $ Src.Operator (A.Region start end) op
420+ return (Src.Operator op)
468− , do name <- Var.upper E.ExposingValue
421+ , do name <- Var.upper E.ExposingValue
469− end <- getPosition
470− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
422+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
471− Src.Upper (A.at start end name) <$> privacy
423+ Src.Upper name <$> privacy
472− ]
424+ ]
473
425
474
426
475privacy :: Parser E.Exposing Src.Privacy
427privacy :: Parser E.Exposing Src.Privacy
@@ -477,11 +429,9 @@ privacy =
477 oneOfWithFallback
429 oneOfWithFallback
478 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
430 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
479 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
431 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
480− start <- getPosition
481 word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
432 word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
482− end <- getPosition
483 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
433 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
484 word1 0x29 {-)-} E.ExposingTypePrivacy
434 word1 0x29 {-)-} E.ExposingTypePrivacy
485− return $ Src.Public (A.Region start end)
435+ return Src.Public
486 ]
436 ]
487 Src.Private
437 Src.Private
compiler/src/Parse/Pattern.hs+1−1
@@ -129,7 +129,7 @@ recordHelp start vars =
129 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
129 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
130 recordHelp start (var:vars)
130 recordHelp start (var:vars)
131 , do word1 0x7D {-}-} E.PRecordEnd
131 , do word1 0x7D {-}-} E.PRecordEnd
132− addEnd start (Src.PRecord (reverse vars))
132+ addEnd start (Src.PRecord vars)
133 ]
133 ]
134
134
135
135
compiler/src/Parse/Primitives.hs+2−2
@@ -46,7 +46,7 @@ newtype Parser x a =
46 )
46 )
47
47
48
48
49−data State = -- PERF try taking some out to avoid allocation
49+data State = -- TODO try taking some out to avoid allocation?
50 State
50 State
51 { _src :: ForeignPtr Word8
51 { _src :: ForeignPtr Word8
52 , _pos :: !(Ptr Word8)
52 , _pos :: !(Ptr Word8)
@@ -145,7 +145,7 @@ oneOfHelp state cok eok cerr eerr toError parsers =
145
145
146
146
147{-# INLINE oneOfWithFallback #-}
147{-# INLINE oneOfWithFallback #-}
148−oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values.
148+oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- TODO is this function okay? Worried about allocation/laziness with fallback values.
149oneOfWithFallback parsers fallback =
149oneOfWithFallback parsers fallback =
150 Parser $ \state cok eok cerr _ ->
150 Parser $ \state cok eok cerr _ ->
151 oowfHelp state cok eok cerr parsers fallback
151 oowfHelp state cok eok cerr parsers fallback
compiler/src/Parse/Repl.hsnew file+117
@@ -0,0 +1,117 @@
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/Space.hs+2−2
@@ -157,7 +157,7 @@ eatSpaces pos end row col =
157-- LINE COMMENTS
157-- LINE COMMENTS
158
158
159
159
160−eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
160+eatLineComment :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
161eatLineComment pos end row col =
161eatLineComment pos end row col =
162 if pos >= end then
162 if pos >= end then
163 (# Good, pos, row, col #)
163 (# Good, pos, row, col #)
@@ -208,7 +208,7 @@ data MultiStatus
208 | MultiEndless
208 | MultiEndless
209
209
210
210
211−eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)
211+eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Word16, Word16 #)
212eatMultiCommentHelp pos end row col openComments =
212eatMultiCommentHelp pos end row col openComments =
213 if pos >= end then
213 if pos >= end then
214 (# MultiEndless, pos, row, col #)
214 (# MultiEndless, pos, row, col #)
compiler/src/Parse/String.hs+2−2
@@ -165,7 +165,7 @@ addEscape chunk start end revChunks =
165-- SINGLE STRINGS
165-- SINGLE STRINGS
166
166
167
167
168−singleString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [ES.Chunk] -> StringResult
168+singleString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [ES.Chunk] -> StringResult
169singleString pos end row col initialPos revChunks =
169singleString pos end row col initialPos revChunks =
170 if pos >= end then
170 if pos >= end then
171 Err row col E.StringEndless_Single
171 Err row col E.StringEndless_Single
@@ -211,7 +211,7 @@ singleString pos end row col initialPos revChunks =
211-- MULTI STRINGS
211-- MULTI STRINGS
212
212
213
213
214−multiString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> Row -> Col -> [ES.Chunk] -> StringResult
214+multiString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> Word16 -> Word16 -> [ES.Chunk] -> StringResult
215multiString pos end row col initialPos sr sc revChunks =
215multiString pos end row col initialPos sr sc revChunks =
216 if pos >= end then
216 if pos >= end then
217 Err sr sc E.StringEndless_Multi
217 Err sr sc E.StringEndless_Multi
compiler/src/Parse/Symbol.hs+1−1
@@ -40,7 +40,7 @@ operator toExpectation toError =
40
40
41 else
41 else
42 case Name.fromPtr pos newPos of
42 case Name.fromPtr pos newPos of
43− "." -> eerr row col (toError BadDot)
43+ "." -> cerr row col (toError BadDot)
44 "|" -> cerr row col (toError BadPipe)
44 "|" -> cerr row col (toError BadPipe)
45 "->" -> cerr row col (toError BadArrow)
45 "->" -> cerr row col (toError BadArrow)
46 "=" -> cerr row col (toError BadEquals)
46 "=" -> cerr row col (toError BadEquals)
compiler/src/Parse/Variable.hs+3−3
@@ -67,7 +67,7 @@ lower toError =
67
67
68
68
69{-# NOINLINE reservedWords #-}
69{-# NOINLINE reservedWords #-}
70−reservedWords :: Set.Set Name.Name -- PERF try using a trie instead
70+reservedWords :: Set.Set Name.Name -- TODO try using a trie instead
71reservedWords =
71reservedWords =
72 Set.fromList
72 Set.fromList
73 [ "if", "then", "else"
73 [ "if", "then", "else"
@@ -149,14 +149,14 @@ foreignUpper toError =
149 let
149 let
150 !newState = P.State src upperEnd end indent row newCol
150 !newState = P.State src upperEnd end indent row newCol
151 !name = Name.fromPtr upperStart upperEnd
151 !name = Name.fromPtr upperStart upperEnd
152− !upperName =
152+ !foreign =
153 if upperStart == pos then
153 if upperStart == pos then
154 Unqualified name
154 Unqualified name
155 else
155 else
156 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
156 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
157 Qualified home name
157 Qualified home name
158 in
158 in
159− cok upperName newState
159+ cok foreign newState
160
160
161
161
162foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
162foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
compiler/src/Reporting/Annotation.hs+1−1
@@ -26,7 +26,7 @@ import Data.Word (Word16)
26
26
27
27
28data Located a =
28data Located a =
29− At Region a -- PERF see if unpacking region is helpful
29+ At Region a -- TODO see if unpacking region is helpful
30
30
31
31
32instance Functor Located where
32instance Functor Located where
compiler/src/Reporting/Doc.hs+24−18
@@ -56,7 +56,6 @@ import qualified Text.PrettyPrint.ANSI.Leijen as P
56import qualified Data.Index as Index
56import qualified Data.Index as Index
57import qualified Elm.Package as Pkg
57import qualified Elm.Package as Pkg
58import qualified Elm.Version as V
58import qualified Elm.Version as V
59−import Json.Encode ((==>))
60import qualified Json.Encode as E
59import qualified Json.Encode as E
61import qualified Json.String as Json
60import qualified Json.String as Json
62
61
@@ -172,19 +171,19 @@ toFancyHint chunks =
172-- LINKS
171-- LINKS
173
172
174
173
175−link :: String -> String -> String -> String -> P.Doc
174+link :: P.Doc -> String -> String -> String -> P.Doc
176link word before fileName after =
175link word before fileName after =
177 P.fillSep $
176 P.fillSep $
178− (P.underline (P.text word) <> ":")
177+ (P.underline word <> ":")
179 : map P.text (words before)
178 : map P.text (words before)
180 ++ P.text (makeLink fileName)
179 ++ P.text (makeLink fileName)
181 : map P.text (words after)
180 : map P.text (words after)
182
181
183
182
184−fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
183+fancyLink :: P.Doc -> [P.Doc] -> String -> [P.Doc] -> P.Doc
185fancyLink word before fileName after =
184fancyLink word before fileName after =
186 P.fillSep $
185 P.fillSep $
187− (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after
186+ (P.underline word <> ":") : before ++ P.text (makeLink fileName) : after
188
187
189
188
190makeLink :: [Char] -> [Char]
189makeLink :: [Char] -> [Char]
@@ -306,8 +305,10 @@ data Color
306 | WHITE
305 | WHITE
307
306
308
307
309−toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value]
308+toJsonHelp :: Style -> [a] -> P.SimpleDoc -> [E.Value]
310toJsonHelp style revChunks simpleDoc =
309toJsonHelp style revChunks simpleDoc =
310+ error "TODO generate json on errors" style revChunks simpleDoc sgrToStyle encodeColor
311+{-
311 case simpleDoc of
312 case simpleDoc of
312 P.SFail ->
313 P.SFail ->
313 error $
314 error $
@@ -318,18 +319,23 @@ toJsonHelp style revChunks simpleDoc =
318 [ encodeChunks style revChunks ]
319 [ encodeChunks style revChunks ]
319
320
320 P.SChar char rest ->
321 P.SChar char rest ->
321− toJsonHelp style ([char] : revChunks) rest
322+ toJsonHelp style (TB.singleton char : revChunks) rest
322
323
323 P.SText _ string rest ->
324 P.SText _ string rest ->
324− toJsonHelp style (string : revChunks) rest
325+ toJsonHelp style (TB.fromString string : revChunks) rest
325
326
326 P.SLine indent rest ->
327 P.SLine indent rest ->
327− toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest
328+ toJsonHelp style (spaces indent : "\n" : revChunks) rest
328
329
329 P.SSGR sgrs rest ->
330 P.SSGR sgrs rest ->
330 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
331 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
331
332
332
333
334+spaces :: Int -> TB.Builder
335+spaces n =
336+ TB.fromText (Text.replicate n " ")
337+-}
338+
333sgrToStyle :: [Ansi.SGR] -> Style -> Style
339sgrToStyle :: [Ansi.SGR] -> Style -> Style
334sgrToStyle sgrs style@(Style bold underline color) =
340sgrToStyle sgrs style@(Style bold underline color) =
335 case sgrs of
341 case sgrs of
@@ -390,24 +396,24 @@ toColor layer intensity color =
390 Ansi.White -> pick White WHITE
396 Ansi.White -> pick White WHITE
391 Ansi.Black -> pick Black BLACK
397 Ansi.Black -> pick Black BLACK
392
398
393−
399+{-
394−encodeChunks :: Style -> [String] -> E.Value
400+encodeChunks :: Style -> [TB.Builder] -> E.Value
395encodeChunks (Style bold underline color) revChunks =
401encodeChunks (Style bold underline color) revChunks =
396 let
402 let
397− chars = concat (reverse revChunks)
403+ !str = Utf8.concat (reverse revChunks)
398 in
404 in
399 case color of
405 case color of
400 Nothing | not bold && not underline ->
406 Nothing | not bold && not underline ->
401− E.chars chars
407+ E.string str
402
408
403 _ ->
409 _ ->
404 E.object
410 E.object
405− [ "bold" ==> E.bool bold
411+ [ ("bold", E.bool bold)
406− , "underline" ==> E.bool underline
412+ , ("underline", E.bool underline)
407− , "color" ==> maybe E.null encodeColor color
413+ , ("color", maybe E.null encodeColor color)
408− , "string" ==> E.chars chars
414+ , ("string", E.string str)
409 ]
415 ]
410−
416+-}
411
417
412encodeColor :: Color -> E.Value
418encodeColor :: Color -> E.Value
413encodeColor color =
419encodeColor color =
compiler/src/Reporting/Error.hs+26−32
@@ -10,9 +10,10 @@ module Reporting.Error
10
10
11
11
12import qualified Data.ByteString as B
12import qualified Data.ByteString as B
13+import qualified Data.Name as Name
13import qualified Data.NonEmptyList as NE
14import qualified Data.NonEmptyList as NE
14import qualified Data.OneOrMore as OneOrMore
15import qualified Data.OneOrMore as OneOrMore
15−import qualified System.FilePath as FP
16+import qualified Data.Utf8 as Utf8
16
17
17import qualified Elm.ModuleName as ModuleName
18import qualified Elm.ModuleName as ModuleName
18import qualified File
19import qualified File
@@ -21,7 +22,6 @@ import Json.Encode ((==>))
21import qualified Reporting.Annotation as A
22import qualified Reporting.Annotation as A
22import qualified Reporting.Doc as D
23import qualified Reporting.Doc as D
23import qualified Reporting.Error.Canonicalize as Canonicalize
24import qualified Reporting.Error.Canonicalize as Canonicalize
24−import qualified Reporting.Error.Docs as Docs
25import qualified Reporting.Error.Import as Import
25import qualified Reporting.Error.Import as Import
26import qualified Reporting.Error.Main as Main
26import qualified Reporting.Error.Main as Main
27import qualified Reporting.Error.Pattern as Pattern
27import qualified Reporting.Error.Pattern as Pattern
@@ -39,8 +39,8 @@ import qualified Reporting.Report as Report
39data Module =
39data Module =
40 Module
40 Module
41 { _name :: ModuleName.Raw
41 { _name :: ModuleName.Raw
42− , _absolutePath :: FilePath
42+ , _path :: FilePath
43− , _modificationTime :: File.Time
43+ , _time :: File.Time
44 , _source :: B.ByteString
44 , _source :: B.ByteString
45 , _error :: Error
45 , _error :: Error
46 }
46 }
@@ -57,7 +57,6 @@ data Error
57 | BadTypes L.Localizer (NE.List Type.Error)
57 | BadTypes L.Localizer (NE.List Type.Error)
58 | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error)
58 | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error)
59 | BadPatterns (NE.List Pattern.Error)
59 | BadPatterns (NE.List Pattern.Error)
60− | BadDocs Docs.Error
61
60
62
61
63
62
@@ -85,34 +84,32 @@ toReports source err =
85 BadPatterns errs ->
84 BadPatterns errs ->
86 fmap (Pattern.toReport source) errs
85 fmap (Pattern.toReport source) errs
87
86
88− BadDocs docsErr ->
89− Docs.toReports source docsErr
90−
91
87
92
88
93-- TO DOC
89-- TO DOC
94
90
95
91
96−toDoc :: FilePath -> Module -> [Module] -> D.Doc
92+toDoc :: Module -> [Module] -> D.Doc
97−toDoc root err errs =
93+toDoc err errs =
98 let
94 let
95+ timeCompare m1 m2 = compare (_time m1) (_time m2)
99− (NE.List m ms) = NE.sortBy _modificationTime (NE.List err errs)
96+ (NE.List m ms) = NE.sortBy timeCompare (NE.List err errs)
100 in
97 in
101− D.vcat (toDocHelp root m ms)
98+ D.vcat (toDocHelp m ms)
102
99
103
100
104−toDocHelp :: FilePath -> Module -> [Module] -> [D.Doc]
101+toDocHelp :: Module -> [Module] -> [D.Doc]
105−toDocHelp root module1 modules =
102+toDocHelp module1 modules =
106 case modules of
103 case modules of
107 [] ->
104 [] ->
108− [moduleToDoc root module1
105+ [moduleToDoc module1
109 ,""
106 ,""
110 ]
107 ]
111
108
112 module2 : otherModules ->
109 module2 : otherModules ->
113− moduleToDoc root module1
110+ moduleToDoc module1
114 : toSeparator module1 module2
111 : toSeparator module1 module2
115− : toDocHelp root module2 otherModules
112+ : toDocHelp module2 otherModules
116
113
117
114
118toSeparator :: Module -> Module -> D.Doc
115toSeparator :: Module -> Module -> D.Doc
@@ -134,22 +131,19 @@ toSeparator beforeModule afterModule =
134-- MODULE TO DOC
131-- MODULE TO DOC
135
132
136
133
137−moduleToDoc :: FilePath -> Module -> D.Doc
134+moduleToDoc :: Module -> D.Doc
138−moduleToDoc root (Module _ absolutePath _ source err) =
135+moduleToDoc (Module _ path _ source err) =
139 let
136 let
140 reports =
137 reports =
141 toReports (Code.toSource source) err
138 toReports (Code.toSource source) err
142−
143− relativePath =
144− FP.makeRelative root absolutePath
145 in
139 in
146− D.vcat $ map (reportToDoc relativePath) (NE.toList reports)
140+ D.vcat $ map (reportToDoc path) (NE.toList reports)
147
141
148
142
149reportToDoc :: FilePath -> Report.Report -> D.Doc
143reportToDoc :: FilePath -> Report.Report -> D.Doc
150−reportToDoc relativePath (Report.Report title _ _ message) =
144+reportToDoc path (Report.Report title _ _ message) =
151 D.vcat
145 D.vcat
152− [ toMessageBar title relativePath
146+ [ toMessageBar title path
153 , ""
147 , ""
154 , message
148 , message
155 , ""
149 , ""
@@ -179,8 +173,8 @@ toJson (Module name path _ source err) =
179 toReports (Code.toSource source) err
173 toReports (Code.toSource source) err
180 in
174 in
181 E.object
175 E.object
182− [ "path" ==> E.chars path
176+ [ "path" ==> E.string (Utf8.fromChars path)
183− , "name" ==> E.name name
177+ , "name" ==> E.string (Name.toUtf8 name)
184 , "problems" ==> E.array (map reportToJson (NE.toList reports))
178 , "problems" ==> E.array (map reportToJson (NE.toList reports))
185 ]
179 ]
186
180
@@ -188,7 +182,7 @@ toJson (Module name path _ source err) =
188reportToJson :: Report.Report -> E.Value
182reportToJson :: Report.Report -> E.Value
189reportToJson (Report.Report title region _sgstns message) =
183reportToJson (Report.Report title region _sgstns message) =
190 E.object
184 E.object
191− [ "title" ==> E.chars title
185+ [ "title" ==> E.string (Utf8.fromChars title)
192 , "region" ==> encodeRegion region
186 , "region" ==> encodeRegion region
193 , "message" ==> D.encode message
187 , "message" ==> D.encode message
194 ]
188 ]
@@ -199,12 +193,12 @@ encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
199 E.object
193 E.object
200 [ "start" ==>
194 [ "start" ==>
201 E.object
195 E.object
202− [ "line" ==> E.int (fromIntegral sr)
196+ [ ("line", E.int (fromIntegral sr))
203− , "column" ==> E.int (fromIntegral sc)
197+ , ("column", E.int (fromIntegral sc))
204 ]
198 ]
205 , "end" ==>
199 , "end" ==>
206 E.object
200 E.object
207− [ "line" ==> E.int (fromIntegral er)
201+ [ ("line", E.int (fromIntegral er))
208− , "column" ==> E.int (fromIntegral ec)
202+ , ("column", E.int (fromIntegral ec))
209 ]
203 ]
210 ]
204 ]
compiler/src/Reporting/Error/Canonicalize.hs+40−41
@@ -14,10 +14,8 @@ module Reporting.Error.Canonicalize
14
14
15
15
16import qualified Data.Char as Char
16import qualified Data.Char as Char
17−import qualified Data.List as List
18import qualified Data.Map as Map
17import qualified Data.Map as Map
19import qualified Data.Name as Name
18import qualified Data.Name as Name
20−import qualified Data.OneOrMore as OneOrMore
21import qualified Data.Set as Set
19import qualified Data.Set as Set
22
20
23import qualified AST.Canonical as Can
21import qualified AST.Canonical as Can
@@ -39,10 +37,10 @@ import qualified Reporting.Suggest as Suggest
39
37
40data Error
38data Error
41 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
39 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
42− | AmbiguousVar A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
40+ | AmbiguousVar A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
43− | AmbiguousType A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
41+ | AmbiguousType A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
44− | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
42+ | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
45− | AmbiguousBinop A.Region Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
43+ | AmbiguousBinop A.Region Name.Name [ModuleName.Canonical]
46 | BadArity A.Region BadArityContext Name.Name Int Int
44 | BadArity A.Region BadArityContext Name.Name Int Int
47 | Binop A.Region Name.Name Name.Name
45 | Binop A.Region Name.Name Name.Name
48 | DuplicateDecl Name.Name A.Region A.Region
46 | DuplicateDecl Name.Name A.Region A.Region
@@ -166,17 +164,17 @@ toReport source err =
166 <> " be deleted? Maybe some parentheses are missing?"
164 <> " be deleted? Maybe some parentheses are missing?"
167 )
165 )
168
166
169− AmbiguousVar region maybePrefix name h hs ->
167+ AmbiguousVar region maybePrefix name possibleHomes ->
170− ambiguousName source region maybePrefix name h hs "variable"
168+ ambiguousName source region maybePrefix name possibleHomes "variable"
171
169
172− AmbiguousType region maybePrefix name h hs ->
170+ AmbiguousType region maybePrefix name possibleHomes ->
173− ambiguousName source region maybePrefix name h hs "type"
171+ ambiguousName source region maybePrefix name possibleHomes "type"
174
172
175− AmbiguousVariant region maybePrefix name h hs ->
173+ AmbiguousVariant region maybePrefix name possibleHomes ->
176− ambiguousName source region maybePrefix name h hs "variant"
174+ ambiguousName source region maybePrefix name possibleHomes "variant"
177
175
178− AmbiguousBinop region name h hs ->
176+ AmbiguousBinop region name possibleHomes ->
179− ambiguousName source region Nothing name h hs "operator"
177+ ambiguousName source region Nothing name possibleHomes "operator"
180
178
181 BadArity region badArityContext name expected actual ->
179 BadArity region badArityContext name expected actual ->
182 let
180 let
@@ -244,11 +242,11 @@ toReport source err =
244
242
245 DuplicateAliasArg typeName name r1 r2 ->
243 DuplicateAliasArg typeName name r1 r2 ->
246 nameClash source r1 r2 $
244 nameClash source r1 r2 $
247− "The `" <> Name.toChars typeName <> "` type alias has multiple `" <> Name.toChars name <> "` type variables."
245+ "The `" <> Name.toChars typeName <> "` type alias has multilpe `" <> Name.toChars name <> "` type variables."
248
246
249 DuplicateUnionArg typeName name r1 r2 ->
247 DuplicateUnionArg typeName name r1 r2 ->
250 nameClash source r1 r2 $
248 nameClash source r1 r2 $
251− "The `" <> Name.toChars typeName <> "` type has multiple `" <> Name.toChars name <> "` type variables."
249+ "The `" <> Name.toChars typeName <> "` type has multilpe `" <> Name.toChars name <> "` type variables."
252
250
253 DuplicatePattern context name r1 r2 ->
251 DuplicatePattern context name r1 r2 ->
254 nameClash source r1 r2 $
252 nameClash source r1 r2 $
@@ -276,7 +274,7 @@ toReport source err =
276 "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
274 "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
277 ,
275 ,
278 D.reflow $
276 D.reflow $
279− "But I cannot find a custom type named `" ++ Name.toChars name ++ "` in this file!"
277+ "But I cannot find a union type named `" ++ Name.toChars name ++ "` in this file!"
280 )
278 )
281
279
282 EffectFunctionNotFound region name ->
280 EffectFunctionNotFound region name ->
@@ -344,7 +342,7 @@ toReport source err =
344 Code.toSnippet source region Nothing
342 Code.toSnippet source region Nothing
345 (
343 (
346 D.reflow $
344 D.reflow $
347− "The (..) syntax is for exposing variants of a custom type. It cannot be used with a type alias like `"
345+ "The (..) syntax is for exposing union type constructors. It cannot be used with a type alias like `"
348 ++ Name.toChars name ++ "` though."
346 ++ Name.toChars name ++ "` though."
349 ,
347 ,
350 D.reflow $
348 D.reflow $
@@ -357,12 +355,12 @@ toReport source err =
357 (
355 (
358 D.reflow $
356 D.reflow $
359 "You are trying to import the `" <> Name.toChars ctor
357 "You are trying to import the `" <> Name.toChars ctor
360− <> "` variant by name:"
358+ <> "` type constructor by name:"
361 ,
359 ,
362 D.fillSep
360 D.fillSep
363 ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
361 ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
364 ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
362 ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
365− ,"all","its","variants","so","it","gives","you","access","to"
363+ ,"all","its","constructors”","so","it","gives","you","access","to"
366 , D.fromName ctor <> "."
364 , D.fromName ctor <> "."
367 ]
365 ]
368 )
366 )
@@ -388,8 +386,13 @@ toReport source err =
388 D.reflow $
386 D.reflow $
389 "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
387 "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
390 ,
388 ,
391− D.reflow $
389+ D.stack
392− "Remove the (..) and it should work."
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+ ]
393 )
396 )
394
397
395 ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
398 ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
@@ -519,7 +522,7 @@ toReport source err =
519 <> "` as a function, but it is not available in pattern matching like this:"
522 <> "` as a function, but it is not available in pattern matching like this:"
520 ,
523 ,
521 D.reflow $
524 D.reflow $
522− "I recommend matching the record as a variable and unpacking it later."
525+ "I recommend matching matching the record as a variable and unpacking it later."
523 )
526 )
524
527
525 PortPayloadInvalid region portName _badType invalidPayload ->
528 PortPayloadInvalid region portName _badType invalidPayload ->
@@ -679,7 +682,7 @@ toReport source err =
679 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
682 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
680 ,
683 ,
681 D.stack
684 D.stack
682− [ makeTheory "Are you trying to mutate a variable?" $
685+ [ makeTheory "Are you are trying to mutate a variable?" $
683 "Elm does not have mutation, so when I see " ++ Name.toChars name
686 "Elm does not have mutation, so when I see " ++ Name.toChars name
684 ++ " defined in terms of " ++ Name.toChars name
687 ++ " defined in terms of " ++ Name.toChars name
685 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
688 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -725,7 +728,7 @@ toReport source err =
725 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
728 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
726 ,
729 ,
727 D.stack
730 D.stack
728− [ makeTheory "Are you trying to mutate a variable?" $
731+ [ makeTheory "Are you are trying to mutate a variable?" $
729 "Elm does not have mutation, so when I see " ++ Name.toChars name
732 "Elm does not have mutation, so when I see " ++ Name.toChars name
730 ++ " defined in terms of " ++ Name.toChars name
733 ++ " defined in terms of " ++ Name.toChars name
731 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
734 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -976,32 +979,28 @@ nameClash source r1 r2 messageThatEndsWithPunctuation =
976-- AMBIGUOUS NAME
979-- AMBIGUOUS NAME
977
980
978
981
979−ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> ModuleName.Canonical -> OneOrMore.OneOrMore ModuleName.Canonical -> String -> Report.Report
982+ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> [ModuleName.Canonical] -> String -> Report.Report
980−ambiguousName source region maybePrefix name h hs thing =
983+ambiguousName source region maybePrefix name possibleHomes thing =
981− let
982− possibleHomes = List.sort (h : OneOrMore.destruct (:) hs)
983− in
984 Report.Report "AMBIGUOUS NAME" region [] $
984 Report.Report "AMBIGUOUS NAME" region [] $
985 Code.toSnippet source region Nothing $
985 Code.toSnippet source region Nothing $
986 case maybePrefix of
986 case maybePrefix of
987 Nothing ->
987 Nothing ->
988 let
988 let
989 homeToYellowDoc (ModuleName.Canonical _ home) =
989 homeToYellowDoc (ModuleName.Canonical _ home) =
990− D.dullyellow (D.fromName home <> "." <> D.fromName name)
990+ D.dullyellow (D.fromName home)
991+
992+ bothOrAll =
993+ if length possibleHomes == 2 then "both" else "all"
991 in
994 in
992 (
995 (
993− D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous:"
996+ D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous."
994 ,
997 ,
995 D.stack
998 D.stack
996 [ D.reflow $
999 [ D.reflow $
997− "This name is exposed by " ++ show (length possibleHomes) ++ " of your imports, so I am not\
1000+ "Check your imports. The following modules " ++ bothOrAll
998− \ sure which one to use:"
1001+ ++ " expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ":"
999 , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
1002 , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
1000− , D.reflow $
1003+ , D.reflowLink "Read" "imports" "to learn how to clarify which one you want."
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."
1005 ]
1004 ]
1006 )
1005 )
1007
1006
@@ -1009,9 +1008,9 @@ ambiguousName source region maybePrefix name h hs thing =
1009 let
1008 let
1010 homeToYellowDoc (ModuleName.Canonical _ home) =
1009 homeToYellowDoc (ModuleName.Canonical _ home) =
1011 if prefix == home then
1010 if prefix == home then
1012− D.cyan "import" <+> D.fromName home
1011+ D.blue "import" <+> D.dullyellow (D.fromName home)
1013 else
1012 else
1014− D.cyan "import" <+> D.fromName home <+> D.cyan "as" <+> D.fromName prefix
1013+ D.blue "import" <+> D.dullyellow (D.fromName home) <+> D.blue "as" <+> D.dullyellow (D.fromName prefix)
1015
1014
1016 eitherOrAny =
1015 eitherOrAny =
1017 if length possibleHomes == 2 then "either" else "any"
1016 if length possibleHomes == 2 then "either" else "any"
compiler/src/Reporting/Error/Docs.hs+4−69
@@ -35,7 +35,7 @@ data Error
35data SyntaxProblem
35data SyntaxProblem
36 = Op Row Col
36 = Op Row Col
37 | OpBad BadOperator Row Col
37 | OpBad BadOperator Row Col
38− | Name Row Col
38+ | Export Row Col
39 | Space E.Space Row Col
39 | Space E.Space Row Col
40 | Comma Row Col
40 | Comma Row Col
41 | BadEnd Row Col
41 | BadEnd Row Col
@@ -69,7 +69,7 @@ toReports source err =
69 \ declaration and the imports."
69 \ declaration and the imports."
70 ,
70 ,
71 D.reflow
71 D.reflow
72− "Learn more at <https://package.elm-lang.org/help/documentation-format>"
72+ "Learn more at <http://package.elm-lang.org/help/documentation-format>"
73 )
73 )
74
74
75 ImplicitExposing region ->
75 ImplicitExposing region ->
@@ -88,9 +88,8 @@ toReports source err =
88 \ it will be easy to understand as people read the documentation!"
88 \ it will be easy to understand as people read the documentation!"
89 )
89 )
90
90
91− SyntaxProblem problem ->
91+ SyntaxProblem _ ->
92− NE.singleton $
92+ error "TODO SyntaxProblem in docs"
93− toSyntaxProblemReport source problem
94
93
95 NameProblems problems ->
94 NameProblems problems ->
96 fmap (toNameProblemReport source) problems
95 fmap (toNameProblemReport source) problems
@@ -99,66 +98,6 @@ toReports source err =
99 fmap (toDefProblemReport source) problems
98 fmap (toDefProblemReport source) problems
100
99
101
100
102−
103−-- SYNTAX PROBLEM
104−
105−
106−toSyntaxProblemReport :: Code.Source -> SyntaxProblem -> Report.Report
107−toSyntaxProblemReport source problem =
108− let
109− toSyntaxReport row col details =
110− let
111− region = toRegion row col
112− in
113− Report.Report "PROBLEM IN DOCS" region [] $
114− Code.toSnippet source region Nothing
115− ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:"
116− , D.stack $
117− [ D.reflow details
118− , D.toSimpleHint $
119− "Read through <https://package.elm-lang.org/help/documentation-format> for\
120− \ tips on how to write module documentation!"
121− ]
122− )
123− in
124− case problem of
125− Op row col ->
126− toSyntaxReport row col $
127− "I am trying to parse an operator like (+) or (*) but something is going wrong."
128−
129− OpBad _ row col ->
130− toSyntaxReport row col $
131− "I am trying to parse an operator like (+) or (*) but it looks like you are using\
132− \ a reserved symbol in this case."
133−
134− Name row col ->
135− toSyntaxReport row col $
136− "I was expecting to see the name of another exposed value from this module."
137−
138− Space space row col ->
139− E.toSpaceReport source space row col
140−
141− Comma row col ->
142− toSyntaxReport row col $
143− "I was expecting to see a comma next."
144−
145− BadEnd row col ->
146− toSyntaxReport row col $
147− "I am not really sure what I am getting stuck on though."
148−
149−
150−toRegion :: Row -> Col -> A.Region
151−toRegion row col =
152− let
153− pos = A.Position row col
154− in
155− A.Region pos pos
156−
157−
158−
159−-- NAME PROBLEM
160−
161−
162toNameProblemReport :: Code.Source -> NameProblem -> Report.Report
101toNameProblemReport :: Code.Source -> NameProblem -> Report.Report
163toNameProblemReport source problem =
102toNameProblemReport source problem =
164 case problem of
103 case problem of
@@ -212,10 +151,6 @@ toNameProblemReport source problem =
212 )
151 )
213
152
214
153
215−
216−-- DEF PROBLEM
217−
218−
219toDefProblemReport :: Code.Source -> DefProblem -> Report.Report
154toDefProblemReport :: Code.Source -> DefProblem -> Report.Report
220toDefProblemReport source problem =
155toDefProblemReport source problem =
221 case problem of
156 case problem of
compiler/src/Reporting/Error/Import.hs+1−1
@@ -56,7 +56,7 @@ toReport source (Error region name unimportedModules problem) =
56 D.stack
56 D.stack
57 [
57 [
58 D.reflow $
58 D.reflow $
59− "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json,\
59+ "I checked the \"dependencies\" and \"source-directories\" listend in your elm.json,\
60 \ but I cannot find it! Maybe it is a typo for one of these names?"
60 \ but I cannot find it! Maybe it is a typo for one of these names?"
61 ,
61 ,
62 D.dullyellow $ D.indent 4 $ D.vcat $
62 D.dullyellow $ D.indent 4 $ D.vcat $
compiler/src/Reporting/Error/Json.hs+269−281
@@ -1,344 +1,332 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Json
3module Reporting.Error.Json
4+ ( Error(..)
5+ , Problem(..)
6+ , DecodeExpectation(..)
7+ , ParseError(..)
4− ( toReport
8+ , toReport
5− , FailureToReport(..)
6− , Context(..)
7− , Reason(..)
8 )
9 )
9 where
10 where
10
11
11
12
12−import qualified Data.ByteString as BS
13+import qualified Data.Utf8 as Utf8
13−import qualified Data.ByteString.UTF8 as BS_UTF8
14+import Data.Word (Word16)
14−import qualified Data.NonEmptyList as NE
15
15
16−import Json.Decode (Error(..), Problem(..), DecodeExpectation(..), ParseError(..), StringProblem(..))
17−import qualified Reporting.Annotation as A
16+import qualified Reporting.Report as Report
18−import qualified Reporting.Doc as D
19−import qualified Reporting.Exit.Help as Help
20−import qualified Reporting.Render.Code as Code
21
17
22
18
23
19
24−-- TO REPORT
20+-- ERROR
25
21
26
22
27−toReport :: FilePath -> FailureToReport x -> Error x -> Reason -> Help.Report
23+data Error e
28−toReport path ftr err reason =
29− case err of
30− DecodeProblem bytes problem ->
24+ = DecodeProblem (Problem e)
31− problemToReport path ftr (Code.toSource bytes) CRoot problem reason
25+ | ParseProblem ParseError
32
26
33− ParseProblem bytes parseError ->
34− parseErrorToReport path (Code.toSource bytes) parseError reason
35
27
36
28
37−newtype Reason =
29+-- DECODE PROBLEMS
38− ExplicitReason String
39
30
40
31
41−because :: Reason -> String -> String
32+data Problem e
42−because (ExplicitReason iNeedThings) problem =
33+ = Field Utf8.String (Problem e)
43− iNeedThings ++ " " ++ problem
34+ | Index Int (Problem e)
35+ | OneOf (Problem e) [Problem e]
36+ | Failure e
37+ | Expecting DecodeExpectation
44
38
45
39
40+data DecodeExpectation
41+ = TObject
42+ | TArray
43+ | TString
44+ | TBool
45+ | TInt
46+ | TObjectWith Utf8.String
47+ | TArrayPair Int
46
48
47−-- PARSE ERROR TO REPORT
48
49
49
50
50−parseErrorToReport :: FilePath -> Code.Source -> ParseError -> Reason -> Help.Report
51+-- PARSE ERROR
51−parseErrorToReport path source parseError reason =
52− let
53− toSnippet title row col (problem, details) =
54− let
55− pos = A.Position row col
56− surroundings = A.Region (A.Position (max 1 (row - 2)) 1) pos
57− region = A.Region pos pos
58− in
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− ,
71− D.stack
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!"
80− ]
81− )
82
52
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− )
101
53
102− ObjectColon row col ->
54+data ParseError
103− toSnippet "EXPECTING COLON" row col
55+ = PIndex Int ParseError Row Col
104− (
56+ | PField Utf8.String ParseError Row Col
105− "I was partway through parsing a JSON object when I got stuck here:"
57+ | ObjectStart Row Col
106− ,
58+ | ObjectMore Row Col
107− D.stack
59+ | ObjectEnd Row Col
108− [ D.reflow $ "I was expecting to see a colon next."
60+ | ArrayStart Row Col
109− , objectNote
61+ | ArrayMore Row Col
110− ]
62+ | ArrayEnd Row Col
111− )
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
112
73
113− ObjectEnd row col ->
74+
114− toSnippet "UNFINISHED OBJECT" row col
75+type Row = Word16
115− (
76+type Col = Word16
116− "I was partway through parsing a JSON object when I got stuck here:"
77+
117− ,
78+
79+
80+-- TO REPORT
81+
82+
83+toReport :: Error e -> Report.Report
84+toReport err =
85+ error "TODO Reporting.Error.Json.toReport" err
86+
87+
88+{-
89+
90+-- ERROR
91+
92+
93+data Error e
94+ = BadJson Syntax.Error
95+ | BadContent (Json.Error e)
96+
97+
98+
99+-- TO DOC
100+
101+
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
118− D.stack
126+ D.stack $
119 [ D.reflow $
127 [ D.reflow $
120− "I was expecting to see a comma or a closing curly brace next."
128+ "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"
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 ]
129 ]
126− )
130+ ++ zipWith toNumberedDoc [1..] flatErrors
131+
132+
133+
134+-- FLAT ERROR TO DOC
127
135
128− ArrayEnd row col ->
136+
129− toSnippet "UNFINISHED ARRAY" row col
137+flatErrorToDoc :: String -> [D.Doc] -> (e -> [D.Doc]) -> FlatError e -> D.Doc
130− (
138+flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =
131− "I was partway through parsing a JSON array when I got stuck here:"
139+ case theories of
132− ,
140+ [] ->
141+ let
142+ explanation =
143+ case theory of
144+ Failure userError ->
145+ userErrorToDocs userError
146+
147+ Expecting tipe ->
148+ ["I","was","expecting"] ++ anExpectedThing tipe
149+ in
150+ case accesses of
151+ [] ->
152+ D.fillSep (starter ++ explanation)
153+
154+ _ ->
133 D.stack
155 D.stack
134− [ D.reflow $ "I was expecting to see a comma or a closing square bracket next."
156+ [ D.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]
135− , D.reflow $
157+ , D.fillSep explanation
136− "Is a comma missing on the previous line? It is often something like that!"
137 ]
158 ]
138− )
159+
139−
160+ _:_ ->
140− StringProblem stringProblem row col ->
161+ let
141− case stringProblem of
162+ introduction =
142− BadStringEnd ->
163+ case accesses of
143− toSnippet "ENDLESS STRING" row col
164+ [] ->
144− (
165+ ["I","am","having","trouble","with","the"]
145− "I got to the end of the line without seeing the closing double quote:"
166+ ++ actualThing json
146− ,
167+ ++ ["here","because:"]
147− D.fillSep $
168+
148− ["Strings","look","like",D.green "\"this\"","with","double"
169+ _ ->
149− ,"quotes","on","each","end.","Is","the","closing","double"
170+ ["I","am","having","trouble","with","the"]
150− ,"quote","missing","in","your","code?"
171+ ++ actualThing json
151− ]
172+ ++ ["at",accessToDoc rootName accesses,"because:"]
152− )
173+ in
153−
174+ D.stack
154− BadStringControlChar ->
175+ [ D.fillSep (starter ++ introduction)
155− toSnippet "UNEXPECTED CONTROL CHARACTER" row col
176+ , D.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)
156− (
177+ , D.reflow "I accept any of these things."
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 ]
178 ]
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− ]
236
179
237
180
181+accessToDoc :: String -> [String] -> D.Doc
182+accessToDoc rootName accesses =
183+ D.dullyellow (D.fromString (rootName ++ concat accesses))
238
184
239−-- PROBLEM TO REPORT
240
185
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"]
241
196
242−data Context
243− = CRoot
244− | CField BS.ByteString Context
245− | CIndex Int Context
246
197
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+ ]
247
211
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
253
212
254− Index index prob ->
213+toBullet :: [D.Doc] -> (e -> [D.Doc]) -> Theory e -> D.Doc
255− problemToReport path ftr source (CIndex index context) prob reason
214+toBullet intro userErrorToDocs theory =
215+ D.indent 4 $ D.fillSep $ (++) intro $
216+ case theory of
217+ Failure userError ->
218+ userErrorToDocs userError
256
219
257− OneOf p ps ->
220+ Expecting tipe ->
258− -- NOTE: only displays the deepest problem. This works well for the kind
221+ ["I","was","expecting"] ++ anExpectedThing tipe
259− -- of JSON used by Elm, but probably would not work well in general.
222+
260− let
223+
261− (NE.List prob _) = NE.sortBy (negate . getMaxDepth) (NE.List p ps)
224+
262− in
225+-- TO FLAT ERRORS
263− problemToReport path ftr source context prob reason
264
226
265− Failure region x ->
266− _failureToReport ftr path source context region x
267
227
268− Expecting region expectation ->
228+data FlatError e =
269− expectationToReport path source context region expectation reason
229+ FlatError [String] E.Value (Theory e) [Theory e]
270
230
271
231
272−getMaxDepth :: Problem x -> Int
232+data Theory e
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
233+ = Failure e
279− Expecting _ _ -> 0
234+ | Expecting Json.Type
280
235
281
236
282−newtype FailureToReport x =
237+flatten :: Json.Error e -> [FlatError e]
283− FailureToReport { _failureToReport :: FilePath -> Code.Source -> Context -> A.Region -> x -> Help.Report }
238+flatten jsonError =
239+ let
240+ depth (FlatError accesses _ _ _) =
241+ length accesses
242+ in
243+ List.sortOn depth $ flattenTree (toErrorTree jsonError)
284
244
285
245
286−expectationToReport :: FilePath -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Reason -> Help.Report
246+flattenTree :: ErrorTree e -> [FlatError e]
287−expectationToReport path source context (A.Region start end) expectation reason =
247+flattenTree (ErrorTree theories subTrees) =
288 let
248 let
289− (A.Position sr _) = start
249+ addAccess access (FlatError accesses json t ts) =
290− (A.Position er _) = end
250+ FlatError (access:accesses) json t ts
291
251
292− region =
252+ toFlats (name, tree) =
293− if sr == er then region else A.Region start start
253+ map (addAccess name) (flattenTree tree)
254+
255+ subErrors =
256+ concatMap toFlats (Map.toList subTrees)
257+ in
258+ case theories of
259+ [] ->
260+ subErrors
294
261
295− introduction =
262+ (json, theory) : rest ->
296− case context of
263+ FlatError [] json theory (map snd rest) : subErrors
297− CRoot ->
298− "I ran into some trouble here:"
299
264
300− CField field _ ->
301− "I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:"
302
265
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:"
306
266
307− CIndex index _ ->
267+-- TO ERROR TREE
308− "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:"
309
268
310− toSnippet title aThing =
269+
311− Help.jsonReport title (Just path) $
270+data ErrorTree e =
312− Code.toSnippet source region Nothing
271+ ErrorTree
313− ( D.reflow (because reason introduction)
272+ { _theories :: [(E.Value, Theory e)]
314− , D.fillSep $ ["I","was","expecting","to","run","into"] ++ aThing
273+ , _subErrors :: Map.Map String (ErrorTree e)
315− )
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))
316 in
311 in
317− case expectation of
312+ Map.alter subAdd name subErrors
318− TObject ->
319− toSnippet "EXPECTING OBJECT" ["an", D.green "OBJECT" <> "."]
320
313
321− TArray ->
322− toSnippet "EXPECTING ARRAY" ["an", D.green "ARRAY" <> "."]
323
314
324− TString ->
315+fieldToName :: Text.Text -> String
325− toSnippet "EXPECTING STRING" ["a", D.green "STRING" <> "."]
316+fieldToName field =
317+ case Text.unpack field of
318+ [] ->
319+ "['']"
326
320
327− TBool ->
321+ string@(char : rest) ->
328− toSnippet "EXPECTING BOOL" ["a", D.green "BOOLEAN" <> "."]
322+ if Char.isAlpha char && all Char.isAlphaNum rest then
323+ '.' : string
324+ else
325+ "['" ++ string ++ "']"
329
326
330− TInt ->
331− toSnippet "EXPECTING INT" ["an", D.green "INT" <> "."]
332
327
333− TObjectWith field ->
328+indexToName :: Int -> String
334− toSnippet "MISSING FIELD"
329+indexToName index =
335− ["an",D.green "OBJECT","with","a"
330+ "[" ++ show index ++ "]"
336− ,D.green ("\"" <> D.fromChars (BS_UTF8.toString field) <> "\"")
337− ,"field."
338− ]
339
331
340− TArrayPair len ->
332+-}
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+2−2
@@ -41,7 +41,7 @@ toReport source err =
41 Report.Report "UNSAFE PATTERN" region [] $
41 Report.Report "UNSAFE PATTERN" region [] $
42 Code.toSnippet source region Nothing
42 Code.toSnippet source region Nothing
43 (
43 (
44− "This pattern does not cover all possibilities:"
44+ "This pattern does not cover all possiblities:"
45 ,
45 ,
46 D.stack
46 D.stack
47 [ "Other possibilities include:"
47 [ "Other possibilities include:"
@@ -64,7 +64,7 @@ toReport source err =
64 , unhandledPatternsToDocBlock unhandled
64 , unhandledPatternsToDocBlock unhandled
65 , D.reflow $
65 , D.reflow $
66 "I would have to crash if I saw one of those! You can use\
66 "I would have to crash if I saw one of those! You can use\
67− \ `let` to deconstruct values only if there is ONE possibility.\
67+ \ `let` to deconstruct values only if there is ONE possiblity.\
68 \ Switch to a `case` expression to account for all possibilities."
68 \ Switch to a `case` expression to account for all possibilities."
69 , D.toSimpleHint $
69 , D.toSimpleHint $
70 "Are you calling a function that definitely returns values\
70 "Are you calling a function that definitely returns values\
compiler/src/Reporting/Error/Syntax.hs+458−1034
@@ -2,7 +2,6 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Syntax
3module Reporting.Error.Syntax
4 ( Error(..)
4 ( Error(..)
5− , toReport
6 --
5 --
7 , Module(..)
6 , Module(..)
8 , Exposing(..)
7 , Exposing(..)
@@ -40,7 +39,7 @@ module Reporting.Error.Syntax
40 , Number(..)
39 , Number(..)
41 --
40 --
42 , Space(..)
41 , Space(..)
43− , toSpaceReport
42+ , toReport
44 )
43 )
45 where
44 where
46
45
@@ -69,9 +68,6 @@ data Error
69 | ModuleNameMismatch ModuleName.Raw (A.Located ModuleName.Raw)
68 | ModuleNameMismatch ModuleName.Raw (A.Located ModuleName.Raw)
70 | UnexpectedPort A.Region
69 | UnexpectedPort A.Region
71 | NoPorts A.Region
70 | NoPorts A.Region
72− | NoPortsInPackage (A.Located Name.Name)
73− | NoPortModulesInPackage A.Region
74− | NoEffectsOutsideKernel A.Region
75 | ParseError Module
71 | ParseError Module
76
72
77
73
@@ -520,7 +516,7 @@ toReport source err =
520 ,
516 ,
521 D.stack
517 D.stack
522 [ D.reflow $
518 [ D.reflow $
523− "I need it to match the file path, so I was expecting to see `"
519+ "I need it to match the file path, so I was expecting it to see `"
524 ++ ModuleName.toChars expectedName
520 ++ ModuleName.toChars expectedName
525 ++ "` here. Make the following change, and you should be all set!"
521 ++ "` here. Make the following change, and you should be all set!"
526 , D.indent 4 $
522 , D.indent 4 $
@@ -564,84 +560,10 @@ toReport source err =
564 ]
560 ]
565 )
561 )
566
562
567− NoPortsInPackage (A.At region _) ->
568− Report.Report "PACKAGES CANNOT HAVE PORTS" region [] $
569− Code.toSnippet source region Nothing
570− (
571− D.reflow $
572− "Packages cannot declare any ports, so I am getting stuck here:"
573− ,
574− D.stack
575− [ D.reflow $
576− "Remove this port declaration."
577− , noteForPortsInPackage
578− ]
579− )
580−
581− NoPortModulesInPackage region ->
582− Report.Report "PACKAGES CANNOT HAVE PORTS" region [] $
583− Code.toSnippet source region Nothing
584− (
585− D.reflow $
586− "Packages cannot declare any ports, so I am getting stuck here:"
587− ,
588− D.stack
589− [ D.fillSep $
590− ["Remove","the",D.cyan "port","keyword","and","I"
591− ,"should","be","able","to","continue."
592− ]
593− , noteForPortsInPackage
594− ]
595− )
596−
597− NoEffectsOutsideKernel region ->
598− Report.Report "INVALID EFFECT MODULE" region [] $
599− Code.toSnippet source region Nothing
600− (
601− D.reflow $
602− "It is not possible to declare an `effect module` outside the @elm organization,\
603− \ so I am getting stuck here:"
604− ,
605− D.stack
606− [ D.reflow $
607− "Switch to a normal module declaration."
608− , D.toSimpleNote $
609− "Effect modules are designed to allow certain core functionality to be\
610− \ defined separately from the compiler. So the @elm organization has access to\
611− \ this so that certain changes, extensions, and fixes can be introduced without\
612− \ needing to release new Elm binaries. For example, we want to make it possible\
613− \ to test effects, but this may require changes to the design of effect modules.\
614− \ By only having them defined in the @elm organization, that kind of design work\
615− \ can proceed much more smoothly."
616− ]
617− )
618−
619 ParseError modul ->
563 ParseError modul ->
620 toParseErrorReport source modul
564 toParseErrorReport source modul
621
565
622
566
623−noteForPortsInPackage :: D.Doc
624−noteForPortsInPackage =
625− D.stack
626− [ D.toSimpleNote $
627− "One of the major goals of the package ecosystem is to be completely written\
628− \ in Elm. This means when you install an Elm package, you can be sure you are safe\
629− \ from security issues on install and that you are not going to get any runtime\
630− \ exceptions coming from your new dependency. This design also sets the ecosystem\
631− \ up to target other platforms more easily (like mobile phones, WebAssembly, etc.)\
632− \ since no community code explicitly depends on JavaScript even existing."
633− , D.reflow $
634− "Given that overall goal, allowing ports in packages would lead to some pretty\
635− \ surprising behavior. If ports were allowed in packages, you could install a\
636− \ package but not realize that it brings in an indirect dependency that defines a\
637− \ port. Now you have a program that does not work and the fix is to realize that\
638− \ some JavaScript needs to be added for a dependency you did not even know about.\
639− \ That would be extremely frustrating! \"So why not allow the package author to\
640− \ include the necessary JS code as well?\" Now we are back in conflict with our\
641− \ overall goal to keep all community packages free from runtime exceptions."
642− ]
643−
644−
645toParseErrorReport :: Code.Source -> Module -> Report.Report
567toParseErrorReport :: Code.Source -> Module -> Report.Report
646toParseErrorReport source modul =
568toParseErrorReport source modul =
647 case modul of
569 case modul of
@@ -649,9 +571,64 @@ toParseErrorReport source modul =
649 toSpaceReport source space row col
571 toSpaceReport source space row col
650
572
651 ModuleBadEnd row col ->
573 ModuleBadEnd row col ->
652− if col == 1
574+ case Code.whatIsNext source row col of
653− then toDeclStartReport source row col
575+ Code.Keyword keyword ->
654− else toWeirdEndReport source row col
576+ let
577+ region = toKeywordRegion row col keyword
578+ in
579+ Report.Report "RESERVED WORD" region [] $
580+ Code.toSnippet source region Nothing
581+ (
582+ D.reflow $
583+ "I got stuck on this reserved word:"
584+ ,
585+ D.reflow $
586+ "The name `" ++ keyword ++ "` is reserved, so try using a different name?"
587+ )
588+
589+ Code.Operator op ->
590+ let
591+ region = toKeywordRegion row col op
592+ in
593+ Report.Report "UNEXPECTED SYMBOL" region [] $
594+ Code.toSnippet source region Nothing
595+ (
596+ D.reflow $
597+ "I ran into an unexpected symbol:"
598+ ,
599+ D.reflow $
600+ "I was not expecting to see a " ++ op ++ " here. Try deleting it? Maybe\
601+ \ I can give a better hint from there?"
602+ )
603+
604+ Code.Close term bracket ->
605+ let
606+ region = toRegion row col
607+ in
608+ Report.Report ("UNEXPECTED " ++ map Char.toUpper term) region [] $
609+ Code.toSnippet source region Nothing
610+ (
611+ D.reflow $
612+ "I ran into an unexpected " ++ term ++ ":"
613+ ,
614+ D.reflow $
615+ "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?"
616+ )
617+
618+ Code.Other ->
619+ let
620+ region = toRegion row col
621+ in
622+ Report.Report "SYNTAX PROBLEM" region [] $
623+ Code.toSnippet source region Nothing
624+ (
625+ D.reflow $
626+ "I got stuck here:"
627+ ,
628+ D.reflow $
629+ "Whatever I am running into is confusing me a lot! Normally I can give fairly\
630+ \ specific hints, but something is really tripping me up this time."
631+ )
655
632
656 ModuleProblem row col ->
633 ModuleProblem row col ->
657 let
634 let
@@ -797,15 +774,15 @@ toParseErrorReport source modul =
797 [ D.reflow $
774 [ D.reflow $
798 "I am not sure what is going on, but I recommend starting an Elm\
775 "I am not sure what is going on, but I recommend starting an Elm\
799 \ file with the following lines:"
776 \ file with the following lines:"
800− , D.indent 4 $ D.vcat $
777+ , D.vcat
801 [ D.fillSep [D.cyan "import","Html"]
778 [ D.fillSep [D.cyan "import","Html"]
802 , ""
779 , ""
803− , "main ="
780+ , D.fillSep [D.green "main","="]
804− , " Html.text " <> D.dullyellow "\"Hello!\""
781+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
805 ]
782 ]
806 , D.reflow $
783 , D.reflow $
807− "You should be able to copy those lines directly into your file. Check out the\
784+ "You should be able to copy those lines directly into your file. Check out\
808− \ examples at <https://elm-lang.org/examples> for more help getting started!"
785+ \ some of the examples on https://elm-lang.org for more help getting started!"
809 , D.toSimpleNote $
786 , D.toSimpleNote $
810 "This can also happen when something is indented too much!"
787 "This can also happen when something is indented too much!"
811 ]
788 ]
@@ -830,12 +807,11 @@ toParseErrorReport source modul =
830 , D.indent 4 $ D.vcat $
807 , D.indent 4 $ D.vcat $
831 [ D.fillSep [D.cyan "import","Dict"]
808 [ D.fillSep [D.cyan "import","Dict"]
832 , D.fillSep [D.cyan "import","Maybe"]
809 , D.fillSep [D.cyan "import","Maybe"]
833− , D.fillSep [D.cyan "import","Html.Attributes",D.cyan "as","A"]
810+ , D.fillSep [D.cyan "import","Html.Attributes"]
834− , D.fillSep [D.cyan "import","Json.Decode",D.cyan "exposing","(..)"]
811+ , D.fillSep [D.cyan "import","Json.Decode"]
835 ]
812 ]
836 , D.reflow $
813 , D.reflow $
837 "Notice that the module names all start with capital letters. That is required!"
814 "Notice that the module names all start with capital letters. That is required!"
838− , D.reflowLink "Read" "imports" "to learn more."
839 ]
815 ]
840 )
816 )
841
817
@@ -846,7 +822,7 @@ toParseErrorReport source modul =
846 let
822 let
847 region = toRegion row col
823 region = toRegion row col
848 in
824 in
849− Report.Report "EXPECTING IMPORT ALIAS" region [] $
825+ Report.Report "EXECTING IMPORT ALIAS" region [] $
850 Code.toSnippet source region Nothing
826 Code.toSnippet source region Nothing
851 (
827 (
852 D.reflow $
828 D.reflow $
@@ -862,7 +838,6 @@ toParseErrorReport source modul =
862 ]
838 ]
863 , D.reflow $
839 , D.reflow $
864 "Notice that the alias always starts with a capital letter. That is required!"
840 "Notice that the alias always starts with a capital letter. That is required!"
865− , D.reflowLink "Read" "imports" "to learn more."
866 ]
841 ]
867 )
842 )
868
843
@@ -925,192 +900,6 @@ toParseErrorReport source modul =
925
900
926
901
927
902
928−-- WEIRD END
929−
930−
931−toWeirdEndReport :: Code.Source -> Row -> Col -> Report.Report
932−toWeirdEndReport source row col =
933− case Code.whatIsNext source row col of
934− Code.Keyword keyword ->
935− let
936− region = toKeywordRegion row col keyword
937− in
938− Report.Report "RESERVED WORD" region [] $
939− Code.toSnippet source region Nothing
940− (
941− D.reflow $
942− "I got stuck on this reserved word:"
943− ,
944− D.reflow $
945− "The name `" ++ keyword ++ "` is reserved, so try using a different name?"
946− )
947−
948− Code.Operator op ->
949− let
950− region = toKeywordRegion row col op
951− in
952− Report.Report "UNEXPECTED SYMBOL" region [] $
953− Code.toSnippet source region Nothing
954− (
955− D.reflow $
956− "I ran into an unexpected symbol:"
957− ,
958− D.reflow $
959− "I was not expecting to see a " ++ op ++ " here. Try deleting it? Maybe\
960− \ I can give a better hint from there?"
961− )
962−
963− Code.Close term bracket ->
964− let
965− region = toRegion row col
966− in
967− Report.Report ("UNEXPECTED " ++ map Char.toUpper term) region [] $
968− Code.toSnippet source region Nothing
969− (
970− D.reflow $
971− "I ran into an unexpected " ++ term ++ ":"
972− ,
973− D.reflow $
974− "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?"
975− )
976−
977− Code.Lower c cs ->
978− let
979− region = toKeywordRegion row col (c:cs)
980− in
981− Report.Report "UNEXPECTED NAME" region [] $
982− Code.toSnippet source region Nothing
983− (
984− D.reflow $
985− "I got stuck on this name:"
986− ,
987− D.reflow $
988− "It is confusing me a lot! Normally I can give fairly specific hints, but\
989− \ something is really tripping me up this time."
990− )
991−
992− Code.Upper c cs ->
993− let
994− region = toKeywordRegion row col (c:cs)
995− in
996− Report.Report "UNEXPECTED NAME" region [] $
997− Code.toSnippet source region Nothing
998− (
999− D.reflow $
1000− "I got stuck on this name:"
1001− ,
1002− D.reflow $
1003− "It is confusing me a lot! Normally I can give fairly specific hints, but\
1004− \ something is really tripping me up this time."
1005− )
1006−
1007− Code.Other maybeChar ->
1008− let
1009− region = toRegion row col
1010− in
1011− case maybeChar of
1012− Just ';' ->
1013− Report.Report "UNEXPECTED SEMICOLON" region [] $
1014− Code.toSnippet source region Nothing
1015− (
1016− D.reflow $
1017− "I got stuck on this semicolon:"
1018− ,
1019− D.stack
1020− [ D.reflow $ "Try removing it?"
1021− , D.toSimpleNote $
1022− "Some languages require semicolons at the end of each statement. These are\
1023− \ often called C-like languages, and they usually share a lot of language design\
1024− \ choices. (E.g. side-effects, for loops, etc.) Elm manages effects with commands\
1025− \ and subscriptions instead, so there is no special syntax for \"statements\" and\
1026− \ therefore no need to use semicolons to separate them. I think this will make\
1027− \ more sense as you work through <https://guide.elm-lang.org> though!"
1028− ]
1029− )
1030−
1031− Just ',' ->
1032− Report.Report "UNEXPECTED COMMA" region [] $
1033− Code.toSnippet source region Nothing
1034− (
1035− D.reflow $
1036− "I got stuck on this comma:"
1037− ,
1038− D.stack
1039− [ D.reflow $
1040− "I do not think I am parsing a list or tuple right now. Try deleting the comma?"
1041− , D.toSimpleNote $
1042− "If this is supposed to be part of a list, the problem may be a bit earlier.\
1043− \ Perhaps the opening [ is missing? Or perhaps some value in the list has an extra\
1044− \ closing ] that is making me think the list ended earlier? The same kinds of\
1045− \ things could be going wrong if this is supposed to be a tuple."
1046− ]
1047− )
1048−
1049− Just '`' ->
1050− Report.Report "UNEXPECTED CHARACTER" region [] $
1051− Code.toSnippet source region Nothing
1052− (
1053− D.reflow $
1054− "I got stuck on this character:"
1055− ,
1056− D.stack
1057− [ D.reflow $
1058− "It is not used for anything in Elm syntax. It is used for multi-line strings in\
1059− \ some languages though, so if you want a string that spans multiple lines, you\
1060− \ can use Elm's multi-line string syntax like this:"
1061− , D.dullyellow $ D.indent 4 $ D.vcat $
1062− [ "\"\"\""
1063− , "# Multi-line Strings"
1064− , ""
1065− , "- start with triple double quotes"
1066− , "- write whatever you want"
1067− , "- no need to escape newlines or double quotes"
1068− , "- end with triple double quotes"
1069− , "\"\"\""
1070− ]
1071− , D.reflow $
1072− "Otherwise I do not know what is going on! Try removing the character?"
1073− ]
1074− )
1075−
1076− Just '$' ->
1077− Report.Report "UNEXPECTED SYMBOL" region [] $
1078− Code.toSnippet source region Nothing
1079− (
1080− D.reflow $
1081− "I got stuck on this dollar sign:"
1082− ,
1083− D.reflow $
1084− "It is not used for anything in Elm syntax. Are you coming from a language where\
1085− \ dollar signs can be used in variable names? If so, try a name that (1) starts\
1086− \ with a letter and (2) only contains letters, numbers, and underscores."
1087− )
1088−
1089− Just c | elem c ['#','@','!','%','~'] ->
1090− Report.Report "UNEXPECTED SYMBOL" region [] $
1091− Code.toSnippet source region Nothing
1092− (
1093− D.reflow $
1094− "I got stuck on this symbol:"
1095− ,
1096− D.reflow $
1097− "It is not used for anything in Elm syntax. Try removing it?"
1098− )
1099−
1100− _ ->
1101− Report.Report "SYNTAX PROBLEM" region [] $
1102− Code.toSnippet source region Nothing
1103− (
1104− D.reflow $
1105− "I got stuck here:"
1106− ,
1107− D.reflow $
1108− "Whatever I am running into is confusing me a lot! Normally I can give fairly\
1109− \ specific hints, but something is really tripping me up this time."
1110− )
1111−
1112−
1113−
1114-- IMPORTS
903-- IMPORTS
1115
904
1116
905
@@ -1136,7 +925,6 @@ toImportReport source row col =
1136 ]
925 ]
1137 , D.reflow $
926 , D.reflow $
1138 "You are probably trying to import a different module, but try to make it look like one of these examples!"
927 "You are probably trying to import a different module, but try to make it look like one of these examples!"
1139− , D.reflowLink "Read" "imports" "to learn more."
1140 ]
928 ]
1141 )
929 )
1142
930
@@ -1443,7 +1231,106 @@ toDeclarationsReport :: Code.Source -> Decl -> Report.Report
1443toDeclarationsReport source decl =
1231toDeclarationsReport source decl =
1444 case decl of
1232 case decl of
1445 DeclStart row col ->
1233 DeclStart row col ->
1446− toDeclStartReport source row col
1234+ case Code.whatIsNext source row col of
1235+ Code.Close term bracket ->
1236+ let
1237+ region = toRegion row col
1238+ in
1239+ Report.Report ("STRAY " ++ map Char.toUpper term) region [] $
1240+ Code.toSnippet source region Nothing
1241+ (
1242+ D.reflow $
1243+ "I was not expecting to see a " ++ term ++ " here:"
1244+ , D.reflow $
1245+ "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?"
1246+ )
1247+
1248+ Code.Keyword keyword ->
1249+ let
1250+ region = toKeywordRegion row col keyword
1251+ in
1252+ Report.Report "RESERVED WORD" region [] $
1253+ Code.toSnippet source region Nothing
1254+ (
1255+ D.reflow $
1256+ "I was not expecting to run into the `" ++ keyword ++ "` keyword here:"
1257+ ,
1258+ case keyword of
1259+ "import" ->
1260+ D.reflow $
1261+ "It is reserved for declaring imports at the top of your module. If you want\
1262+ \ another import, try moving it up top with the other imports. If you want to\
1263+ \ define a value or function, try changing the name to something else!"
1264+
1265+ "case" ->
1266+ D.stack
1267+ [ D.reflow $
1268+ "It is reserved for writing `case` expressions. Try using a different name?"
1269+ , D.toSimpleNote $
1270+ "If you are trying to write a `case` expression, it needs to be part of a\
1271+ \ definition. So you could write something like this instead:"
1272+ , D.vcat $
1273+ [ D.indent 0 $ D.fillSep [D.green "getWidth","maybeWidth","="]
1274+ , D.indent 2 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
1275+ , D.indent 4 $ D.fillSep [D.blue "Just","width","->"]
1276+ , D.indent 6 $ D.fillSep ["width","+",D.dullyellow "200"]
1277+ , ""
1278+ , D.indent 4 $ D.fillSep [D.blue "Nothing","->"]
1279+ , D.indent 6 $ D.fillSep [D.dullyellow "400"]
1280+ ]
1281+ , D.reflow $
1282+ "This defines a `getWidth` function that we can use elsewhere in our program."
1283+ ]
1284+
1285+ "if" ->
1286+ D.stack
1287+ [ D.reflow $
1288+ "It is reserved for writing `if` expressions. Try using a different name?"
1289+ , D.toSimpleNote $
1290+ "If you are trying to write an `if` expression, it needs to be part of a\
1291+ \ definition. So you could write something like this instead:"
1292+ , D.vcat $
1293+ [ D.indent 0 $ D.fillSep [D.green "reviewPowerLevel","powerLevel","="]
1294+ , D.indent 2 $ D.fillSep $
1295+ [D.cyan "if","powerLevel",">",D.dullyellow "9000"
1296+ ,D.cyan "then",D.dullyellow "\"OVER 9000!!!\""
1297+ ,D.cyan "else",D.dullyellow "\"not bad\""
1298+ ]
1299+ ]
1300+ , D.reflow $
1301+ "This defines a `reviewPowerLevel` function that we can use elsewhere in our program."
1302+ ]
1303+
1304+ _ ->
1305+ D.reflow $
1306+ "It is a reserved word. Try changing the name to something else?"
1307+ )
1308+
1309+ _ ->
1310+ let
1311+ region = toRegion row col
1312+ in
1313+ Report.Report "SYNTAX PROBLEM" region [] $
1314+ Code.toSnippet source region Nothing
1315+ (
1316+ D.reflow $
1317+ "I was expecting to see a new declaration here:"
1318+ ,
1319+ D.stack
1320+ [ D.reflow $
1321+ "I am not sure what is going wrong exactly, but here are a couple valid\
1322+ \ declarations for reference:"
1323+ , D.vcat
1324+ [ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
1325+ , D.fillSep [D.green "add","x","y","="]
1326+ , D.fillSep [" ","x","+","y"]
1327+ ]
1328+ , D.fillSep [D.cyan "type",D.green "User","=","Anonymous","|","LoggedIn String"]
1329+ , D.reflow $
1330+ "Note that all declarations start with lower-case letters in Elm. Capitalization\
1331+ \ makes a difference, so be consious of that if you are working from examples!"
1332+ ]
1333+ )
1447
1334
1448 DeclSpace space row col ->
1335 DeclSpace space row col ->
1449 toSpaceReport source space row col
1336 toSpaceReport source space row col
@@ -1473,165 +1360,6 @@ toDeclarationsReport source decl =
1473 )
1360 )
1474
1361
1475
1362
1476−toDeclStartReport :: Code.Source -> Row -> Col -> Report.Report
1477−toDeclStartReport source row col =
1478− case Code.whatIsNext source row col of
1479− Code.Close term bracket ->
1480− let
1481− region = toRegion row col
1482− in
1483− Report.Report ("STRAY " ++ map Char.toUpper term) region [] $
1484− Code.toSnippet source region Nothing
1485− (
1486− D.reflow $
1487− "I was not expecting to see a " ++ term ++ " here:"
1488− , D.reflow $
1489− "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?"
1490− )
1491−
1492− Code.Keyword keyword ->
1493− let
1494− region = toKeywordRegion row col keyword
1495− in
1496− Report.Report "RESERVED WORD" region [] $
1497− Code.toSnippet source region Nothing
1498− (
1499− D.reflow $
1500− "I was not expecting to run into the `" ++ keyword ++ "` keyword here:"
1501− ,
1502− case keyword of
1503− "import" ->
1504− D.reflow $
1505− "It is reserved for declaring imports at the top of your module. If you want\
1506− \ another import, try moving it up top with the other imports. If you want to\
1507− \ define a value or function, try changing the name to something else!"
1508−
1509− "case" ->
1510− D.stack
1511− [ D.reflow $
1512− "It is reserved for writing `case` expressions. Try using a different name?"
1513− , D.toSimpleNote $
1514− "If you are trying to write a `case` expression, it needs to be part of a\
1515− \ definition. So you could write something like this instead:"
1516− , D.indent 4 $ D.vcat $
1517− [ D.indent 0 $ D.fillSep ["getWidth","maybeWidth","="]
1518− , D.indent 2 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
1519− , D.indent 4 $ D.fillSep [D.blue "Just","width","->"]
1520− , D.indent 6 $ D.fillSep ["width","+",D.dullyellow "200"]
1521− , ""
1522− , D.indent 4 $ D.fillSep [D.blue "Nothing","->"]
1523− , D.indent 6 $ D.fillSep [D.dullyellow "400"]
1524− ]
1525− , D.reflow $
1526− "This defines a `getWidth` function that you can use elsewhere in your program."
1527− ]
1528−
1529− "if" ->
1530− D.stack
1531− [ D.reflow $
1532− "It is reserved for writing `if` expressions. Try using a different name?"
1533− , D.toSimpleNote $
1534− "If you are trying to write an `if` expression, it needs to be part of a\
1535− \ definition. So you could write something like this instead:"
1536− , D.indent 4 $ D.vcat $
1537− [ "greet name ="
1538− , D.fillSep $
1539− [" "
1540− ,D.cyan "if","name","==",D.dullyellow "\"Abraham Lincoln\""
1541− ,D.cyan "then",D.dullyellow "\"Greetings Mr. President.\""
1542− ,D.cyan "else",D.dullyellow "\"Hey!\""
1543− ]
1544− ]
1545− , D.reflow $
1546− "This defines a `reviewPowerLevel` function that you can use elsewhere in your program."
1547− ]
1548−
1549− _ ->
1550− D.reflow $
1551− "It is a reserved word. Try changing the name to something else?"
1552− )
1553−
1554− Code.Upper c cs ->
1555− let
1556− region = toRegion row col
1557− in
1558− Report.Report "UNEXPECTED CAPITAL LETTER" region [] $
1559− Code.toSnippet source region Nothing
1560− (
1561− D.reflow $
1562− "Declarations always start with a lower-case letter, so I am getting stuck here:"
1563− ,
1564− D.stack
1565− [ D.fillSep $
1566− ["Try","a","name","like"
1567− ,D.green (D.fromChars (Char.toLower c : cs))
1568− ,"instead?"
1569− ]
1570− , D.toSimpleNote $
1571− "Here are a couple valid declarations for reference:"
1572− , D.indent 4 $ D.vcat $
1573− [ "greet : String -> String"
1574− , "greet name ="
1575− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
1576− , ""
1577− , D.cyan "type" <> " User = Anonymous | LoggedIn String"
1578− ]
1579− , D.reflow $
1580− "Notice that they always start with a lower-case letter. Capitalization matters!"
1581− ]
1582− )
1583−
1584− Code.Other (Just char) | elem char ['(', '{', '[', '+', '-', '*', '/', '^', '&', '|', '"', '\'', '!', '@', '#', '$', '%'] ->
1585− let
1586− region = toRegion row col
1587− in
1588− Report.Report "UNEXPECTED SYMBOL" region [] $
1589− Code.toSnippet source region Nothing
1590− (
1591− D.reflow $
1592− "I am getting stuck because this line starts with the " ++ [char] ++ " symbol:"
1593− ,
1594− D.stack
1595− [ D.reflow $
1596− "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:"
1597− , D.indent 4 $ D.vcat $
1598− [ "greet : String -> String"
1599− , "greet name ="
1600− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
1601− , ""
1602− , D.cyan "type" <> " User = Anonymous | LoggedIn String"
1603− ]
1604− , D.reflow $
1605− "If this is not supposed to be a declaration, try adding some spaces before it?"
1606− ]
1607− )
1608−
1609− _ ->
1610− let
1611− region = toRegion row col
1612− in
1613− Report.Report "WEIRD DECLARATION" region [] $
1614− Code.toSnippet source region Nothing
1615− (
1616− D.reflow $
1617− "I am trying to parse a declaration, but I am getting stuck here:"
1618− ,
1619− D.stack
1620− [ D.reflow $
1621− "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:"
1622− , D.indent 4 $ D.vcat $
1623− [ "greet : String -> String"
1624− , "greet name ="
1625− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
1626− , ""
1627− , D.cyan "type" <> " User = Anonymous | LoggedIn String"
1628− ]
1629− , D.reflow $
1630− "Try to make your declaration look like one of those? Or if this is not\
1631− \ supposed to be a declaration, try adding some spaces before it?"
1632− ]
1633− )
1634−
1635
1363
1636-- PORT
1364-- PORT
1637
1365
@@ -1758,7 +1486,7 @@ toPortReport source port_ startRow startCol =
1758 [ D.reflow $
1486 [ D.reflow $
1759 "I was expecting to see a type next. Here are examples of outgoing and\
1487 "I was expecting to see a type next. Here are examples of outgoing and\
1760 \ incoming ports for reference:"
1488 \ incoming ports for reference:"
1761− , D.indent 4 $ D.vcat $
1489+ , D.vcat
1762 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1490 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1763 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1491 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1764 ]
1492 ]
@@ -1777,7 +1505,7 @@ portNote =
1777 D.stack
1505 D.stack
1778 [ D.toSimpleNote $
1506 [ D.toSimpleNote $
1779 "Here are some example `port` declarations for reference:"
1507 "Here are some example `port` declarations for reference:"
1780− , D.indent 4 $ D.vcat $
1508+ , D.vcat
1781 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1509 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1782 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1510 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1783 ]
1511 ]
@@ -1907,7 +1635,7 @@ toTypeAliasReport source typeAlias startRow startCol =
1907 ,
1635 ,
1908 D.stack
1636 D.stack
1909 [ D.reflow $
1637 [ D.reflow $
1910− "I was expecting to see a type variable or an equals sign next."
1638+ "I was expecting to see a type variable or an an equals sign next."
1911 , typeAliasNote
1639 , typeAliasNote
1912 ]
1640 ]
1913 )
1641 )
@@ -1928,7 +1656,7 @@ toTypeAliasReport source typeAlias startRow startCol =
1928 ,
1656 ,
1929 D.stack
1657 D.stack
1930 [ D.reflow $
1658 [ D.reflow $
1931− "I was expecting to see a type variable or an equals sign next."
1659+ "I was expecting to see a type variable or an an equals sign next."
1932 , typeAliasNote
1660 , typeAliasNote
1933 ]
1661 ]
1934 )
1662 )
@@ -1960,8 +1688,8 @@ typeAliasNote =
1960 [ D.toSimpleNote $
1688 [ D.toSimpleNote $
1961 "Here is an example of a valid `type alias` for reference:"
1689 "Here is an example of a valid `type alias` for reference:"
1962 , D.vcat $
1690 , D.vcat $
1963− [ D.indent 4 $ D.fillSep [D.cyan "type",D.cyan "alias","Person","="]
1691+ [ D.indent 0 $ D.fillSep [D.cyan "type",D.cyan "alias",D.green "Person","="]
1964− , D.indent 6 $ D.vcat $
1692+ , D.indent 2 $ D.vcat $
1965 ["{ name : String"
1693 ["{ name : String"
1966 ,", age : Int"
1694 ,", age : Int"
1967 ,", height : Float"
1695 ,", height : Float"
@@ -2035,7 +1763,7 @@ toCustomTypeReport source customType startRow startCol =
2035 ,
1763 ,
2036 D.stack
1764 D.stack
2037 [ D.reflow $
1765 [ D.reflow $
2038− "I was expecting to see a type variable or an equals sign next."
1766+ "I was expecting to see a type variable or an an equals sign next."
2039 , customTypeNote
1767 , customTypeNote
2040 ]
1768 ]
2041 )
1769 )
@@ -2095,7 +1823,7 @@ toCustomTypeReport source customType startRow startCol =
2095 ,
1823 ,
2096 D.stack
1824 D.stack
2097 [ D.reflow $
1825 [ D.reflow $
2098− "I was expecting to see a type variable or an equals sign next."
1826+ "I was expecting to see a type variable or an an equals sign next."
2099 , customTypeNote
1827 , customTypeNote
2100 ]
1828 ]
2101 )
1829 )
@@ -2161,10 +1889,10 @@ customTypeNote =
2161 [ D.toSimpleNote $
1889 [ D.toSimpleNote $
2162 "Here is an example of a valid `type` declaration for reference:"
1890 "Here is an example of a valid `type` declaration for reference:"
2163 , D.vcat $
1891 , D.vcat $
2164− [ D.indent 4 $ D.fillSep [D.cyan "type","Status"]
1892+ [ D.indent 0 $ D.fillSep [D.cyan "type",D.green "Status"]
2165− , D.indent 6 $ D.fillSep ["=","Failure"]
1893+ , D.indent 2 $ D.fillSep ["=","Failure"]
2166− , D.indent 6 $ D.fillSep ["|","Waiting"]
1894+ , D.indent 2 $ D.fillSep ["|","Waiting"]
2167− , D.indent 6 $ D.fillSep ["|","Success","String"]
1895+ , D.indent 2 $ D.fillSep ["|","Success","String"]
2168 ]
1896 ]
2169 , D.reflow $
1897 , D.reflow $
2170 "This defines a new `Status` type with three variants. This could be useful if\
1898 "This defines a new `Status` type with three variants. This could be useful if\
@@ -2193,57 +1921,13 @@ toDeclDefReport source name declDef startRow startCol =
2193 region = toKeywordRegion row col keyword
1921 region = toKeywordRegion row col keyword
2194 in
1922 in
2195 Report.Report "RESERVED WORD" region [] $
1923 Report.Report "RESERVED WORD" region [] $
2196− Code.toSnippet source surroundings (Just region)
2197− (
2198− D.fillSep
2199− ["The","name"
2200− ,"`" <> D.cyan (D.fromChars keyword) <> "`"
2201− ,"is","reserved","in","Elm,","so","it","cannot"
2202− ,"be","used","as","an","argument","here:"
2203− ]
2204− ,
2205− D.stack
2206− [ D.reflow $
2207− "Try renaming it to something else."
2208− , case keyword of
2209− "as" ->
2210− D.toFancyNote
2211− ["This","keyword","is","reserved","for","pattern","matches","like"
2212− ,"((x,y)",D.cyan "as","point)","where","you","want","to","name","a","tuple","and"
2213− ,"the","values","it","contains."
2214− ]
2215−
2216− _ ->
2217− D.toSimpleNote $
2218− "The `" ++ keyword ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations."
2219− ]
2220− )
2221−
2222− Code.Operator "->" ->
2223− let
2224− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
2225− region = toWiderRegion row col 2
2226− in
2227− Report.Report "MISSING COLON?" region [] $
2228 Code.toSnippet source surroundings (Just region)
1924 Code.toSnippet source surroundings (Just region)
2229 (
1925 (
2230 D.reflow $
1926 D.reflow $
2231− "I was not expecting to see an arrow here:"
1927+ "It looks like you are trying to use `" ++ keyword ++ "` as an argument:"
2232 ,
1928 ,
2233− D.stack
1929+ D.reflow $
2234− [ D.fillSep
1930+ "This is a reserved word! Try using some other name?"
2235− ["This","usually","means","a",D.green ":","is","missing","a","bit","earlier","in"
2236− ,"a","type","annotation.","It","could","be","something","else","though,","so"
2237− ,"here","is","a","valid","definition","for","reference:"
2238− ]
2239− , D.indent 4 $ D.vcat $
2240− [ "greet : String -> String"
2241− , "greet name ="
2242− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
2243− ]
2244− , D.reflow $
2245− "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
2246− ]
2247 )
1931 )
2248
1932
2249 Code.Operator op ->
1933 Code.Operator op ->
@@ -2261,10 +1945,10 @@ toDeclDefReport source name declDef startRow startCol =
2261 [ D.reflow $
1945 [ D.reflow $
2262 "I am not sure what is going wrong exactly, so here is a valid\
1946 "I am not sure what is going wrong exactly, so here is a valid\
2263 \ definition (with an optional type annotation) for reference:"
1947 \ definition (with an optional type annotation) for reference:"
2264− , D.indent 4 $ D.vcat $
1948+ , D.vcat
2265− [ "greet : String -> String"
1949+ [ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
2266− , "greet name ="
1950+ , D.fillSep [D.green "add","x","y","="]
2267− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
1951+ , D.fillSep [" ","x","+","y"]
2268 ]
1952 ]
2269 , D.reflow $
1953 , D.reflow $
2270 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
1954 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
@@ -2286,10 +1970,10 @@ toDeclDefReport source name declDef startRow startCol =
2286 [ D.reflow $
1970 [ D.reflow $
2287 "I am not sure what is going wrong exactly, so here is a valid\
1971 "I am not sure what is going wrong exactly, so here is a valid\
2288 \ definition (with an optional type annotation) for reference:"
1972 \ definition (with an optional type annotation) for reference:"
2289− , D.indent 4 $ D.vcat $
1973+ , D.vcat
2290− [ "greet : String -> String"
1974+ [ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
2291− , "greet name ="
1975+ , D.fillSep [D.green "add","x","y","="]
2292− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
1976+ , D.fillSep [" ","x","+","y"]
2293 ]
1977 ]
2294 , D.reflow $
1978 , D.reflow $
2295 "Try to use that format!"
1979 "Try to use that format!"
@@ -2404,10 +2088,10 @@ declDefNote =
2404 D.stack
2088 D.stack
2405 [ D.reflow $
2089 [ D.reflow $
2406 "Here is a valid definition (with a type annotation) for reference:"
2090 "Here is a valid definition (with a type annotation) for reference:"
2407− , D.indent 4 $ D.vcat $
2091+ , D.vcat
2408− [ "greet : String -> String"
2092+ [ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
2409− , "greet name ="
2093+ , D.fillSep [D.green "add","x","y","="]
2410− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
2094+ , D.fillSep [" ","x","+","y"]
2411 ]
2095 ]
2412 , D.reflow $
2096 , D.reflow $
2413 "The top line (called a \"type annotation\") is optional. You can leave it off\
2097 "The top line (called a \"type annotation\") is optional. You can leave it off\
@@ -2519,40 +2203,25 @@ toExprReport source context expr startRow startCol =
2519 )
2203 )
2520
2204
2521 OperatorRight op row col ->
2205 OperatorRight op row col ->
2522− let
2523− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
2524− region = toRegion row col
2206+ let region = toRegion row col in
2525− isMath = elem op ["-","+","*","/","^"]
2526− in
2527 Report.Report "MISSING EXPRESSION" region [] $
2207 Report.Report "MISSING EXPRESSION" region [] $
2528− Code.toSnippet source surroundings (Just region)
2208+ Code.toSnippet source region Nothing
2529 (
2209 (
2530 D.reflow $
2210 D.reflow $
2531− "I just saw a " ++ Name.toChars op ++ " "
2211+ "I was expecting to see an expression after this " ++ Name.toChars op ++ " operator:"
2532− ++ (if isMath then "sign" else "operator")
2533− ++ ", so I am getting stuck here:"
2534 ,
2212 ,
2535− if isMath then
2213+ D.stack
2536− D.fillSep
2214+ [ D.fillSep $
2537− ["I","was","expecting","to","see","an","expression","next."
2215+ ["You","can","just","put","anything","for","now,","like"
2538− ,"Something","like",D.dullyellow "42","or",D.dullyellow "1000"
2216+ ,D.dullyellow "42","or",D.dullyellow"\"hello\"" <> "."
2539− ,"that","makes","sense","with","a",D.fromName op,"sign."
2217+ ,"Once","there","is","something","there,","I","can","probably"
2540− ]
2218+ ,"give","a","more","specific","hint!"
2541− else if op == "&&" || op == "||" then
2542− D.fillSep
2543− ["I","was","expecting","to","see","an","expression","next."
2544− ,"Something","like",D.dullyellow "True","or",D.dullyellow "False"
2545− ,"that","makes","sense","with","boolean","logic."
2546− ]
2219+ ]
2547− else if op == "|>" then
2220+ , D.toSimpleNote $
2548− D.reflow $
2221+ "This can also happen if run into reserved words like `let` or `as` unexpectedly.\
2549− "I was expecting to see a function next."
2222+ \ Or if I run into operators in unexpected spots. Point is, there are a\
2550− else if op == "<|" then
2223+ \ couple ways I can get confused and give sort of weird advice!"
2551− D.reflow $
2224+ ]
2552− "I was expecting to see an argument next."
2553− else
2554− D.reflow $
2555− "I was expecting to see an expression next."
2556 )
2225 )
2557
2226
2558 OperatorReserved operator row col ->
2227 OperatorReserved operator row col ->
@@ -2573,6 +2242,7 @@ toExprReport source context expr startRow startCol =
2573 InNode NElse r c _ -> (r, c, "an `if` expression")
2242 InNode NElse r c _ -> (r, c, "an `if` expression")
2574 InNode NCase r c _ -> (r, c, "a `case` expression")
2243 InNode NCase r c _ -> (r, c, "a `case` expression")
2575 InNode NBranch r c _ -> (r, c, "a `case` expression")
2244 InNode NBranch r c _ -> (r, c, "a `case` expression")
2245+ -- TODO check if this is actually the best way to get error messages here
2576
2246
2577 surroundings = A.Region (A.Position contextRow contextCol) (A.Position row col)
2247 surroundings = A.Region (A.Position contextRow contextCol) (A.Position row col)
2578 region = toRegion row col
2248 region = toRegion row col
@@ -2591,7 +2261,7 @@ toExprReport source context expr startRow startCol =
2591 ,"give","a","more","specific","hint!"
2261 ,"give","a","more","specific","hint!"
2592 ]
2262 ]
2593 , D.toSimpleNote $
2263 , D.toSimpleNote $
2594− "This can also happen if I run into reserved words like `let` or `as` unexpectedly.\
2264+ "This can also happen if run into reserved words like `let` or `as` unexpectedly.\
2595 \ Or if I run into operators in unexpected spots. Point is, there are a\
2265 \ Or if I run into operators in unexpected spots. Point is, there are a\
2596 \ couple ways I can get confused and give sort of weird advice!"
2266 \ couple ways I can get confused and give sort of weird advice!"
2597 ]
2267 ]
@@ -2737,19 +2407,7 @@ toStringReport source string row col =
2737 ,"quotes","on","each","end.","Is","the","closing","double"
2407 ,"quotes","on","each","end.","Is","the","closing","double"
2738 ,"quote","missing","in","your","code?"
2408 ,"quote","missing","in","your","code?"
2739 ]
2409 ]
2740− , D.toSimpleNote $
2741− "For a string that spans multiple lines, you can use the multi-line string\
2410+ , D.link "Note" "Read" "TODO" "if you want a string that spans multiple lines."
2742− \ syntax like this:"
2743− , D.dullyellow $ D.indent 4 $ D.vcat $
2744− [ "\"\"\""
2745− , "# Multi-line Strings"
2746− , ""
2747− , "- start with triple double quotes"
2748− , "- write whatever you want"
2749− , "- no need to escape newlines or double quotes"
2750− , "- end with triple double quotes"
2751− , "\"\"\""
2752− ]
2753 ]
2411 ]
2754 )
2412 )
2755
2413
@@ -2765,18 +2423,7 @@ toStringReport source string row col =
2765 ,
2423 ,
2766 D.stack
2424 D.stack
2767 [ D.reflow "Add a \"\"\" somewhere after this to end the string."
2425 [ D.reflow "Add a \"\"\" somewhere after this to end the string."
2768− , D.toSimpleNote $
2426+ , D.link "Hint" "Read" "TODO" "for more information on strings and multi-line strings."
2769− "Here is a valid multi-line string for reference:"
2770− , D.dullyellow $ D.indent 4 $ D.vcat $
2771− [ "\"\"\""
2772− , "# Multi-line Strings"
2773− , ""
2774− , "- start with triple double quotes"
2775− , "- write whatever you want"
2776− , "- no need to escape newlines or double quotes"
2777− , "- end with triple double quotes"
2778− , "\"\"\""
2779− ]
2780 ]
2427 ]
2781 )
2428 )
2782
2429
@@ -3009,41 +2656,33 @@ toOperatorReport source context operator row col =
3009 in
2656 in
3010 Report.Report "UNEXPECTED ARROW" region [] $
2657 Report.Report "UNEXPECTED ARROW" region [] $
3011 Code.toSnippet source region Nothing $
2658 Code.toSnippet source region Nothing $
3012− if isWithin NCase context then
3013− (
3014− D.reflow $
3015− "I am parsing a `case` expression right now, but this arrow is confusing me:"
3016− ,
3017− D.stack
3018− [ D.reflow "Maybe the `of` keyword is missing on a previous line?"
3019− , noteForCaseError
3020− ]
3021− )
3022−
3023− else if isWithin NBranch context then
2659+ if isWithin NBranch context then
3024 (
2660 (
3025 D.reflow $
2661 D.reflow $
3026− "I am parsing a `case` expression right now, but this arrow is confusing me:"
2662+ "I was not expecting to see an arrow here:"
3027 ,
2663 ,
3028 D.stack
2664 D.stack
2665+ [
3029− [ D.reflow $
2666+ D.reflow $
3030− "It makes sense to see arrows around here, so I suspect it is something earlier. Maybe this pattern is indented a bit farther than the previous patterns?"
2667+ "I think I am parsing a `case` expression right now, so it makes sense to\
3031− , noteForCaseIndentError
2668+ \ see arrows around here. This one is confusing me though!"
2669+ ,
2670+ D.toSimpleHint $
2671+ "I may be getting confused by the indentation. Every pattern in a `case` must be\
2672+ \ exactly aligned (with exactly the same amount of indentation) so maybe this arrow\
2673+ \ appears after the next `case` pattern (correctly!) but the pattern itself is\
2674+ \ indented too far?"
3032 ]
2675 ]
3033 )
2676 )
3034
2677
3035 else
2678 else
3036 (
2679 (
3037 D.reflow $
2680 D.reflow $
3038− "I was partway through parsing an expression when I got stuck on this arrow:"
2681+ "I was not expecting an arrow here:"
3039 ,
2682 ,
3040− D.stack
2683+ D.reflow $
3041− [ "Arrows should only appear in `case` expressions and anonymous functions.\n\
2684+ "Arrows should only appear in `case` expressions and anonymous functions. Maybe\
3042− \Maybe it was supposed to be a > sign instead?"
2685+ \ you want > or >= instead?"
3043− , D.toSimpleNote $
3044− "The syntax for anonymous functions is (\\x -> x + 1) so the arguments all appear\
3045− \ after the backslash and before the arrow. Maybe a backslash is missing earlier?"
3046− ]
3047 )
2686 )
3048
2687
3049 BadEquals ->
2688 BadEquals ->
@@ -3170,7 +2809,7 @@ toLetReport source context let_ startRow startCol =
3170 , D.toSimpleNote $
2809 , D.toSimpleNote $
3171 "This can also happen if you are trying to define another value within the `let` but\
2810 "This can also happen if you are trying to define another value within the `let` but\
3172 \ it is not indented enough. Make sure each definition has exactly the same amount of\
2811 \ it is not indented enough. Make sure each definition has exactly the same amount of\
3173− \ spaces before it. They should line up exactly!"
2812+ \ spaces before it. The should line up exactly!"
3174 ]
2813 ]
3175 )
2814 )
3176
2815
@@ -3240,8 +2879,8 @@ toUnfinishLetReport source row col startRow startCol message =
3240 [ message
2879 [ message
3241 , D.toSimpleNote $
2880 , D.toSimpleNote $
3242 "Here is an example with a valid `let` expression for reference:"
2881 "Here is an example with a valid `let` expression for reference:"
3243− , D.indent 4 $ D.vcat $
2882+ , D.vcat $
3244− [ D.indent 0 $ D.fillSep ["viewPerson","person","="]
2883+ [ D.indent 0 $ D.fillSep [D.green "viewPerson","person","="]
3245 , D.indent 2 $ D.fillSep [D.cyan "let"]
2884 , D.indent 2 $ D.fillSep [D.cyan "let"]
3246 , D.indent 4 $ D.fillSep ["fullName","="]
2885 , D.indent 4 $ D.fillSep ["fullName","="]
3247 , D.indent 6 $ D.fillSep ["person.firstName","++",D.dullyellow "\" \"","++","person.lastName"]
2886 , D.indent 6 $ D.fillSep ["person.firstName","++",D.dullyellow "\" \"","++","person.lastName"]
@@ -3316,57 +2955,13 @@ toLetDefReport source name def startRow startCol =
3316 region = toKeywordRegion row col keyword
2955 region = toKeywordRegion row col keyword
3317 in
2956 in
3318 Report.Report "RESERVED WORD" region [] $
2957 Report.Report "RESERVED WORD" region [] $
3319− Code.toSnippet source surroundings (Just region)
3320− (
3321− D.fillSep
3322− ["The","name"
3323− ,"`" <> D.cyan (D.fromChars keyword) <> "`"
3324− ,"is","reserved","in","Elm,","so","it","cannot"
3325− ,"be","used","as","an","argument","here:"
3326− ]
3327− ,
3328− D.stack
3329− [ D.reflow $
3330− "Try renaming it to something else."
3331− , case keyword of
3332− "as" ->
3333− D.toFancyNote
3334− ["This","keyword","is","reserved","for","pattern","matches","like"
3335− ,"((x,y)",D.cyan "as","point)","where","you","want","to","name","a","tuple","and"
3336− ,"the","values","it","contains."
3337− ]
3338−
3339− _ ->
3340− D.toSimpleNote $
3341− "The `" ++ keyword ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations."
3342− ]
3343− )
3344−
3345− Code.Operator "->" ->
3346− let
3347− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3348− region = toWiderRegion row col 2
3349− in
3350− Report.Report "MISSING COLON?" region [] $
3351 Code.toSnippet source surroundings (Just region)
2958 Code.toSnippet source surroundings (Just region)
3352 (
2959 (
3353 D.reflow $
2960 D.reflow $
3354− "I was not expecting to see an arrow here:"
2961+ "It looks like you are trying to use `" ++ keyword ++ "` as an argument:"
3355 ,
2962 ,
3356− D.stack
2963+ D.reflow $
3357− [ D.fillSep
2964+ "This is a reserved word! Try using some other name?"
3358− ["This","usually","means","a",D.green ":","is","missing","a","bit","earlier","in"
3359− ,"a","type","annotation.","It","could","be","something","else","though,","so"
3360− ,"here","is","a","valid","definition","for","reference:"
3361− ]
3362− , D.indent 4 $ D.vcat $
3363− [ "greet : String -> String"
3364− , "greet name ="
3365− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
3366− ]
3367− , D.reflow $
3368− "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
3369− ]
3370 )
2965 )
3371
2966
3372 Code.Operator op ->
2967 Code.Operator op ->
@@ -3384,10 +2979,10 @@ toLetDefReport source name def startRow startCol =
3384 [ D.reflow $
2979 [ D.reflow $
3385 "I am not sure what is going wrong exactly, so here is a valid\
2980 "I am not sure what is going wrong exactly, so here is a valid\
3386 \ definition (with an optional type annotation) for reference:"
2981 \ definition (with an optional type annotation) for reference:"
3387− , D.indent 4 $ D.vcat $
2982+ , D.vcat
3388− [ "greet : String -> String"
2983+ [ D.indent 4 $ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
3389− , "greet name ="
2984+ , D.indent 4 $ D.fillSep [D.green "add","x","y","="]
3390− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
2985+ , D.indent 6 $ D.fillSep ["x","+","y"]
3391 ]
2986 ]
3392 , D.reflow $
2987 , D.reflow $
3393 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
2988 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
@@ -3409,10 +3004,10 @@ toLetDefReport source name def startRow startCol =
3409 [ D.reflow $
3004 [ D.reflow $
3410 "I am not sure what is going wrong exactly, so here is a valid\
3005 "I am not sure what is going wrong exactly, so here is a valid\
3411 \ definition (with an optional type annotation) for reference:"
3006 \ definition (with an optional type annotation) for reference:"
3412− , D.indent 4 $ D.vcat $
3007+ , D.vcat
3413− [ "greet : String -> String"
3008+ [ D.indent 4 $ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
3414− , "greet name ="
3009+ , D.indent 4 $ D.fillSep [D.green "add","x","y","="]
3415− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
3010+ , D.indent 4 $ D.fillSep ["x","+","y"]
3416 ]
3011 ]
3417 , D.reflow $
3012 , D.reflow $
3418 "Try to use that format!"
3013 "Try to use that format!"
@@ -3502,10 +3097,10 @@ defNote =
3502 D.stack
3097 D.stack
3503 [ D.reflow $
3098 [ D.reflow $
3504 "Here is a valid definition (with a type annotation) for reference:"
3099 "Here is a valid definition (with a type annotation) for reference:"
3505− , D.indent 4 $ D.vcat $
3100+ , D.vcat
3506− [ "greet : String -> String"
3101+ [ D.indent 4 $ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
3507− , "greet name ="
3102+ , D.indent 4 $ D.fillSep [D.green "add","x","y","="]
3508− , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
3103+ , D.indent 6 $ D.fillSep ["x","+","y"]
3509 ]
3104 ]
3510 , D.reflow $
3105 , D.reflow $
3511 "The top line (called a \"type annotation\") is optional. You can leave it off\
3106 "The top line (called a \"type annotation\") is optional. You can leave it off\
@@ -3668,10 +3263,9 @@ toCaseReport source context case_ startRow startCol =
3668 D.reflow $
3263 D.reflow $
3669 "I am partway through parsing a `case` expression, but I got stuck here:"
3264 "I am partway through parsing a `case` expression, but I got stuck here:"
3670 ,
3265 ,
3671− D.stack
3266+ addNoteForCaseIndentError $
3267+ D.reflow $
3672− [ D.reflow "I was expecting to see an arrow next."
3268+ "I was expecting to see an arrow next."
3673− , noteForCaseIndentError
3674− ]
3675 )
3269 )
3676
3270
3677 CaseExpr expr row col ->
3271 CaseExpr expr row col ->
@@ -3719,39 +3313,34 @@ toUnfinishCaseReport source row col startRow startCol message =
3719 in
3313 in
3720 Report.Report "UNFINISHED CASE" region [] $
3314 Report.Report "UNFINISHED CASE" region [] $
3721 Code.toSnippet source surroundings (Just region)
3315 Code.toSnippet source surroundings (Just region)
3722− (
3316+ (
3723− D.reflow $
3317+ D.reflow $
3724− "I was partway through parsing a `case` expression, but I got stuck here:"
3318+ "I was partway through parsing a `case` expression, but I got stuck here:"
3725− ,
3319+ ,
3726− D.stack
3320+ D.stack
3727− [ message
3321+ [ message
3728− , noteForCaseError
3729− ]
3730− )
3731−
3732−
3733−noteForCaseError :: D.Doc
3734−noteForCaseError =
3735− D.stack
3736− [ D.toSimpleNote $
3322+ , D.toSimpleNote $
3737− "Here is an example of a valid `case` expression for reference."
3323+ "Here is an example of a valid `case` expression for reference."
3738− , D.vcat $
3324+ , D.vcat $
3739− [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
3325+ [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
3740− , D.indent 6 $ D.fillSep [D.blue "Just","width","->"]
3326+ , D.indent 6 $ D.fillSep [D.blue "Just","width","->"]
3741− , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"]
3327+ , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"]
3742− , ""
3328+ , ""
3743− , D.indent 6 $ D.fillSep [D.blue "Nothing","->"]
3329+ , D.indent 6 $ D.fillSep [D.blue "Nothing","->"]
3744− , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3330+ , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3745− ]
3331+ ]
3746− , D.reflow $
3332+ , D.reflow $
3747− "Notice the indentation. Each pattern is aligned, and each branch is indented\
3333+ "Notice the indentation. Each pattern is aligned, and each branch is indented\
3748− \ a bit more than the corresponding pattern. That is important!"
3334+ \ a bit more than the corresponding pattern. That is important!"
3749− ]
3335+ ]
3336+ )
3750
3337
3751
3338
3752−noteForCaseIndentError :: D.Doc
3339+addNoteForCaseIndentError :: D.Doc -> D.Doc
3753−noteForCaseIndentError =
3340+addNoteForCaseIndentError message =
3754− D.stack
3341+ D.stack $
3342+ message
3343+ :
3755 [ D.toSimpleNote $
3344 [ D.toSimpleNote $
3756 "Sometimes I get confused by indentation, so try to make your `case` look\
3345 "Sometimes I get confused by indentation, so try to make your `case` look\
3757 \ something like this:"
3346 \ something like this:"
@@ -3764,9 +3353,8 @@ noteForCaseIndentError =
3764 , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3353 , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3765 ]
3354 ]
3766 , D.reflow $
3355 , D.reflow $
3767− "Notice the indentation! Patterns are aligned with each other. Same indentation.\
3356+ "Notice the indentation! Each pattern is aligned, and each branch is indented\
3768− \ The expressions after each arrow are all indented a bit more than the patterns.\
3769− \ That is important!"
3357+ \ a bit more than the corresponding pattern. That is important!"
3770 ]
3358 ]
3771
3359
3772
3360
@@ -3918,43 +3506,23 @@ toIfReport source context if_ startRow startCol =
3918 )
3506 )
3919
3507
3920 IfIndentElse row col ->
3508 IfIndentElse row col ->
3921− case Code.nextLineStartsWithKeyword "else" source row of
3922− Just (elseRow, elseCol) ->
3923− let
3509+ let
3924− surroundings = A.Region (A.Position startRow startCol) (A.Position elseRow elseCol)
3925− region = toWiderRegion elseRow elseCol 4
3926− in
3927− Report.Report "WEIRD ELSE BRANCH" region [] $
3928− Code.toSnippet source surroundings (Just region)
3929− (
3930− D.reflow $
3931− "I was partway through an `if` expression when I got stuck here:"
3932− ,
3933− D.fillSep $
3934− ["I","think","this",D.cyan "else","keyword","needs","to","be","indented","more."
3935− ,"Try","adding","some","spaces","before","it."
3936− ]
3937− )
3938−
3939− Nothing ->
3940− let
3941− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3510+ surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3942− region = toRegion row col
3511+ region = toRegion row col
3943− in
3512+ in
3944− Report.Report "UNFINISHED IF" region [] $
3513+ Report.Report "UNFINISHED IF" region [] $
3945− Code.toSnippet source surroundings (Just region)
3514+ Code.toSnippet source surroundings (Just region)
3946− (
3515+ (
3947− D.reflow $
3516+ D.reflow $
3948− "I was expecting to see an `else` branch after this:"
3517+ "I was expecting to see an `else` branch after this:"
3949− ,
3518+ ,
3950− D.stack
3519+ D.stack
3951− [ D.fillSep
3520+ [ D.reflow $
3952− ["I","know","what","to","do","when","the","condition","is","True,"
3521+ "I know what to do when the condition is `True`, but not when it is `False`."
3953− ,"but","what","happens","when","it","is","False?"
3522+ , D.fillSep
3954− ,"Add","an",D.cyan "else","branch","to","handle","that","scenario!"
3523+ ["Add","an",D.cyan "else","branch","to","handle","that","scenario!"]
3955− ]
3956− ]
3524+ ]
3957− )
3525+ )
3958
3526
3959
3527
3960
3528
@@ -3987,22 +3555,15 @@ toRecordReport source context record startRow startCol =
3987 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3555 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3988 region = toRegion row col
3556 region = toRegion row col
3989 in
3557 in
3990− Report.Report "PROBLEM IN RECORD" region [] $
3558+ Report.Report "UNFINISHED RECORD" region [] $
3991 Code.toSnippet source surroundings (Just region)
3559 Code.toSnippet source surroundings (Just region)
3992 (
3560 (
3993 D.reflow $
3561 D.reflow $
3994 "I just started parsing a record, but I got stuck here:"
3562 "I just started parsing a record, but I got stuck here:"
3995 ,
3563 ,
3996− D.stack
3997− [ D.fillSep
3564+ D.fillSep
3565+ ["Records","look","like",D.dullyellow "{ x = 3, y = 4 },"
3998− ["I","was","expecting","to","see","a","record","field","defined","next,"
3566+ ,"so","I","was","expecting","to","see","a","field","name","next."
3999− ,"so","I","am","looking","for","a","name","like"
4000− ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
4001− ]
4002− , D.toSimpleNote $
4003− "Field names must start with a lower-case letter. After that, you can use\
4004− \ any sequence of letters, numbers, and underscores."
4005− , noteForRecordError
4006 ]
3567 ]
4007 )
3568 )
4008
3569
@@ -4011,7 +3572,7 @@ toRecordReport source context record startRow startCol =
4011 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3572 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4012 region = toRegion row col
3573 region = toRegion row col
4013 in
3574 in
4014− Report.Report "PROBLEM IN RECORD" region [] $
3575+ Report.Report "UNFINISHED RECORD" region [] $
4015 Code.toSnippet source surroundings (Just region)
3576 Code.toSnippet source surroundings (Just region)
4016 (
3577 (
4017 D.reflow $
3578 D.reflow $
@@ -4046,67 +3607,22 @@ toRecordReport source context record startRow startCol =
4046 \ that is a reserved word. Try using a different name!"
3607 \ that is a reserved word. Try using a different name!"
4047 )
3608 )
4048
3609
4049− Code.Other (Just ',') ->
4050− let
4051− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4052− region = toRegion row col
4053− in
4054− Report.Report "EXTRA COMMA" region [] $
4055− Code.toSnippet source surroundings (Just region)
4056− (
4057− D.reflow $
4058− "I am partway through parsing a record, but I got stuck here:"
4059− ,
4060− D.stack
4061− [ D.reflow $
4062− "I am seeing two commas in a row. This is the second one!"
4063− , D.reflow $
4064− "Just delete one of the commas and you should be all set!"
4065− , noteForRecordError
4066− ]
4067− )
4068−
4069− Code.Close _ '}' ->
4070− let
4071− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4072− region = toRegion row col
4073− in
4074− Report.Report "EXTRA COMMA" region [] $
4075− Code.toSnippet source surroundings (Just region)
4076− (
4077− D.reflow $
4078− "I am partway through parsing a record, but I got stuck here:"
4079− ,
4080− D.stack
4081− [ D.reflow $
4082− "Trailing commas are not allowed in records. Try deleting the comma that appears\
4083− \ before this closing curly brace."
4084− , noteForRecordError
4085− ]
4086− )
4087−
4088 _ ->
3610 _ ->
4089 let
3611 let
4090 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3612 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4091 region = toRegion row col
3613 region = toRegion row col
4092 in
3614 in
4093− Report.Report "PROBLEM IN RECORD" region [] $
3615+ Report.Report "UNFINISHED RECORD" region [] $
4094 Code.toSnippet source surroundings (Just region)
3616 Code.toSnippet source surroundings (Just region)
4095 (
3617 (
4096 D.reflow $
3618 D.reflow $
4097− "I am partway through parsing a record, but I got stuck here:"
3619+ "I am partway through parsing a record, but I got stuck after that last comma:"
4098 ,
3620 ,
4099− D.stack
3621+ addNoteForRecordError $
4100− [ D.fillSep
3622+ D.reflow $
4101− ["I","was","expecting","to","see","another","record","field","defined","next,"
3623+ "Trailing commas are not allowed in records, so I was expecting to see another\
4102− ,"so","I","am","looking","for","a","name","like"
3624+ \ record field defined next. If you are done defining the record, the fix may\
4103− ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
3625+ \ be to delete that last comma?"
4104− ]
4105− , D.toSimpleNote $
4106− "Field names must start with a lower-case letter. After that, you can use\
4107− \ any sequence of letters, numbers, and underscores."
4108− , noteForRecordError
4109− ]
4110 )
3626 )
4111
3627
4112 RecordEquals row col ->
3628 RecordEquals row col ->
@@ -4114,19 +3630,17 @@ toRecordReport source context record startRow startCol =
4114 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3630 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4115 region = toRegion row col
3631 region = toRegion row col
4116 in
3632 in
4117− Report.Report "PROBLEM IN RECORD" region [] $
3633+ Report.Report "UNFINISHED RECORD" region [] $
4118 Code.toSnippet source surroundings (Just region)
3634 Code.toSnippet source surroundings (Just region)
4119 (
3635 (
4120 D.reflow $
3636 D.reflow $
4121 "I am partway through parsing a record, but I got stuck here:"
3637 "I am partway through parsing a record, but I got stuck here:"
4122 ,
3638 ,
4123− D.stack
3639+ addNoteForRecordError $
4124− [ D.fillSep $
3640+ D.fillSep $
4125− ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
3641+ ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
4126− ,"an","equals","sign","next.","So","try","putting","an",D.green "=","sign","here?"
3642+ ,"an","equals","sign","next.","So","try","putting","an",D.green "=","sign","here?"
4127− ]
4128− , noteForRecordError
4129− ]
3643+ ]
4130 )
3644 )
4131
3645
4132 RecordExpr expr row col ->
3646 RecordExpr expr row col ->
@@ -4146,54 +3660,29 @@ toRecordReport source context record startRow startCol =
4146 D.reflow $
3660 D.reflow $
4147 "I just saw the opening curly brace of a record, but then I got stuck here:"
3661 "I just saw the opening curly brace of a record, but then I got stuck here:"
4148 ,
3662 ,
4149− D.stack
3663+ addNoteForRecordIndentError $
4150− [ D.fillSep $
3664+ D.fillSep $
4151− ["I","am","expecting","a","record","like",D.dullyellow "{ x = 3, y = 4 }","here."
3665+ ["I","am","expecting","a","record","like",D.dullyellow "{ x = 3, y = 4 }","here."
4152− ,"Try","defining","some","fields","of","your","own?"
3666+ ,"Try","defining","some","fields","of","your","own?"
4153− ]
4154− , noteForRecordIndentError
4155− ]
3667+ ]
4156 )
3668 )
4157
3669
4158 RecordIndentEnd row col ->
3670 RecordIndentEnd row col ->
4159− case Code.nextLineStartsWithCloseCurly source row of
4160− Just (curlyRow, curlyCol) ->
4161− let
3671+ let
4162− surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol)
4163− region = toRegion curlyRow curlyCol
4164− in
4165− Report.Report "NEED MORE INDENTATION" region [] $
4166− Code.toSnippet source surroundings (Just region)
4167− (
4168− D.reflow $
4169− "I was partway through parsing a record, but I got stuck here:"
4170− ,
4171− D.stack
4172− [ D.reflow $
4173− "I need this curly brace to be indented more. Try adding some spaces before it!"
4174− , noteForRecordError
4175− ]
4176− )
4177−
4178− Nothing ->
4179− let
4180− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3672+ surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4181− region = toRegion row col
3673+ region = toRegion row col
4182− in
3674+ in
4183− Report.Report "UNFINISHED RECORD" region [] $
3675+ Report.Report "UNFINISHED RECORD" region [] $
4184− Code.toSnippet source surroundings (Just region)
3676+ Code.toSnippet source surroundings (Just region)
4185− (
3677+ (
4186− D.reflow $
3678+ D.reflow $
4187− "I was partway through parsing a record, but I got stuck here:"
4188− ,
4189− D.stack
4190− [ D.fillSep $
4191− ["I","was","expecting","to","see","a","closing","curly","brace","next."
3679+ "I was expecting to see a closing curly brace next:"
3680+ ,
3681+ addNoteForRecordIndentError $
3682+ D.fillSep $
4192− ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?"
3683+ ["Try","putting","an",D.green "}","and","see","if","that","helps?"
4193− ]
3684+ ]
4194− , noteForRecordIndentError
4195− ]
4196− )
3685+ )
4197
3686
4198 RecordIndentField row col ->
3687 RecordIndentField row col ->
4199 let
3688 let
@@ -4206,13 +3695,11 @@ toRecordReport source context record startRow startCol =
4206 D.reflow $
3695 D.reflow $
4207 "I am partway through parsing a record, but I got stuck after that last comma:"
3696 "I am partway through parsing a record, but I got stuck after that last comma:"
4208 ,
3697 ,
4209− D.stack
3698+ addNoteForRecordError $
4210− [ D.reflow $
3699+ D.reflow $
4211− "Trailing commas are not allowed in records, so the fix may be to\
3700+ "Trailing commas are not allowed in records, so the fix may be to\
4212− \ delete that last comma? Or maybe you were in the middle of defining\
3701+ \ delete that last comma? Or maybe you were in the middle of defining\
4213− \ an additional field?"
3702+ \ an additional field?"
4214− , noteForRecordError
4215− ]
4216 )
3703 )
4217
3704
4218 RecordIndentEquals row col ->
3705 RecordIndentEquals row col ->
@@ -4227,12 +3714,10 @@ toRecordReport source context record startRow startCol =
4227 "I am partway through parsing a record. I just saw a record\
3714 "I am partway through parsing a record. I just saw a record\
4228 \ field, so I was expecting to see an equals sign next:"
3715 \ field, so I was expecting to see an equals sign next:"
4229 ,
3716 ,
4230− D.stack
3717+ addNoteForRecordIndentError $
4231− [ D.fillSep $
3718+ D.fillSep $
4232− ["Try","putting","an",D.green "=","followed","by","an","expression?"
3719+ ["Try","putting","an",D.green "=","followed","by","an","expression?"
4233− ]
4234− , noteForRecordIndentError
4235− ]
3720+ ]
4236 )
3721 )
4237
3722
4238 RecordIndentExpr row col ->
3723 RecordIndentExpr row col ->
@@ -4246,48 +3731,52 @@ toRecordReport source context record startRow startCol =
4246 D.reflow $
3731 D.reflow $
4247 "I am partway through parsing a record, and I was expecting to run into an expression next:"
3732 "I am partway through parsing a record, and I was expecting to run into an expression next:"
4248 ,
3733 ,
4249− D.stack
3734+ addNoteForRecordIndentError $
4250− [ D.fillSep $
3735+ D.fillSep $
4251− ["Try","putting","something","like"
3736+ ["Try","putting","something","like"
4252− ,D.dullyellow "42","or",D.dullyellow"\"hello\"","for","now?"
3737+ ,D.dullyellow "42","or",D.dullyellow"\"hello\"","for","now?"
4253− ]
4254− , noteForRecordIndentError
4255− ]
3738+ ]
4256 )
3739 )
4257
3740
4258
3741
4259−noteForRecordError :: D.Doc
3742+addNoteForRecordError :: D.Doc -> D.Doc
4260−noteForRecordError =
3743+addNoteForRecordError normalRecommendation =
4261 D.stack $
3744 D.stack $
3745+ normalRecommendation
3746+ :
4262 [ D.toSimpleNote
3747 [ D.toSimpleNote
4263 "If you are trying to define a record across multiple lines, I recommend using this format:"
3748 "If you are trying to define a record across multiple lines, I recommend using this format:"
4264 , D.indent 4 $ D.vcat $
3749 , D.indent 4 $ D.vcat $
4265− [ "{ name = " <> D.dullyellow "\"Alice\""
3750+ [ "{ name = \"Alice\""
4266− , ", age = " <> D.dullyellow "42"
3751+ , ", age = 42"
4267− , ", height = " <> D.dullyellow "1.75"
3752+ , ", height = 1.75"
4268 , "}"
3753 , "}"
4269 ]
3754 ]
4270 , D.reflow $
3755 , D.reflow $
4271− "Notice that each line starts with some indentation. Usually two or four spaces.\
3756+ "Notice that each line starts with some indentation. Usually two or four spaces. I\
4272− \ This is the stylistic convention in the Elm ecosystem."
3757+ \ know this style can be jarring for people coming from C-like syntax, but folks generally\
3758+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4273 ]
3759 ]
4274
3760
4275
3761
4276−noteForRecordIndentError :: D.Doc
3762+addNoteForRecordIndentError :: D.Doc -> D.Doc
4277−noteForRecordIndentError =
3763+addNoteForRecordIndentError normalRecommendation =
4278− D.stack
3764+ D.stack $
3765+ normalRecommendation
3766+ :
4279 [ D.toSimpleNote
3767 [ D.toSimpleNote
4280 "I may be confused by indentation. For example, if you are trying to define\
3768 "I may be confused by indentation. For example, if you are trying to define\
4281 \ a record across multiple lines, I recommend using this format:"
3769 \ a record across multiple lines, I recommend using this format:"
4282 , D.indent 4 $ D.vcat $
3770 , D.indent 4 $ D.vcat $
4283− [ "{ name = " <> D.dullyellow "\"Alice\""
3771+ [ "{ name = \"Alice\""
4284− , ", age = " <> D.dullyellow "42"
3772+ , ", age = 42"
4285− , ", height = " <> D.dullyellow "1.75"
3773+ , ", height = 1.75"
4286 , "}"
3774 , "}"
4287 ]
3775 ]
4288 , D.reflow $
3776 , D.reflow $
4289− "Notice that each line starts with some indentation. Usually two or four spaces.\
3777+ "Notice that each line starts with some indentation. Usually two or four spaces. I\
4290− \ This is the stylistic convention in the Elm ecosystem!"
3778+ \ know this style can be jarring for people coming from C-like syntax, but folks generally\
3779+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4291 ]
3780 ]
4292
3781
4293
3782
@@ -4476,14 +3965,15 @@ toListReport source context list startRow startCol =
4476 , D.toSimpleNote
3965 , D.toSimpleNote
4477 "I recommend using the following format for lists that span multiple lines:"
3966 "I recommend using the following format for lists that span multiple lines:"
4478 , D.indent 4 $ D.vcat $
3967 , D.indent 4 $ D.vcat $
4479− [ "[ " <> D.dullyellow "\"Alice\""
3968+ [ "[ \"Alice\""
4480− , ", " <> D.dullyellow "\"Bob\""
3969+ , ", \"Bob\""
4481− , ", " <> D.dullyellow "\"Chuck\""
3970+ , ", \"Chuck\""
4482 , "]"
3971 , "]"
4483 ]
3972 ]
4484 , D.reflow $
3973 , D.reflow $
4485− "Notice that each line starts with some indentation. Usually two or four spaces.\
3974+ "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4486− \ This is the stylistic convention in the Elm ecosystem."
3975+ \ This style can be jarring for people coming from C-like syntax, but folks generally\
3976+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4487 ]
3977 ]
4488 )
3978 )
4489
3979
@@ -4536,14 +4026,15 @@ toListReport source context list startRow startCol =
4536 "I may be confused by indentation. For example, if you are trying to define\
4026 "I may be confused by indentation. For example, if you are trying to define\
4537 \ a list across multiple lines, I recommend using this format:"
4027 \ a list across multiple lines, I recommend using this format:"
4538 , D.indent 4 $ D.vcat $
4028 , D.indent 4 $ D.vcat $
4539− [ "[ " <> D.dullyellow "\"Alice\""
4029+ [ "[ \"Alice\""
4540− , ", " <> D.dullyellow "\"Bob\""
4030+ , ", \"Bob\""
4541− , ", " <> D.dullyellow "\"Chuck\""
4031+ , ", \"Chuck\""
4542 , "]"
4032 , "]"
4543 ]
4033 ]
4544 , D.reflow $
4034 , D.reflow $
4545− "Notice that each line starts with some indentation. Usually two or four spaces.\
4035+ "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4546− \ This is the stylistic convention in the Elm ecosystem."
4036+ \ This style can be jarring for people coming from C-like syntax, but folks generally\
4037+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4547 ]
4038 ]
4548 )
4039 )
4549
4040
@@ -4567,14 +4058,15 @@ toListReport source context list startRow startCol =
4567 "I may be confused by indentation. For example, if you are trying to define\
4058 "I may be confused by indentation. For example, if you are trying to define\
4568 \ a list across multiple lines, I recommend using this format:"
4059 \ a list across multiple lines, I recommend using this format:"
4569 , D.indent 4 $ D.vcat $
4060 , D.indent 4 $ D.vcat $
4570− [ "[ " <> D.dullyellow "\"Alice\""
4061+ [ "[ \"Alice\""
4571− , ", " <> D.dullyellow "\"Bob\""
4062+ , ", \"Bob\""
4572− , ", " <> D.dullyellow "\"Chuck\""
4063+ , ", \"Chuck\""
4573 , "]"
4064 , "]"
4574 ]
4065 ]
4575 , D.reflow $
4066 , D.reflow $
4576− "Notice that each line starts with some indentation. Usually two or four spaces.\
4067+ "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4577− \ This is the stylistic convention in the Elm ecosystem."
4068+ \ This style can be jarring for people coming from C-like syntax, but folks generally\
4069+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4578 ]
4070 ]
4579 )
4071 )
4580
4072
@@ -4595,14 +4087,15 @@ toListReport source context list startRow startCol =
4595 , D.toSimpleNote
4087 , D.toSimpleNote
4596 "I recommend using the following format for lists that span multiple lines:"
4088 "I recommend using the following format for lists that span multiple lines:"
4597 , D.indent 4 $ D.vcat $
4089 , D.indent 4 $ D.vcat $
4598− [ "[ " <> D.dullyellow "\"Alice\""
4090+ [ "[ \"Alice\""
4599− , ", " <> D.dullyellow "\"Bob\""
4091+ , ", \"Bob\""
4600− , ", " <> D.dullyellow "\"Chuck\""
4092+ , ", \"Chuck\""
4601 , "]"
4093 , "]"
4602 ]
4094 ]
4603 , D.reflow $
4095 , D.reflow $
4604− "Notice that each line starts with some indentation. Usually two or four spaces.\
4096+ "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4605− \ This is the stylistic convention in the Elm ecosystem."
4097+ \ This style can be jarring for people coming from C-like syntax, but folks generally\
4098+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4606 ]
4099 ]
4607 )
4100 )
4608
4101
@@ -4851,7 +4344,7 @@ toPatternReport source context pattern startRow startCol =
4851 ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")"
4344 ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")"
4852 ,"so","you","can","refer","to","individual","parts","of","the","tuple","with"
4345 ,"so","you","can","refer","to","individual","parts","of","the","tuple","with"
4853 ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole"
4346 ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole"
4854− ,"thing","with",D.dullyellow "point" <> "."
4347+ ,"thing","with",D.dullyellow "point."
4855 ]
4348 ]
4856 , D.reflow $
4349 , D.reflow $
4857 "So I was expecting to see a variable name after the `as` keyword here. Sometimes\
4350 "So I was expecting to see a variable name after the `as` keyword here. Sometimes\
@@ -5043,7 +4536,7 @@ toPTupleReport source context tuple startRow startCol =
5043 "I just saw an open parenthesis, but I got stuck here:"
4536 "I just saw an open parenthesis, but I got stuck here:"
5044 ,
4537 ,
5045 D.fillSep
4538 D.fillSep
5046− ["I","was","expecting","to","see","a","pattern","next."
4539+ ["I","was","expecting","so","see","a","pattern","next."
5047 ,"Maybe","it","will","end","up","being","something"
4540 ,"Maybe","it","will","end","up","being","something"
5048 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
4541 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
5049 ]
4542 ]
@@ -5152,7 +4645,7 @@ toPTupleReport source context tuple startRow startCol =
5152 "I just saw an open parenthesis, but then I got stuck here:"
4645 "I just saw an open parenthesis, but then I got stuck here:"
5153 ,
4646 ,
5154 D.fillSep
4647 D.fillSep
5155− ["I","was","expecting","to","see","a","pattern","next."
4648+ ["I","was","expecting","so","see","a","pattern","next."
5156 ,"Maybe","it","will","end","up","being","something"
4649 ,"Maybe","it","will","end","up","being","something"
5157 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
4650 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
5158 ]
4651 ]
@@ -5171,7 +4664,7 @@ toPTupleReport source context tuple startRow startCol =
5171 ,
4664 ,
5172 D.stack
4665 D.stack
5173 [ D.fillSep
4666 [ D.fillSep
5174− ["I","was","expecting","to","see","a","pattern","next."
4667+ ["I","was","expecting","so","see","a","pattern","next."
5175 ,"I","am","expecting","the","final","result","to","be","something"
4668 ,"I","am","expecting","the","final","result","to","be","something"
5176 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "."
4669 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "."
5177 ]
4670 ]
@@ -5475,64 +4968,22 @@ toTRecordReport source context record startRow startCol =
5475 \ that is a reserved word. Try using a different name!"
4968 \ that is a reserved word. Try using a different name!"
5476 )
4969 )
5477
4970
5478− Code.Other (Just ',') ->
5479− let
5480− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5481− region = toRegion row col
5482− in
5483− Report.Report "EXTRA COMMA" region [] $
5484− Code.toSnippet source surroundings (Just region)
5485− (
5486− D.reflow $
5487− "I am partway through parsing a record type, but I got stuck here:"
5488− ,
5489− D.stack
5490− [ D.reflow $
5491− "I am seeing two commas in a row. This is the second one!"
5492− , D.reflow $
5493− "Just delete one of the commas and you should be all set!"
5494− , noteForRecordTypeError
5495− ]
5496− )
5497−
5498− Code.Close _ '}' ->
5499− let
5500− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5501− region = toRegion row col
5502− in
5503− Report.Report "EXTRA COMMA" region [] $
5504− Code.toSnippet source surroundings (Just region)
5505− (
5506− D.reflow $
5507− "I am partway through parsing a record type, but I got stuck here:"
5508− ,
5509− D.stack
5510− [ D.reflow $
5511− "Trailing commas are not allowed in record types. Try deleting the comma that\
5512− \ appears before this closing curly brace."
5513− , noteForRecordTypeError
5514− ]
5515− )
5516−
5517 _ ->
4971 _ ->
5518 let
4972 let
5519 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4973 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5520 region = toRegion row col
4974 region = toRegion row col
5521 in
4975 in
5522− Report.Report "PROBLEM IN RECORD TYPE" region [] $
4976+ Report.Report "UNFINISHED RECORD TYPE" region [] $
5523 Code.toSnippet source surroundings (Just region)
4977 Code.toSnippet source surroundings (Just region)
5524 (
4978 (
5525 D.reflow $
4979 D.reflow $
5526− "I am partway through parsing a record type, but I got stuck here:"
4980+ "I am partway through parsing a record type, but I got stuck after that last comma:"
5527 ,
4981 ,
5528− D.stack
4982+ addNoteForRecordTypeError $
5529− [ D.fillSep
4983+ D.reflow $
5530− ["I","was","expecting","to","see","another","record","field","defined","next,"
4984+ "Trailing commas are not allowed in records, so I was expecting to see another\
5531− ,"so","I","am","looking","for","a","name","like"
4985+ \ record field defined next. If you are done defining the record, the fix may\
5532− ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
4986+ \ be to delete that last comma?"
5533− ]
5534− , noteForRecordTypeError
5535− ]
5536 )
4987 )
5537
4988
5538 TRecordColon row col ->
4989 TRecordColon row col ->
@@ -5546,13 +4997,11 @@ toTRecordReport source context record startRow startCol =
5546 D.reflow $
4997 D.reflow $
5547 "I am partway through parsing a record type, but I got stuck here:"
4998 "I am partway through parsing a record type, but I got stuck here:"
5548 ,
4999 ,
5549− D.stack
5000+ addNoteForRecordTypeError $
5550− [ D.fillSep $
5001+ D.fillSep $
5551− ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
5002+ ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
5552− ,"a","colon","next.","So","try","putting","an",D.green ":","sign","here?"
5003+ ,"a","colon","next.","So","try","putting","an",D.green ":","sign","here?"
5553− ]
5554− , noteForRecordTypeError
5555− ]
5004+ ]
5556 )
5005 )
5557
5006
5558 TRecordType tipe row col ->
5007 TRecordType tipe row col ->
@@ -5572,54 +5021,29 @@ toTRecordReport source context record startRow startCol =
5572 D.reflow $
5021 D.reflow $
5573 "I just saw the opening curly brace of a record type, but then I got stuck here:"
5022 "I just saw the opening curly brace of a record type, but then I got stuck here:"
5574 ,
5023 ,
5575− D.stack
5024+ addNoteForRecordTypeIndentError $
5576− [ D.fillSep $
5025+ D.fillSep $
5577− ["I","am","expecting","a","record","like",D.dullyellow "{ name : String, age : Int }","here."
5026+ ["I","am","expecting","a","record","like",D.dullyellow "{ name : String, age : Int }","here."
5578− ,"Try","defining","some","fields","of","your","own?"
5027+ ,"Try","defining","some","fields","of","your","own?"
5579− ]
5580− , noteForRecordTypeIndentError
5581− ]
5028+ ]
5582 )
5029 )
5583
5030
5584 TRecordIndentEnd row col ->
5031 TRecordIndentEnd row col ->
5585− case Code.nextLineStartsWithCloseCurly source row of
5586− Just (curlyRow, curlyCol) ->
5587− let
5032+ let
5588− surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol)
5589− region = toRegion curlyRow curlyCol
5590− in
5591− Report.Report "NEED MORE INDENTATION" region [] $
5592− Code.toSnippet source surroundings (Just region)
5593− (
5594− D.reflow $
5595− "I was partway through parsing a record type, but I got stuck here:"
5596− ,
5597− D.stack
5598− [ D.reflow $
5599− "I need this curly brace to be indented more. Try adding some spaces before it!"
5600− , noteForRecordTypeError
5601− ]
5602− )
5603−
5604− Nothing ->
5605− let
5606− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5033+ surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5607− region = toRegion row col
5034+ region = toRegion row col
5608− in
5035+ in
5609− Report.Report "UNFINISHED RECORD TYPE" region [] $
5036+ Report.Report "UNFINISHED RECORD TYPE" region [] $
5610− Code.toSnippet source surroundings (Just region)
5037+ Code.toSnippet source surroundings (Just region)
5611− (
5038+ (
5612− D.reflow $
5039+ D.reflow $
5613− "I was partway through parsing a record type, but I got stuck here:"
5614− ,
5615− D.stack
5616− [ D.fillSep $
5617− ["I","was","expecting","to","see","a","closing","curly","brace","next."
5040+ "I was expecting to see a closing curly brace next:"
5041+ ,
5042+ addNoteForRecordTypeIndentError $
5043+ D.fillSep $
5618− ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?"
5044+ ["Try","putting","an",D.green "}","and","see","if","that","helps?"
5619− ]
5045+ ]
5620− , noteForRecordTypeIndentError
5621− ]
5622− )
5046+ )
5623
5047
5624 TRecordIndentField row col ->
5048 TRecordIndentField row col ->
5625 let
5049 let
@@ -5632,13 +5056,11 @@ toTRecordReport source context record startRow startCol =
5632 D.reflow $
5056 D.reflow $
5633 "I am partway through parsing a record type, but I got stuck after that last comma:"
5057 "I am partway through parsing a record type, but I got stuck after that last comma:"
5634 ,
5058 ,
5635− D.stack
5059+ addNoteForRecordTypeIndentError $
5636− [ D.reflow $
5060+ D.reflow $
5637− "Trailing commas are not allowed in record types, so the fix may be to\
5061+ "Trailing commas are not allowed in record types, so the fix may be to\
5638− \ delete that last comma? Or maybe you were in the middle of defining\
5062+ \ delete that last comma? Or maybe you were in the middle of defining\
5639− \ an additional field?"
5063+ \ an additional field?"
5640− , noteForRecordTypeIndentError
5641− ]
5642 )
5064 )
5643
5065
5644 TRecordIndentColon row col ->
5066 TRecordIndentColon row col ->
@@ -5653,12 +5075,10 @@ toTRecordReport source context record startRow startCol =
5653 "I am partway through parsing a record type. I just saw a record\
5075 "I am partway through parsing a record type. I just saw a record\
5654 \ field, so I was expecting to see a colon next:"
5076 \ field, so I was expecting to see a colon next:"
5655 ,
5077 ,
5656− D.stack
5078+ addNoteForRecordTypeIndentError $
5657− [ D.fillSep $
5079+ D.fillSep $
5658− ["Try","putting","an",D.green ":","followed","by","a","type?"
5080+ ["Try","putting","an",D.green ":","followed","by","a","type?"
5659− ]
5660− , noteForRecordTypeIndentError
5661− ]
5081+ ]
5662 )
5082 )
5663
5083
5664 TRecordIndentType row col ->
5084 TRecordIndentType row col ->
@@ -5672,19 +5092,19 @@ toTRecordReport source context record startRow startCol =
5672 D.reflow $
5092 D.reflow $
5673 "I am partway through parsing a record type, and I was expecting to run into a type next:"
5093 "I am partway through parsing a record type, and I was expecting to run into a type next:"
5674 ,
5094 ,
5675− D.stack
5095+ addNoteForRecordTypeIndentError $
5676− [ D.fillSep $
5096+ D.fillSep $
5677− ["Try","putting","something","like"
5097+ ["Try","putting","something","like"
5678− ,D.dullyellow "Int","or",D.dullyellow "String","for","now?"
5098+ ,D.dullyellow "Int","or",D.dullyellow "String","for","now?"
5679− ]
5680− , noteForRecordTypeIndentError
5681− ]
5099+ ]
5682 )
5100 )
5683
5101
5684
5102
5685−noteForRecordTypeError :: D.Doc
5103+addNoteForRecordTypeError :: D.Doc -> D.Doc
5686−noteForRecordTypeError =
5104+addNoteForRecordTypeError normalRecommendation =
5687 D.stack $
5105 D.stack $
5106+ normalRecommendation
5107+ :
5688 [ D.toSimpleNote
5108 [ D.toSimpleNote
5689 "If you are trying to define a record type across multiple lines, I recommend using this format:"
5109 "If you are trying to define a record type across multiple lines, I recommend using this format:"
5690 , D.indent 4 $ D.vcat $
5110 , D.indent 4 $ D.vcat $
@@ -5694,14 +5114,17 @@ noteForRecordTypeError =
5694 , "}"
5114 , "}"
5695 ]
5115 ]
5696 , D.reflow $
5116 , D.reflow $
5697− "Notice that each line starts with some indentation. Usually two or four spaces.\
5117+ "Notice that each line starts with some indentation. Usually two or four spaces. I\
5698− \ This is the stylistic convention in the Elm ecosystem."
5118+ \ know this style can be jarring for people coming from C-like syntax, but folks generally\
5119+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
5699 ]
5120 ]
5700
5121
5701
5122
5702−noteForRecordTypeIndentError :: D.Doc
5123+addNoteForRecordTypeIndentError :: D.Doc -> D.Doc
5703−noteForRecordTypeIndentError =
5124+addNoteForRecordTypeIndentError normalRecommendation =
5704 D.stack $
5125 D.stack $
5126+ normalRecommendation
5127+ :
5705 [ D.toSimpleNote
5128 [ D.toSimpleNote
5706 "I may be confused by indentation. For example, if you are trying to define\
5129 "I may be confused by indentation. For example, if you are trying to define\
5707 \ a record type across multiple lines, I recommend using this format:"
5130 \ a record type across multiple lines, I recommend using this format:"
@@ -5712,8 +5135,9 @@ noteForRecordTypeIndentError =
5712 , "}"
5135 , "}"
5713 ]
5136 ]
5714 , D.reflow $
5137 , D.reflow $
5715− "Notice that each line starts with some indentation. Usually two or four spaces.\
5138+ "Notice that each line starts with some indentation. Usually two or four spaces. I\
5716− \ This is the stylistic convention in the Elm ecosystem."
5139+ \ know this style can be jarring for people coming from C-like syntax, but folks generally\
5140+ \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
5717 ]
5141 ]
5718
5142
5719
5143
@@ -5765,7 +5189,7 @@ toTTupleReport source context tuple startRow startCol =
5765 Code.toSnippet source surroundings (Just region)
5189 Code.toSnippet source surroundings (Just region)
5766 (
5190 (
5767 D.reflow $
5191 D.reflow $
5768− "I was expecting to see a closing parenthesis next, but I got stuck here:"
5192+ "I was expecting to see a closing parentheses next, but I got stuck here:"
5769 ,
5193 ,
5770 D.stack
5194 D.stack
5771 [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"]
5195 [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"]
compiler/src/Reporting/Error/Type.hs+23−44
@@ -231,7 +231,7 @@ toPatternReport source localizer patternRegion category tipe expected =
231 "But all the previous patterns match:"
231 "But all the previous patterns match:"
232 [ D.link "Note"
232 [ D.link "Note"
233 "A `case` expression can only handle one type of value, so you may want to use"
233 "A `case` expression can only handle one type of value, so you may want to use"
234− "custom-types"
234+ "union-types"
235 "to handle “mixing” types."
235 "to handle “mixing” types."
236 ]
236 ]
237 )
237 )
@@ -253,11 +253,11 @@ toPatternReport source localizer patternRegion category tipe expected =
253 , patternTypeComparison localizer tipe expectedType
253 , patternTypeComparison localizer tipe expectedType
254 (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category)
254 (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category)
255 "But all the previous patterns in the list are:"
255 "But all the previous patterns in the list are:"
256− [ D.link "Hint"
256+ [ D.toSimpleHint $
257− "Everything in a list must be the same type of value. This way, we never\
257+ "Everything in the list needs to be the same type of value.\
258− \ run into unexpected values partway through a List.map, List.foldl, etc. Read"
258+ \ This way you never run into unexpected values partway through.\
259− "custom-types"
259+ \ To mix different types in a single list, create a \"union type\" as\
260− "to learn how to “mix” types."
260+ \ described in: <http://guide.elm-lang.org/types/union_types.html>"
261 ]
261 ]
262 )
262 )
263
263
@@ -431,14 +431,13 @@ problemToHint problem =
431 ]
431 ]
432 ]
432 ]
433
433
434− T.ArityMismatch x y ->
434+ T.AnythingToList ->
435− [ D.toSimpleHint $
435+ [ D.toSimpleHint "Did you forget to add [] around it?"
436− if x < y then
437− "It looks like it takes too few arguments. I was expecting " ++ show (y - x) ++ " more."
438− else
439− "It looks like it takes too many arguments. I see " ++ show (x - y) ++ " extra."
440 ]
436 ]
441
437
438+ T.MissingArgs _ -> []
439+ T.ReturnMismatch -> []
440+
442 T.BadFlexSuper direction super _ tipe ->
441 T.BadFlexSuper direction super _ tipe ->
443 case tipe of
442 case tipe of
444 T.Lambda _ _ _ -> badFlexSuper direction super tipe
443 T.Lambda _ _ _ -> badFlexSuper direction super tipe
@@ -559,31 +558,11 @@ badFlexSuper :: T.Direction -> T.Super -> T.Type -> [D.Doc]
559badFlexSuper direction super tipe =
558badFlexSuper direction super tipe =
560 case super of
559 case super of
561 T.Comparable ->
560 T.Comparable ->
562− case tipe of
563− T.Record _ _ ->
564− [ D.link "Hint"
565− "I do not know how to compare records. I can only compare ints, floats,\
566− \ chars, strings, lists of comparable values, and tuples of comparable values.\
567− \ Check out" "comparing-records" "for ideas on how to proceed."
568− ]
569−
570− T.Type _ name _ ->
571− [ D.toSimpleHint $
572− "I do not know how to compare `" ++ Name.toChars name ++ "` values. I can only\
573− \ compare ints, floats, chars, strings, lists of comparable values, and tuples\
561+ [ D.toSimpleHint "Only ints, floats, chars, strings, lists, and tuples are comparable."
574− \ of comparable values."
575− , D.reflowLink
576− "Check out" "comparing-custom-types" "for ideas on how to proceed."
577− ]
578−
579− _ ->
580− [ D.toSimpleHint $
581− "I only know how to compare ints, floats, chars, strings, lists of\
582− \ comparable values, and tuples of comparable values."
583− ]
562+ ]
584
563
585 T.Appendable ->
564 T.Appendable ->
586− [ D.toSimpleHint "I only know how to append strings and lists."
565+ [ D.toSimpleHint "Only strings and lists are appendable."
587 ]
566 ]
588
567
589 T.CompAppend ->
568 T.CompAppend ->
@@ -710,11 +689,11 @@ toExprReport source localizer exprRegion category tipe expected =
710 , "The " <> ith <> " element of this list does not match all the previous elements:"
689 , "The " <> ith <> " element of this list does not match all the previous elements:"
711 , "The " <> ith <> " element is"
690 , "The " <> ith <> " element is"
712 , "But all the previous elements in the list are:"
691 , "But all the previous elements in the list are:"
713− , [ D.link "Hint"
692+ , [ D.toSimpleHint $
714− "Everything in a list must be the same type of value. This way, we never\
693+ "Everything in the list needs to be the same type of value.\
715− \ run into unexpected values partway through a List.map, List.foldl, etc. Read"
694+ \ This way you never run into unexpected values partway through.\
716− "custom-types"
695+ \ To mix different types in a single list, create a \"union type\" as\
717− "to learn how to “mix” types."
696+ \ described in: <http://guide.elm-lang.org/types/union_types.html>"
718 ]
697 ]
719 )
698 )
720
699
@@ -761,7 +740,7 @@ toExprReport source localizer exprRegion category tipe expected =
761 , [ D.link "Hint"
740 , [ D.link "Hint"
762 "All branches in an `if` must produce the same type of values. This way, no\
741 "All branches in an `if` must produce the same type of values. This way, no\
763 \ matter which branch we take, the result is always a consistent shape. Read"
742 \ matter which branch we take, the result is always a consistent shape. Read"
764− "custom-types"
743+ "union-types"
765 "to learn how to “mix” types."
744 "to learn how to “mix” types."
766 ]
745 ]
767 )
746 )
@@ -776,7 +755,7 @@ toExprReport source localizer exprRegion category tipe expected =
776 , [ D.link "Hint"
755 , [ D.link "Hint"
777 "All branches in a `case` must produce the same type of values. This way, no\
756 "All branches in a `case` must produce the same type of values. This way, no\
778 \ matter which branch we take, the result is always a consistent shape. Read"
757 \ matter which branch we take, the result is always a consistent shape. Read"
779− "custom-types"
758+ "union-types"
780 "to learn how to “mix” types."
759 "to learn how to “mix” types."
781 ]
760 ]
782 )
761 )
@@ -1093,7 +1072,7 @@ opRightToDocs localizer category op tipe expected =
1093 ( D.reflow $ "I cannot send this through the (<|) pipe:"
1072 ( D.reflow $ "I cannot send this through the (<|) pipe:"
1094 , typeComparison localizer tipe expected
1073 , typeComparison localizer tipe expected
1095 "The argument is:"
1074 "The argument is:"
1096− "But (<|) is piping it to a function that expects:"
1075+ "But (<|) is piping it a function that expects:"
1097 []
1076 []
1098 )
1077 )
1099
1078
@@ -1104,7 +1083,7 @@ opRightToDocs localizer category op tipe expected =
1104 ( D.reflow $ "This function cannot handle the argument sent through the (|>) pipe:"
1083 ( D.reflow $ "This function cannot handle the argument sent through the (|>) pipe:"
1105 , typeComparison localizer argType expectedArgType
1084 , typeComparison localizer argType expectedArgType
1106 "The argument is:"
1085 "The argument is:"
1107− "But (|>) is piping it to a function that expects:"
1086+ "But (|>) is piping it a function that expects:"
1108 []
1087 []
1109 )
1088 )
1110
1089
compiler/src/Reporting/Render/Code.hs+26−67
@@ -7,8 +7,6 @@ module Reporting.Render.Code
7 , toPair
7 , toPair
8 , Next(..)
8 , Next(..)
9 , whatIsNext
9 , whatIsNext
10− , nextLineStartsWithKeyword
11− , nextLineStartsWithCloseCurly
12 )
10 )
13 where
11 where
14
12
@@ -122,7 +120,7 @@ makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end
122 spaces = replicate (fromIntegral c1 + width + 1) ' '
120 spaces = replicate (fromIntegral c1 + width + 1) ' '
123 zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^'
121 zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^'
124 in
122 in
125− Just (D.fromChars spaces <> D.red (D.fromChars zigzag))
123+ Just (D.fromChars spaces <> D.dullred (D.fromChars zigzag))
126
124
127
125
128drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc
126drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc
@@ -148,7 +146,7 @@ addLineNumber addZigZag width start end n line =
148
146
149 spacer =
147 spacer =
150 if addZigZag && start <= n && n <= end then
148 if addZigZag && start <= n && n <= end then
151− D.red ">"
149+ D.dullred ">"
152 else
150 else
153 " "
151 " "
154 in
152 in
@@ -183,8 +181,8 @@ renderPair source@(Source sourceLines) region1 region2 =
183 OneLine $
181 OneLine $
184 D.vcat
182 D.vcat
185 [ D.fromChars lineNumber <> "| " <> D.fromChars line
183 [ D.fromChars lineNumber <> "| " <> D.fromChars line
186− , D.fromChars spaces1 <> D.red (D.fromChars zigzag1) <>
184+ , D.fromChars spaces1 <> D.dullred (D.fromChars zigzag1) <>
187− D.fromChars spaces2 <> D.red (D.fromChars zigzag2)
185+ D.fromChars spaces2 <> D.dullred (D.fromChars zigzag2)
188 ]
186 ]
189
187
190 else
188 else
@@ -201,46 +199,35 @@ data Next
201 = Keyword [Char]
199 = Keyword [Char]
202 | Operator [Char]
200 | Operator [Char]
203 | Close [Char] Char
201 | Close [Char] Char
204− | Upper Char [Char]
205− | Lower Char [Char]
206− | Other (Maybe Char)
202+ | Other
207
203
208
204
209whatIsNext :: Source -> Row -> Col -> Next
205whatIsNext :: Source -> Row -> Col -> Next
210whatIsNext (Source sourceLines) row col =
206whatIsNext (Source sourceLines) row col =
211 case List.lookup row sourceLines of
207 case List.lookup row sourceLines of
212 Nothing ->
208 Nothing ->
213− Other Nothing
209+ Other
214
210
215 Just line ->
211 Just line ->
212+ let
216− case drop (fromIntegral col - 1) line of
213+ chars = drop (fromIntegral col - 1) line
217− [] ->
214+ keywords = map Name.toChars (Set.toList reservedWords)
215+ in
216+ case List.find (startsWithKeyword chars) keywords of
217+ Just keyword ->
218+ Keyword keyword
219+
218− Other Nothing
220+ Nothing ->
219−
221+ case chars of
220− c:cs
222+ [] ->
221− | Char.isUpper c -> Upper c (takeWhile isInner cs)
223+ Other
222− | Char.isLower c -> detectKeywords c cs
224+
225+ c:cs
223− | isSymbol c -> Operator (c : takeWhile isSymbol cs)
226+ | isSymbol c -> Operator (c : takeWhile isSymbol cs)
224− | c == ')' -> Close "parenthesis" ')'
227+ | c == ')' -> Close "parenthesis" ')'
225− | c == ']' -> Close "square bracket" ']'
228+ | c == ']' -> Close "square bracket" ']'
226− | c == '}' -> Close "curly brace" '}'
229+ | c == '}' -> Close "curly brace" '}'
227− | otherwise -> Other (Just c)
230+ | otherwise -> Other
228−
229−
230−detectKeywords :: Char -> [Char] -> Next
231−detectKeywords c rest =
232− let
233− cs = takeWhile isInner rest
234− name = c : cs
235− in
236− if Set.member (Name.fromChars name) reservedWords
237− then Keyword name
238− else Lower c name
239−
240−
241−isInner :: Char -> Bool
242−isInner char =
243− Char.isAlphaNum char || char == '_'
244
231
245
232
246isSymbol :: Char -> Bool
233isSymbol :: Char -> Bool
@@ -257,32 +244,4 @@ startsWithKeyword restOfLine keyword =
257 True
244 True
258
245
259 c:_ ->
246 c:_ ->
260− not (isInner c)
247+ not (Char.isAlphaNum c || c == '_')
261−
262−
263−nextLineStartsWithKeyword :: [Char] -> Source -> Row -> Maybe (Row, Col)
264−nextLineStartsWithKeyword keyword (Source sourceLines) row =
265− case List.lookup (row + 1) sourceLines of
266− Nothing ->
267− Nothing
268−
269− Just line ->
270− if startsWithKeyword (dropWhile (==' ') line) keyword then
271− Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line)))
272− else
273− Nothing
274−
275−
276−nextLineStartsWithCloseCurly :: Source -> Row -> Maybe (Row, Col)
277−nextLineStartsWithCloseCurly (Source sourceLines) row =
278− case List.lookup (row + 1) sourceLines of
279− Nothing ->
280− Nothing
281−
282− Just line ->
283− case dropWhile (==' ') line of
284− '}':_ ->
285− Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line)))
286−
287− _ ->
288− Nothing
compiler/src/Reporting/Render/Type/Localizer.hs+25−5
@@ -7,6 +7,8 @@ module Reporting.Render.Type.Localizer
7 , empty
7 , empty
8 , fromNames
8 , fromNames
9 , fromModule
9 , fromModule
10+ , replEmpty
11+ , replAdd
10 )
12 )
11 where
13 where
12
14
@@ -16,6 +18,7 @@ import qualified Data.Name as Name
16import qualified Data.Set as Set
18import qualified Data.Set as Set
17
19
18import qualified AST.Source as Src
20import qualified AST.Source as Src
21+import qualified Elm.Compiler.Imports as Imports
19import qualified Elm.ModuleName as ModuleName
22import qualified Elm.ModuleName as ModuleName
20import Reporting.Doc ((<>))
23import Reporting.Doc ((<>))
21import qualified Reporting.Doc as D
24import qualified Reporting.Doc as D
@@ -112,9 +115,26 @@ toExposing exposing =
112 Only (foldr addType Set.empty exposedList)
115 Only (foldr addType Set.empty exposedList)
113
116
114
117
115−addType :: Src.Exposed -> Set.Set Name.Name -> Set.Set Name.Name
118+addType :: A.Located Src.Exposed -> Set.Set Name.Name -> Set.Set Name.Name
116−addType exposed types =
119+addType (A.At _ exposed) types =
117 case exposed of
120 case exposed of
118− Src.Lower _ -> types
121+ Src.Lower _ -> types
119− Src.Upper (A.At _ name) _ -> Set.insert name types
122+ Src.Upper name _ -> Set.insert name types
120− Src.Operator _ _ -> types
123+ Src.Operator _ -> types
124+
125+
126+
127+-- REPL STUFF
128+
129+
130+replEmpty :: Localizer
131+replEmpty =
132+ Localizer $
133+ Map.insert Name.replModule (Import Nothing All) $
134+ Map.fromList $ map toPair Imports.defaults
135+
136+
137+replAdd :: Name.Name -> Maybe Name.Name -> Src.Exposing -> Localizer -> Localizer
138+replAdd name alias exposing (Localizer localizer) =
139+ Localizer $ Map.insert name (Import alias (toExposing exposing)) localizer
140+
compiler/src/Reporting/Result.hs+1−9
@@ -118,12 +118,4 @@ instance Monad (Result i w e) where
118 in
118 in
119 ka i w bad good1
119 ka i w bad good1
120
120
121− (>>) (Result ka) (Result kb) =
121+ -- TODO PERF add more specialized definitions?
122− Result $ \i w bad good ->
123− let
124− good1 i1 w1 _ =
125− kb i1 w1 bad good
126− in
127− ka i w bad good1
128−
129− -- PERF add INLINE to these?
compiler/src/Type/Error.hs+123−14
@@ -175,7 +175,9 @@ data Problem
175 | StringToFloat
175 | StringToFloat
176 | AnythingToBool
176 | AnythingToBool
177 | AnythingFromMaybe
177 | AnythingFromMaybe
178− | ArityMismatch Int Int
178+ | AnythingToList
179+ | MissingArgs Int
180+ | ReturnMismatch
179 | BadFlexSuper Direction Super Name.Name Type
181 | BadFlexSuper Direction Super Name.Name Type
180 | BadRigidVar Name.Name Type
182 | BadRigidVar Name.Name Type
181 | BadRigidSuper Super Name.Name Type
183 | BadRigidSuper Super Name.Name Type
@@ -253,11 +255,7 @@ toDiff localizer ctx tipe1 tipe2 =
253 <*> toDiff localizer RT.Func b y
255 <*> toDiff localizer RT.Func b y
254 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
256 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
255 else
257 else
256− let f = toDoc localizer RT.Func in
258+ diffLambda localizer ctx a b cs x y zs
257− different
258− (D.dullyellow (RT.lambda ctx (f a) (f b) (map f cs)))
259− (D.dullyellow (RT.lambda ctx (f x) (f y) (map f zs)))
260− (Bag.one (ArityMismatch (2 + length cs) (2 + length zs)))
261
259
262 (Tuple a b Nothing, Tuple x y Nothing) ->
260 (Tuple a b Nothing, Tuple x y Nothing) ->
263 RT.tuple
261 RT.tuple
@@ -300,7 +298,7 @@ toDiff localizer ctx tipe1 tipe2 =
300 different
298 different
301 (toDoc localizer ctx t1)
299 (toDoc localizer ctx t1)
302 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
300 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
303− Bag.empty
301+ (Bag.one AnythingToList)
304
302
305 (Alias home1 name1 args1 t1, t2) ->
303 (Alias home1 name1 args1 t1, t2) ->
306 case diffAliasedRecord localizer t1 t2 of
304 case diffAliasedRecord localizer t1 t2 of
@@ -449,13 +447,6 @@ isSuper super tipe =
449 Appendable -> isString h n || isList h n
447 Appendable -> isString h n || isList h n
450 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
448 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
451
449
452− Tuple a b maybeC ->
453− case super of
454− Number -> False
455− Comparable -> isSuper super a && isSuper super b && maybe True (isSuper super) maybeC
456− Appendable -> False
457− CompAppend -> False
458−
459 _ ->
450 _ ->
460 False
451 False
461
452
@@ -486,6 +477,124 @@ diffAliasedRecord localizer t1 t2 =
486
477
487
478
488
479
480+-- DIFF LAMBDAS
481+
482+
483+--
484+-- INVARIANTS:
485+-- length cs1 /= length cs2
486+--
487+diffLambda :: L.Localizer -> RT.Context -> Type -> Type -> [Type] -> Type -> Type -> [Type] -> Diff D.Doc
488+diffLambda localizer ctx a1 b1 cs1 a2 b2 cs2 =
489+ let
490+ (result1:revArgs1) = reverse (a1:b1:cs1)
491+ (result2:revArgs2) = reverse (a2:b2:cs2)
492+
493+ numArgs1 = length revArgs1
494+ numArgs2 = length revArgs2
495+ in
496+ case toDiff localizer RT.Func result1 result2 of
497+ Diff resultDoc1 resultDoc2 Similar ->
498+ if numArgs1 < numArgs2 then
499+ diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2
500+
501+ else
502+ diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1
503+
504+ Diff resultDoc1 resultDoc2 (Different problems) ->
505+ let
506+ (a:b:cs) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)
507+ (x:y:zs) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)
508+ in
509+ different
510+ (D.dullyellow (RT.lambda ctx a b cs))
511+ (D.dullyellow (RT.lambda ctx x y zs))
512+ (Bag.append problems (Bag.one ReturnMismatch))
513+
514+
515+--
516+-- INVARIANTS:
517+-- length shortRevArgs >= 2
518+-- length longRevArgs >= 2
519+-- length shortRevArgs < length longRevArgs
520+--
521+diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc
522+diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
523+ let
524+ (a:b:cs, x:y:zs) =
525+ case toGreedyMatch localizer shortRevArgs longRevArgs of
526+ Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
527+ ( reverse (shortResult:shortRevArgDocs)
528+ , reverse (longResult:longRevArgDocs)
529+ )
530+
531+ Nothing ->
532+ case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of
533+ Just (GreedyMatch shortArgDocs longArgDocs) ->
534+ ( shortArgDocs ++ [shortResult]
535+ , longArgDocs ++ [longResult]
536+ )
537+
538+ Nothing ->
539+ let
540+ toYellowDoc tipe =
541+ D.dullyellow (toDoc localizer RT.Func tipe)
542+ in
543+ ( reverse (shortResult : map toYellowDoc shortRevArgs)
544+ , reverse (longResult : map toYellowDoc longRevArgs )
545+ )
546+ in
547+ different
548+ (RT.lambda ctx a b cs)
549+ (RT.lambda ctx x y zs)
550+ (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
551+
552+
553+
554+-- GREEDY ARG MATCHER
555+
556+
557+data GreedyMatch =
558+ GreedyMatch [D.Doc] [D.Doc]
559+
560+
561+--
562+-- INVARIANTS:
563+-- length shorterArgs < length longerArgs
564+--
565+toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
566+toGreedyMatch localizer shorterArgs longerArgs =
567+ toGreedyMatchHelp localizer shorterArgs longerArgs (GreedyMatch [] [])
568+
569+
570+toGreedyMatchHelp :: L.Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
571+toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
572+ let
573+ toYellowDoc tipe =
574+ D.dullyellow (toDoc localizer RT.Func tipe)
575+ in
576+ case (shorterArgs, longerArgs) of
577+ (x:xs, y:ys) ->
578+ case toDiff localizer RT.Func x y of
579+ Diff a b Similar ->
580+ toGreedyMatchHelp localizer xs ys $
581+ GreedyMatch (a:shorterDocs) (b:longerDocs)
582+
583+ Diff _ _ (Different _) ->
584+ toGreedyMatchHelp localizer shorterArgs ys $
585+ GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
586+
587+ ([], []) ->
588+ Just match
589+
590+ ([], _:_) ->
591+ Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
592+
593+ (_:_, []) ->
594+ Nothing
595+
596+
597+
489-- RECORD DIFFS
598-- RECORD DIFFS
490
599
491
600
compiler/src/Type/Solve.hs−7
@@ -427,13 +427,6 @@ typeToVariable rank pools tipe =
427 typeToVar rank pools Map.empty tipe
427 typeToVar rank pools Map.empty tipe
428
428
429
429
430−-- PERF working with @mgriffith we noticed that a 784 line entry in a `let` was
431−-- causing a ~1.5 second slowdown. Moving it to the top-level to be a function
432−-- saved all that time. The slowdown seems to manifest in `typeToVar` and in
433−-- `register` in particular. Have not explored further yet. Top-level definitions
434−-- are recommended in cases like this anyway, so there is at least a safety
435−-- valve for now.
436−--
437typeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Type -> IO Variable
430typeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Type -> IO Variable
438typeToVar rank pools aliasDict tipe =
431typeToVar rank pools aliasDict tipe =
439 let go = typeToVar rank pools aliasDict in
432 let go = typeToVar rank pools aliasDict in
compiler/src/Type/Unify.hs+11−5
@@ -90,6 +90,7 @@ instance Applicative Unify where
90
90
91
91
92instance Monad Unify where
92instance Monad Unify where
93+ -- TODO PERF add INLINE here?
93 return a =
94 return a =
94 Unify $ \vars ok _ ->
95 Unify $ \vars ok _ ->
95 ok vars a
96 ok vars a
@@ -219,6 +220,8 @@ unifyFlex context content otherContent =
219 Error ->
220 Error ->
220 merge context Error
221 merge context Error
221
222
223+ -- TODO see if wildcarding makes a noticable perf difference
224+
222 FlexVar maybeName ->
225 FlexVar maybeName ->
223 merge context $
226 merge context $
224 case maybeName of
227 case maybeName of
@@ -391,13 +394,13 @@ unifyFlexSuperStructure context super flatType =
391
394
392 Comparable ->
395 Comparable ->
393 do comparableOccursCheck context
396 do comparableOccursCheck context
394− unifyComparableRecursive variable
395 merge context (Structure flatType)
397 merge context (Structure flatType)
398+ unifyComparableRecursive variable
396
399
397 CompAppend ->
400 CompAppend ->
398 do comparableOccursCheck context
401 do comparableOccursCheck context
399− unifyComparableRecursive variable
400 merge context (Structure flatType)
402 merge context (Structure flatType)
403+ unifyComparableRecursive variable
401
404
402 Tuple1 a b maybeC ->
405 Tuple1 a b maybeC ->
403 case super of
406 case super of
@@ -409,12 +412,15 @@ unifyFlexSuperStructure context super flatType =
409
412
410 Comparable ->
413 Comparable ->
411 do comparableOccursCheck context
414 do comparableOccursCheck context
415+ merge context (Structure flatType)
412 unifyComparableRecursive a
416 unifyComparableRecursive a
413 unifyComparableRecursive b
417 unifyComparableRecursive b
414 case maybeC of
418 case maybeC of
415− Nothing -> return ()
419+ Nothing ->
420+ return ()
421+
422+ Just c ->
416− Just c -> unifyComparableRecursive c
423+ unifyComparableRecursive c
417− merge context (Structure flatType)
418
424
419 CompAppend ->
425 CompAppend ->
420 mismatch
426 mismatch
docs/elm.json/application.md+2−2
@@ -8,7 +8,7 @@ This is a decent baseline for pretty much any applications made with Elm. You wi
8 "source-directories": [
8 "source-directories": [
9 "src"
9 "src"
10 ],
10 ],
11− "elm-version": "0.19.1",
11+ "elm-version": "0.19.0",
12 "dependencies": {
12 "dependencies": {
13 "direct": {
13 "direct": {
14 "elm/browser": "1.0.0",
14 "elm/browser": "1.0.0",
@@ -48,7 +48,7 @@ A list of directories where Elm code lives. Most projects just use `"src"` for e
48
48
49## `"elm-version"`
49## `"elm-version"`
50
50
51−The exact version of Elm this builds with. Should be `"0.19.1"` for most people!
51+The exact version of Elm this builds with. Should be `"0.19.0"` for most people!
52
52
53<br>
53<br>
54
54
docs/elm.json/package.md+1−1
@@ -49,7 +49,7 @@ A short summary that will appear on [`package.elm-lang.org`](https://package.elm
49
49
50## `"license"`
50## `"license"`
51
51
52−An OSI approved SPDX code like `"BSD-3-Clause"` or `"MIT"`. These are the two most common licenses in the Elm ecosystem, and BSD-3-Clause is a good default. But you can see the full list of options [here](https://spdx.org/licenses/).
52+An OSI approved SPDX code like `"BSD-3-Clause"` or `"MIT"`. These are the two most common licenses in the Elm ecosystem, but you can see the full list of options [here](https://spdx.org/licenses/).
53
53
54<br>
54<br>
55
55
docs/upgrade-instructions/0.19.1.mddeleted−60
@@ -1,60 +0,0 @@
1−# Upgrading to 0.19.1
2−
3−**There are no language changes**, so once you swap to `"elm-version": "0.19.1"` in your `elm.json`, most users should be able to proceed without any further code changes. **You may run into a handful of bugfixes though!** These cases are outlined below!
4−
5−
6−<br>
7−
8−## Improvements
9−
10−- Parse error message quality (like [this](https://github.com/elm/error-message-catalog/issues/255) and [this](https://github.com/elm/error-message-catalog/issues/225))
11−- Faster compilation, especially for incremental compiles
12−- Uses filelocks so that cached files are not corrupted when plugins run `elm make` multiple times on the same project at the same time. (Still worth avoiding that though!)
13−- More intuitive multiline declarations in REPL
14−- Various bug fixes (e.g. `--debug`, `x /= 0`, `type Height = Height Float` in `--optimize`)
15−
16−
17−<br>
18−
19−## Detectable Bug Fixes
20−
21−There are three known cases where code that compiled with 0.19.0 will not compile with 0.19.1 due to bug fixes:
22−
23−
24−### 1. Ambiguous Imports
25−
26−Say you have an import like this:
27−
28−```elm
29−import Html exposing (min)
30−import Regex exposing (never)
31−
32−x = min
33−y = never
34−```
35−
36−These should be reported as ambiguous usages since the names are also exposed by `Basics`, but there was a regression in 0.19.0 described [here](https://github.com/elm/compiler/issues/1945) such that they weren't caught in specific circumstances.
37−
38−The fix is to use a qualified name like `Html.min` or `Regex.never` to make it unambiguous.
39−
40−We found a couple instances of this in packages and have submitted PRs to the relevant authors in August 2019. You may run into this in your own code as well.
41−
42−For more details on why this is considered a regression, check out the details [here](https://github.com/elm/compiler/issues/1945#issuecomment-507871919) or try it in 0.18.0 to see how it worked before.
43−
44−
45−### 2. Tabs in Comments
46−
47−The 0.19.0 binaries did not catch tab characters in comments. The new parser is better at checking for tabs, so it will object when it finds these.
48−
49−Again, we found this in some packages and reached out to the relevant authors with PRs so patches would be published before the 0.19.1 release.
50−
51−
52−### 3. Port Module with no Ports
53−
54−If you have any files that start with:
55−
56−```elm
57−port module Main exposing (..)
58−```
59−
60−But they do not actually have any `port` declarations, the 0.19.1 binary will ask you to switch to a normal module declaration like `module Main exposing (..)`
elm.cabal+11−25
@@ -38,14 +38,11 @@ Executable elm
38 if flag(dev)
38 if flag(dev)
39 ghc-options: -O0 -Wall -Werror
39 ghc-options: -O0 -Wall -Werror
40 else
40 else
41− ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg -A128m"
41+ ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg"
42− -- add -eventlog for (elm make src/Main.elm +RTS -l; threadscope elm.eventlog)
43− -- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/
44
42
45 Hs-Source-Dirs:
43 Hs-Source-Dirs:
46 compiler/src
44 compiler/src
47 builder/src
45 builder/src
48− terminal/impl
49 terminal/src
46 terminal/src
50
47
51 other-extensions:
48 other-extensions:
@@ -55,38 +52,26 @@ Executable elm
55 Main.hs
52 Main.hs
56
53
57 other-modules:
54 other-modules:
58− Bump
59− Develop
55+ Develop.StaticFiles
60− Diff
56+ Develop.StaticFiles.Build
61 Init
57 Init
62 Install
58 Install
63 Make
59 Make
64− Publish
65− Repl
66
60
67 -- terminal args
61 -- terminal args
68− Terminal
62+ Terminal.Args
69− Terminal.Chomp
63+ Terminal.Args.Chomp
70− Terminal.Error
64+ Terminal.Args.Error
71− Terminal.Helpers
65+ Terminal.Args.Helpers
72− Terminal.Internal
66+ Terminal.Args.Internal
73−
74− -- from terminal/
75− Develop.Generate.Help
76− Develop.Generate.Index
77− Develop.StaticFiles
78− Develop.StaticFiles.Build
79
67
80 -- from builder/
68 -- from builder/
81 Build
69 Build
82− BackgroundWriter
83− Deps.Bump
84− Deps.Diff
85 Deps.Registry
70 Deps.Registry
71+ Deps.Diff
86 Deps.Solver
72 Deps.Solver
87 Deps.Website
73 Deps.Website
88 File
74 File
89− Generate
90 Http
75 Http
91 Reporting
76 Reporting
92 Reporting.Exit
77 Reporting.Exit
@@ -165,6 +150,7 @@ Executable elm
165 Parse.Module
150 Parse.Module
166 Parse.Number
151 Parse.Number
167 Parse.Pattern
152 Parse.Pattern
153+ Parse.Repl
168 Parse.Shader
154 Parse.Shader
169 Parse.Space
155 Parse.Space
170 Parse.String
156 Parse.String
@@ -231,7 +217,7 @@ Executable elm
231 snap-core,
217 snap-core,
232 snap-server,
218 snap-server,
233 template-haskell,
219 template-haskell,
234− time >= 1.9.1,
220+ time,
235 unordered-containers,
221 unordered-containers,
236 utf8-string,
222 utf8-string,
237 vector,
223 vector,
hints/bad-recursion.mddeleted−133
@@ -1,133 +0,0 @@
1−
2−# Hints for Bad Recursion
3−
4−There are two problems that will lead you here, both of them pretty tricky:
5−
6− 1. [**No Mutation**](#no-mutation) &mdash; Defining values in Elm is slightly different than defining values in languages like JavaScript.
7−
8− 2. [**Tricky Recursion**](#tricky-recursion) &mdash; Sometimes you need to define recursive values when creating generators, decoders, and parsers. A common case is a JSON decoder a discussion forums where a comment may have replies, which may have replies, which may have replies, etc.
9−
10−
11−## No Mutation
12−
13−Languages like JavaScript let you “reassign” variables. When you say `x = x + 1` it means: whatever `x` was pointing to, have it point to `x + 1` instead. This is called *mutating* a variable. All values are immutable in Elm, so reassigning variables does not make any sense! Okay, so what *should* `x = x + 1` mean in Elm?
14−
15−Well, what does it mean with functions? In Elm, we write recursive functions like this:
16−
17−```elm
18−factorial : Int -> Int
19−factorial n =
20− if n <= 0 then 1 else n * factorial (n - 1)
21−```
22−
23−One cool thing about Elm is that whenever you see `factorial 3`, you can always replace that expression with `if 3 <= 0 then 1 else 3 * factorial (3 - 1)` and it will work exactly the same. So when Elm code gets evaluated, we will keep expanding `factorial` until the `if` produces a 1. At that point, we are done expanding and move on.
24−
25−The thing that surprises newcomers is that recursion works the same way with values too. So take the following definition:
26−
27−```elm
28−x = x + 1
29−```
30−
31−We are actually defining `x` in terms of itself. So it would expand out to `x = ... + 1 + 1 + 1 + 1`, trying to add one to `x` an infinite number of times! This means your program would just run forever, endlessly expanding `x`. In practice, this means the page freezes and the computer starts to get kind of warm. No good! We can detect cases like this with the compiler, so we give an error at compile time so this does not happen in the wild.
32−
33−The fix is usually to just give the new value a new name. So you could rewrite it to:
34−
35−```elm
36−x1 = x + 1
37−```
38−
39−Now `x` is the old value and `x1` is the new value. Again, one cool thing about Elm is that whenever you see a `factorial 3` you can safely replace it with its definition. Well, the same is true of values. Wherever I see `x1`, I can replace it with `x + 1`. Thanks to the way definitions work in Elm, this is always safe!
40−
41−
42−## Tricky Recursion
43−
44−Now, there are some cases where you *do* want a recursive value. Say you are building a website with comments and replies. You may define a comment like this:
45−
46−```elm
47−type alias Comment =
48− { message : String
49− , upvotes : Int
50− , downvotes : Int
51− , responses : Responses
52− }
53−
54−type Responses =
55− Responses (List Comment)
56−```
57−
58−You may have run into this definition in the [hints for recursive aliases](recursive-alias.md)! Anyway, once you have comments, you may want to turn them into JSON to send back to your server or to store in your database or whatever. So you will probably write some code like this:
59−
60−```elm
61−import Json.Decode as Decode exposing (Decoder)
62−
63−decodeComment : Decoder Comment
64−decodeComment =
65− Decode.map4 Comment
66− (Decode.field "message" Decode.string)
67− (Decode.field "upvotes" Decode.int)
68− (Decode.field "downvotes" Decode.int)
69− (Decode.field "responses" decodeResponses)
70−
71−-- PROBLEM
72−decodeResponses : Decoder Responses
73−decodeResponses =
74− Decode.map Responses (Decode.list decodeComment)
75−```
76−
77−The problem is that now `decodeComment` is defined in terms of itself! To know what `decodeComment` is, I need to expand `decodeResponses`. To know what `decodeResponses` is, I need to expand `decodeComment`. This loop will repeat endlessly!
78−
79−In this case, the trick is to use `Json.Decode.lazy` which delays the evaluation of a decoder until it is needed. So the valid definition would look like this:
80−
81−```elm
82−import Json.Decode as Decode exposing (Decoder)
83−
84−decodeComment : Decoder Comment
85−decodeComment =
86− Decode.map4 Comment
87− (Decode.field "message" Decode.string)
88− (Decode.field "upvotes" Decode.int)
89− (Decode.field "downvotes" Decode.int)
90− (Decode.field "responses" decodeResponses)
91−
92−-- SOLUTION
93−decodeResponses : Decoder Responses
94−decodeResponses =
95− Decode.map Responses (Decode.list (Decode.lazy (\_ -> decodeComment)))
96−```
97−
98−Notice that in `decodeResponses`, we hide `decodeComment` behind an anonymous function. Elm cannot evaluate an anonymous function until it is given arguments, so it allows us to delay evaluation until it is needed. If there are no comments, we will not need to expand it!
99−
100−This saves us from expanding the value infinitely. Instead we only expand the value if we need to.
101−
102−> **Note:** The same kind of logic can be applied to tasks, random value generators, and parsers. Use `lazy` or `andThen` to make sure a recursive value is only expanded if needed.
103−
104−
105−## Understanding “Bad Recursion”
106−
107−The compiler tries to detect bad recursion, but how does it know the difference between good and bad situations? Writing `factorial` is fine, but writing `x = x + 1` is not. One version of `decodeComment` was bad, but the other was fine. What is the rule?
108−
109−**Elm will allow recursive definitions as long as there is at least one lambda before you get back to yourself.** So if we write `factorial` without any pretty syntax, it looks like this:
110−
111−```elm
112−factorial =
113− \n -> if n <= 0 then 1 else n * factorial (n - 1)
114−```
115−
116−There is technically a lambda between the definition and the use, so it is okay! The same is true with the good version of `decodeComment`. There is a lambda between the definition and the use. As long as there is a lambda before you get back to yourself, the compiler will let it through.
117−
118−**This rule is nice, but it does not catch everything.** It is pretty easy to write a definition where the recursion is hidden behind a lambda, but it still immediately expands forever:
119−
120−```elm
121−x =
122− (\_ -> x) () + 1
123−```
124−
125−This follows the rules, but it immediately expands until our program runs out of stack space. It leads to a runtime error as soon as you start your program. It is nice to fail fast, but why not have the compiler detect this as well? It turns out this is much harder than it sounds!
126−
127−This is called [the halting problem](https://en.wikipedia.org/wiki/Halting_problem) in computer science. Computational theorists were asking:
128−
129−> Can we determine if a program will finish running (i.e. halt) or if it will continue to run forever?
130−
131−It turns out that Alan Turing wrote a proof in 1936 showing that (1) in some cases you just have to check by running the program and (2) this check will take forever for programs that do not halt!
132−
133−**So we cannot solve the halting problem *in general*, but our simple rule about lambdas can detect the majority of bad cases *in practice*.**
hints/comparing-custom-types.mddeleted−98
@@ -1,98 +0,0 @@
1−# Comparing Custom Types
2−
3−The built-in comparison operators work on a fixed set of types, like `Int` and `String`. That covers a lot of cases, but what happens when you want to compare custom types?
4−
5−This page aims to catalog these scenarios and offer alternative paths that can get you unstuck.
6−
7−
8−## Wrapped Types
9−
10−It is common to try to get some extra type safety by creating really simple custom types:
11−
12−```elm
13−type Id = Id Int
14−type Age = Age Int
15−
16−type Comment = Comment String
17−type Description = Description String
18−```
19−
20−By wrapping the primitive values like this, the type system can now help you make sure that you never mix up a `Id` and an `Age`. Those are different types! This trick is extra cool because it has no runtime cost in `--optimize` mode. The compiler can just use an `Int` or `String` directly when you use that flag!
21−
22−The problem arises when you want to use a `Id` as a key in a dictionary. This is a totally reasonable thing to do, but the current version of Elm cannot handle this scenario.
23−
24−Instead of creating a `Dict Id Info` type, one thing you can do is create a custom data structure like this:
25−
26−```elm
27−module User exposing (Id, Table, empty, get, add)
28−
29−import Dict exposing (Dict)
30−
31−
32−-- USER
33−
34−type Id = Id Int
35−
36−
37−-- TABLE
38−
39−type Table info =
40− Table Int (Dict Int info)
41−
42−empty : Table info
43−empty =
44− Table 0 Dict.empty
45−
46−get : Id -> Table info -> Maybe info
47−get (Id id) (Table _ dict) =
48− Dict.get id dict
49−
50−add : info -> Table info -> (Table info, Id)
51−add info (Table nextId dict) =
52− ( Table (nextId + 1) (Dict.insert nextId info dict)
53− , Id nextId
54− )
55−```
56−
57−There are a couple nice things about this approach:
58−
59−1. The only way to get a new `User.Id` is to `add` information to a `User.Table`.
60−2. All the operations on a `User.Table` are explicit. Does it make sense to remove users? To merge two tables together? Are there any special details to consider in those cases? This will always be captured explicitly in the interface of the `User` module.
61−3. If you ever want to switch the internal representation from `Dict` to `Array` or something else, it is no problem. All the changes will be within the `User` module.
62−
63−So while this approach is not as convenient as using a `Dict` directly, it has some benefits of its own that can be helpful in some cases.
64−
65−
66−## Enumerations to Ints
67−
68−Say you need to define a `trafficLightToInt` function:
69−
70−```elm
71−type TrafficLight = Green | Yellow | Red
72−
73−trafficLightToInt : TrafficLight -> Int
74−trafficLightToInt trafficLight =
75− ???
76−```
77−
78−We have heard that some people would prefer to use a dictionary for this sort of thing. That way you do not need to write the numbers yourself, they can be generated such that you never have a typo.
79−
80−I would recommend using a `case` expression though:
81−
82−```elm
83−type TrafficLight = Green | Yellow | Red
84−
85−trafficLightToInt : TrafficLight -> Int
86−trafficLightToInt trafficLight =
87− case trafficLight of
88− Green -> 1
89− Yellow -> 2
90− Red -> 3
91−```
92−
93−This is really straight-forward while avoiding questions like “is `Green` less than or greater than `Red`?”
94−
95−
96−## Something else?
97−
98−If you have some other situation, please tell us about it [here](https://github.com/elm/error-message-catalog/issues). That is a log of error messages that can be improved, and we can use the particulars of your scenario to add more advice on this page!
hints/comparing-records.mddeleted−85
@@ -1,85 +0,0 @@
1−# Comparing Records
2−
3−The built-in comparison operators work on a fixed set of types, like `Int` and `String`. That covers a lot of cases, but what happens when you want to compare records?
4−
5−This page aims to catalog these scenarios and offer alternative paths that can get you unstuck.
6−
7−
8−## Sorting Records
9−
10−Say we want a `view` function that can show a list of students sorted by different characteristics.
11−
12−We could create something like this:
13−
14−```elm
15−import Html exposing (..)
16−
17−type alias Student =
18− { name : String
19− , age : Int
20− , gpa : Float
21− }
22−
23−type Order = Name | Age | GPA
24−
25−viewStudents : Order -> List Student -> Html msg
26−viewStudents order students =
27− let
28− orderlyStudents =
29− case order of
30− Name -> List.sortBy .name students
31− Age -> List.sortBy .age students
32− GPA -> List.sortBy .gpa students
33− in
34− ul [] (List.map viewStudent orderlyStudents)
35−
36−viewStudent : Student -> Html msg
37−viewStudent student =
38− li [] [ text student.name ]
39−```
40−
41−If you are worried about the performance of changing the order or updating information about particular students, you can start using the [`Html.Lazy`](https://package.elm-lang.org/packages/elm/html/latest/Html-Lazy) and [`Html.Keyed`](https://package.elm-lang.org/packages/elm/html/latest/Html-Keyed) modules. The updated code would look something like this:
42−
43−```elm
44−import Html exposing (..)
45−import Html.Lazy exposing (lazy)
46−import Html.Keyed as Keyed
47−
48−type Order = Name | Age | GPA
49−
50−type alias Student =
51− { name : String
52− , age : Int
53− , gpa : Float
54− }
55−
56−viewStudents : Order -> List Student -> Html msg
57−viewStudents order students =
58− let
59− orderlyStudents =
60− case order of
61− Name -> List.sortBy .name students
62− Age -> List.sortBy .age students
63− GPA -> List.sortBy .gpa students
64− in
65− Keyed.ul [] (List.map viewKeyedStudent orderlyStudents)
66−
67−viewKeyedStudent : Student -> (String, Html msg)
68−viewKeyedStudent student =
69− ( student.name, lazy viewStudent student )
70−
71−viewStudent : Student -> Html msg
72−viewStudent student =
73− li [] [ text student.name ]
74−```
75−
76−By using `Keyed.ul` we help the renderer move the DOM nodes around based on their key. This makes it much cheaper to reorder a bunch of students. And by using `lazy` we help the renderer skip a bunch of work. If the `Student` is the same as last time, the render can skip over it.
77−
78−> **Note:** Some people are skeptical of having logic like this in `view` functions, but I think the alternative (maintaining sort order in your `Model`) has some serious downsides. Say a colleague is adding a message to `Add` students, but they do not know about the sort order rules needed for presentation. Bug! So in this alternate design, you must diligently test your `update` function to make sure that no message disturbs the sort order. This is bound to lead to bugs over time!
79−>
80−> With all the optimizations possible with `Html.Lazy` and `Html.Keyed`, I would always be inclined to work on optimizing my `view` functions rather than making my `update` functions more complicated and error prone.
81−
82−
83−## Something else?
84−
85−If you have some other situation, please tell us about it [here](https://github.com/elm/error-message-catalog/issues). That is a log of error messages that can be improved, and we can use the particulars of your scenario to add more advice on this page!
hints/implicit-casts.mddeleted−50
@@ -1,50 +0,0 @@
1−
2−# Implicit Casts
3−
4−Many languages automatically convert from `Int` to `Float` when they think it is necessary. This conversion is often called an [implicit cast](https://en.wikipedia.org/wiki/Type_conversion).
5−
6−Languages that will add in implicit casts for addition include:
7−
8− - JavaScript
9− - Python
10− - Ruby
11− - C
12− - C++
13− - C#
14− - Java
15− - Scala
16−
17−These languages generally agree that an `Int` may be implicitly cast to a `Float` when necessary. So everyone is doing it, why not Elm?!
18−
19−## Type Inference + Implicit Casts
20−
21−Elm comes from the ML-family of languages. Languages in the ML-family that **never** do implicit casts include:
22−
23− - Standard ML
24− - OCaml
25− - Elm
26− - F#
27− - Haskell
28−
29−Why would so many languages from this lineage require explicit conversions though?
30−
31−Well, we have to go back to the 1970s for some background. J. Roger Hindley and Robin Milner independently discovered an algorithm that could _efficiently_ figure out the type of everything in your program without any type annotations. Type Inference! Every ML-family language has some variation of this algorithm at the center of its design.
32−
33−For decades, the problem was that nobody could figure out how to combine type inference with implicit casts AND make the resulting algorithm efficient enough for daily use. As far as I know, Scala was the first widely known language to figure out how to combine these two things! Its creator, Martin Odersky did a lot of work on combining type inference and subtyping to make this possible.
34−
35−So for any ML-family language designed before Scala, it is safe to assume that implicit conversions just was not an option. Okay, but what about Elm?! It comes after Scala, so why not do it like them?!
36−
37− 1. You pay performance cost to mix type inference and implicit conversions. At least as far as anyone knows, it defeats an optimization that is crucial to getting _reliably_ good performance. It is fine in most cases, but it can be a real issue in very large code bases.
38−
39− 2. Based on experience reports from Scala users, it seemed like the convenience was not worth the hidden cost. Yes, you can convert `n` in `(n + 1.5)` and everything is nice, but when you are in larger programs that are sparsely annotated, it can be quite difficult to figure out what is going on.
40−
41−This user data may be confounded by the fact that Scala allows quite extensive conversions, not just from `Int` to `Float`, but I think it is worth taking seriously nonetheless. So it is _possible_, but it has tradeoffs.
42−
43−
44−## Conclusion
45−
46−First, based on the landscape of design possibilities, it seems like requiring _explicit_ conversions is a pretty nice balance. We can have type inference, it can produce friendly error messages, the algorithm is snappy, and an unintended implicit cast will not flow hundreds of lines before manifesting to the user.
47−
48−Second, Elm very much favors explicit code, so this also fits in with the overall spirit of the language and libraries.
49−
50−I hope that clarifies why you have to add those `toFloat` and `round` functions! It definitely can take some getting used to, but there are tons of folks who get past that acclimation period and really love the tradeoffs!
hints/import-cycles.mddeleted−184
@@ -1,184 +0,0 @@
1−
2−# Import Cycles
3−
4−What is an import cycle? In practice you may see it if you create two modules with interrelated `User` and `Comment` types like this:
5−
6−```elm
7−module Comment exposing (..)
8−
9−import User
10−
11−type alias Comment =
12− { comment : String
13− , author : User.User
14− }
15−```
16−
17−```elm
18−module User exposing (..)
19−
20−import Comment
21−
22−type alias User =
23− { name : String
24− , comments : List Comment.Comment
25− }
26−```
27−
28−Notice that to compile `Comment` we need to `import User`. And notice that to compile `User` we need to `import Comment`. We need both to compile either!
29−
30−Now this is *possible* if the compiler figures out any module cycles and puts them all in one big file to compile them together. That seems fine in our small example, but imagine we have a cycle of 20 modules. If you change *one* of them, you must now recompile *all* of them. In a large code base, this causes extremely long compile times. It is also very hard to disentangle them in practice, so you just end up with slow builds. That is your life now.
31−
32−The thing is that you can always write the code *without* cycles by shuffling declarations around, and the resulting code is often much clearer.
33−
34−
35−# How to Break Cycles
36−
37−There are quite a few ways to break our `Comment` and `User` cycle from above, so let’s go through four useful strategies. The first one is by far the most common solution!
38−
39−
40−## 1. Combine the Modules
41−
42−One approach is to just combine the two modules. If we check out the resulting code, we have actually revealed a problem in how we are representing our data:
43−
44−```elm
45−module BadCombination1 exposing (..)
46−
47−type alias Comment =
48− { comment : String
49− , author : User
50− }
51−
52−type alias User =
53− { name : String
54− , comments : List Comment
55− }
56−```
57−
58−Notice that the `Comment` type alias is defined in terms of the `User` type alias and vice versa. Having recursive type aliases like this does not work! That problem is described in depth [here](recursive-alias.md), but the quick takeaway is that one `type alias` needs to become a `type` to break the recursion. So let’s try again:
59−
60−```elm
61−module BadCombination2 exposing (..)
62−
63−type alias Comment =
64− { comment : String
65− , author : User
66− }
67−
68−type alias User =
69− { name : String
70− , comments : AllUserComments
71− }
72−
73−type AllUserComments = AllUserComments (List Comment)
74−```
75−
76−Okay, now we have broken the recursion, but we need to ask ourselves, how are we going to actually instantiate these `Comment` and `User` types that we have described. A `Comment` will always have an author, and that `User` will always refer back to the `Comment`. So we seem to want cyclic data here. If we were in JavaScript we might instantiate all the comments in one pass, and then go back through and mutate the users to point to all the relevant comments. In other words, we need *mutation* to create this cyclic data!
77−
78−All values are immutable in Elm, so we need to use a more functional strategy. One common approach is to use unique identifiers. Instead of referring directly to “the user object” we can refer to a user ID:
79−
80−```elm
81−module GoodCombination exposing (..)
82−
83−import Dict
84−
85−type alias Comment =
86− { comment : String
87− , author : UserId
88− }
89−
90−type alias UserId = String
91−
92−type alias AllComments =
93− Dict.Dict UserId (List Comment)
94−```
95−
96−Now in this world, we do not even have cycles in our types anymore! That means we can actually break these out into separate modules again:
97−
98−```elm
99−module Comment exposing (..)
100−
101−import Dict
102−import User
103−
104−type alias Comment =
105− { comment : String
106− , author : User.Id
107− }
108−
109−type alias AllComments =
110− Dict.Dict User.Id (List Comment)
111−```
112−
113−```elm
114−module User exposing (..)
115−
116−type alias Id = String
117−```
118−
119−So now we are back to the two modules we wanted, but we have data structures that are going to work much better in a functional language like Elm! **This is the common approach, and it is what you hope will happen!**
120−
121−
122−## 2. Make a New Module
123−
124−Now say there are actually a ton of functions and values in the `Comment` and `User` modules. Combining them into one does not seem like a good strategy. Instead you can create a *third* module that just has the shared types and functions. Let’s pretend we call that third module `GoodCombination`. So rather than having `Comment` and `User` depend on each other, they now both depend on `GoodCombination`. We broke our cycle!
125−
126−**This strategy is less common.** You generally want to keep the core `type` of a module with all the functions that act upon it directly, so separating a `type` from everything else is a bad sign. So maybe there is a `User` module that contains a bunch of helper functions, but you *use* all those helper functions in a bunch of other modules that interact with users in various ways. In that scenario, it is still more sophisticated than “just throw the types in a module together” and hope it turns out alright.
127−
128−
129−## 3. Use Type Variables
130−
131−Another way to avoid module cycles is to be more generic in how you represent your data:
132−
133−```elm
134−module Comment exposing (..)
135−
136−type alias Comment author =
137− { comment : String
138− , author : author
139− }
140−```
141−
142−```elm
143−module User exposing (..)
144−
145−type alias User comment =
146− { name : String
147− , comments : List comment
148− }
149−```
150−
151−Notice that `Comment` and `User` no longer need to import each other! Instead, whenever we use these modules, we need to fill in the type variable. So we may import both `Comment` and `User` and try to combine them into a `Comment (User (Comment (User ...)))`. Gah, we ran into the recursive type alias thing again!
152−
153−So this strategy fails pretty badly with our particular example. The code is more complicated and it still does not work! So **this strategy is rarely useful**, but when it works, it can simplify things quite a lot.
154−
155−
156−## 4. Hiding Implementation Details in Packages
157−
158−This gets a little bit trickier when you are creating a package like `elm-lang/parser` which is built around the `Parser` type.
159−
160−That package has a couple exposed modules: `Parser`, `Parser.LanguageKit`, and `Parser.LowLevel`. All of these modules want access to the internal details of the `Parser` type, but we do not want to ever expose those internal details to the *users* of this package. So where should the `Parser` type live?!
161−
162−Usually you know which module should expose the type for the best public API. In this case, it makes sense for it to live in the `Parser` module. The way to manage this is to create a `Parser.Internal` module with a definition like:
163−
164−```elm
165−module Parser.Internal exposing (..)
166−
167−type Parser a =
168− Parser ...
169−```
170−
171−Now we can `import Parser.Internal` and use it in any of the modules in our package. The trick is that we never expose the `Parser.Internal` module to the *users* of our package. We can see what is inside, but they cannot! Then in the `Parser` module we can say:
172−
173−```elm
174−module Parser exposing (..)
175−
176−import Parser.Internal as Internal
177−
178−type alias Parser a =
179− Internal.Parser a
180−```
181−
182−So now folks see a `Parser` type exposed by the `Parser` module, and it is the one that is used throughout all the modules in the package. Do not screw up your data representation to avoid this trick! I think we can improve how this appears in documentation, but overall this is the best way to go.
183−
184−Now again, this strategy is particularly useful in packages. It is not as worthwhile in application code.
hints/imports.mddeleted−126
@@ -1,126 +0,0 @@
1−
2−# Hints for Imports
3−
4−When getting started with Elm, it is pretty common to have questions about how the `import` declarations work exactly. These questions usually arise when you start playing with the `Html` library so we will focus on that.
5−
6−
7−<br>
8−
9−## `import`
10−
11−An Elm file is called a **module**. To access code in other files, you need to `import` it!
12−
13−So say you want to use the [`div`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#div) function from the [`elm-lang/html`](http://package.elm-lang.org/packages/elm-lang/html/latest) package. The simplest way is to import it like this:
14−
15−```elm
16−import Html
17−
18−main =
19− Html.div [] []
20−```
21−
22−After saying `import Html` we can refer to anything inside that module as long as it is *qualified*. This works for:
23−
24− - **Values** &mdash; we can refer to `Html.text`, `Html.h1`, etc.
25− - **Types** &mdash; We can refer to [`Attribute`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#Attribute) as `Html.Attribute`.
26−
27−So if we add a type annotation to `main` it would look like this:
28−
29−```elm
30−import Html
31−
32−main : Html.Html msg
33−main =
34− Html.div [] []
35−```
36−
37−We are referring to the [`Html`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#Html) type, using its *qualified* name `Html.Html`. This can feel weird at first, but it starts feeling natural quite quickly!
38−
39−> **Note:** Modules do not contain other modules. So the `Html` module *does not* contain the `Html.Attributes` module. Those are separate names that happen to have some overlap. So if you say `import Html` you *do not* get access to `Html.Attributes.style`. You must `import Html.Attributes` module separately.
40−
41−
42−<br>
43−
44−## `as`
45−
46−It is best practice to always use *qualified* names, but sometimes module names are so long that it becomes unwieldy. This is common for the `Html.Attributes` module. We can use the `as` keyword to help with this:
47−
48−```elm
49−import Html
50−import Html.Attributes as A
51−
52−main =
53− Html.div [ A.style "color" "red" ] [ Html.text "Hello!" ]
54−```
55−
56−Saying `import Html.Attributes as A` lets us refer to any value or type in `Html.Attributes` as long as it is qualified with an `A`. So now we can refer to [`style`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html-Attributes#style) as `A.style`.
57−
58−
59−<br>
60−
61−## `exposing`
62−
63−In quick drafts, maybe you want to use *unqualified* names. You can do that with the `exposing` keyword like this:
64−
65−```elm
66−import Html exposing (..)
67−import Html.Attributes exposing (style)
68−
69−main : Html msg
70−main =
71− div [ style "color" "red" ] [ text "Hello!" ]
72−```
73−
74−Saying `import Html exposing (..)` means I can refer to any value or type from the `Html` module without qualification. Notice that I use the `Html` type, the `div` function, and the `text` function without qualification in the example above.
75−
76−> **Note:** It seems neat to expose types and values directly, but it can get out of hand. Say you `import` ten modules `exposing` all of their content. It quickly becomes difficult to figure out what is going on in your code. “Wait, where is this function from?” And then trying to sort through all the imports to find it. Point is, use `exposing (..)` sparingly!
77−
78−Saying `import Html.Attributes exposing (style)` is a bit more reasonable. It means I can refer to the `style` function without qualification, but that is it. You are still importing the `Html.Attributes` module like normal though, so you would say `Html.Attributes.class` or `Html.Attributes.id` to refer to other values and types from that module.
79−
80−
81−<br>
82−
83−## `as` and `exposing`
84−
85−There is one last way to import a module. You can combine `as` and `exposing` to try to get a nice balance of qualified names:
86−
87−```elm
88−import Html exposing (Html, div, text)
89−import Html.Attributes as A exposing (style)
90−
91−main : Html msg
92−main =
93− div [ A.class "greeting", style "color" "red" ] [ text "Hello!" ]
94−```
95−
96−Notice that I refer to `A.class` which is qualified and `style` which is unqualified.
97−
98−
99−<br>
100−
101−## Default Imports
102−
103−We just learned all the variations of the `import` syntax in Elm. You will use some version of that syntax to `import` any module you ever write.
104−
105−It would be the best policy to make it so every module in the whole ecosystem works this way. We thought so in the past at least, but there are some modules that are so commonly used that the Elm compiler automatically adds the imports to every file. These default imports include:
106−
107−```elm
108−import Basics exposing (..)
109−import List exposing (List, (::))
110−import Maybe exposing (Maybe(..))
111−import Result exposing (Result(..))
112−import String
113−import Tuple
114−
115−import Debug
116−
117−import Platform exposing (Program)
118−import Platform.Cmd as Cmd exposing (Cmd)
119−import Platform.Sub as Sub exposing (Sub)
120−```
121−
122−You can think of these imports being at the top of any module you write.
123−
124−One could argue that `Maybe` is so fundamental to how we handle errors in Elm code that it is *basically* part of the language. One could also argue that it is extraordinarily annoying to have to import `Maybe` once you get past your first couple weeks with Elm. Either way, we know that default imports are not ideal in some sense, so we have tried to keep the default imports as minimal as possible.
125−
126−> **Note:** Elm performs dead code elimination, so if you do not use something from a module, it is not included in the generated code. So if you `import` a module with hundreds of functions, you do not need to worry about the size of your assets. You will only get what you use!
hints/infinite-type.mddeleted−42
@@ -1,42 +0,0 @@
1−
2−# Hints for Infinite Types
3−
4−Infinite types are probably the trickiest kind of bugs to track down. **Writing down type annotations is usually the fastest way to figure them out.** Let's work through an example to get a feel for how these errors usually work though!
5−
6−
7−## Example
8−
9−A common way to get an infinite type error is very small typos. For example, do you see the problem in the following code?
10−
11−```elm
12−incrementNumbers list =
13− List.map incrementNumbers list
14−
15−incrementNumber n =
16− n + 1
17−```
18−
19−The issue is that `incrementNumbers` calls itself, not the `incrementNumber` function defined below. So there is an extra `s` in this program! Let's focus on that:
20−
21−```elm
22−incrementNumbers list =
23− List.map incrementNumbers list -- BUG extra `s` makes this self-recursive
24−```
25−
26−Now the compiler does not know that anything is wrong yet. It just tries to figure out the types like normal. It knows that `incrementNumbers` is a function. The definition uses `List.map` so we can deduce that `list : List t1` and the result of this function call should be some other `List t2`. This also means that `incrementNumbers : List t1 -> List t2`.
27−
28−The issue is that `List.map` uses `incrementNumbers` on `list`! That means that each element of `list` (which has type `t1`) must be fed into `incrementNumbers` (which takes `List t1`)
29−
30−That means that `t1 = List t1`, which is an infinite type! If we start expanding this, we get `List (List (List (List (List ...))))` out to infinity!
31−
32−The point is mainly that we are in a confusing situation. The types are confusing. This explanation is confusing. The compiler is confused. It is a bad time. But luckily, the more type annotations you add, the better chance there is that you and the compiler can figure things out! So say we change our definition to:
33−
34−```elm
35−incrementNumbers : List Int -> List Int
36−incrementNumbers list =
37− List.map incrementNumbers list -- STILL HAS BUG
38−```
39−
40−Now we are going to get a pretty normal type error. Hey, you said that each element in the `list` is an `Int` but I cannot feed that into a `List Int -> List Int` function! Something like that.
41−
42−In summary, the root issue is often some small typo, and the best way out is to start adding type annotations on everything!
hints/init.mddeleted−55
@@ -1,55 +0,0 @@
1−
2−# Creating an Elm project
3−
4−The main goal of `elm init` is to get you to this page!
5−
6−It just creates an `elm.json` file and a `src/` directory for your code.
7−
8−
9−## What is `elm.json`?
10−
11−This file describes your project. It lists all of the packages you depend upon, so it will say the particular version of [`elm/core`](https://package.elm-lang.org/packages/elm/core/latest/) and [`elm/html`](https://package.elm-lang.org/packages/elm/html/latest/) that you are using. It makes builds reproducible! You can read a bit more about it [here](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md).
12−
13−You should generally not edit it by hand. It is better to add new dependencies with commands like `elm install elm/http` or `elm install elm/json`.
14−
15−
16−## What goes in `src/`?
17−
18−This is where all of your Elm files live. It is best to start with a file called `src/Main.elm`. As you work through [the official guide](https://guide.elm-lang.org/), you can put the code examples in that `src/Main.elm` file.
19−
20−
21−## How do I compile it?
22−
23−Run `elm reactor` in your project. Now you can go to [`http://localhost:8000`](http://localhost:8000) and browse through all the files in your project. If you navigate to `.elm` files, it will compile them for you!
24−
25−If you want to do things more manually, you can run `elm make src/Main.elm` and it will produce an `index.html` file that you can look at in your browser.
26−
27−
28−## How do I structure my directories?
29−
30−Many folks get anxious about their project structure. “If I get it wrong, I am doomed!” This anxiety makes sense in languages where refactoring is risky, but Elm is not one of those languages!
31−
32−So we recommend that newcomers staying in one file until you get into the 600 to 1000 range. Push out of your comfort zone. Having the experience of being fine in large files will help you understand the boundaries in Elm, rather than just defaulting to the boundaries you learned in another language.
33−
34−The talk [The Life of a File](https://youtu.be/XpDsk374LDE) gets into this a lot more. The advice about building modules around a specific [custom type](https://guide.elm-lang.org/types/custom_types.html) is particularly important! You will see that emphasized a lot as you work through the official guide.
35−
36−
37−## How do I write tests?
38−
39−Elm will catch a bunch of errors statically, and I think it is worth skipping tests at first to get a feeling for when tests will actually help you _in Elm_.
40−
41−From there, we have a great testing package called [`elm-explorations/test`](https://github.com/elm-explorations/test) that can help you out! It is particularly helpful for teams working on a large codebase. When you are editing code you have never seen before, tests can capture additional details and constraints that are not otherwise apparent!
42−
43−
44−## How do I start fancier projects?
45−
46−I wanted `elm init` to generate as little code as possible. It is mainly meant to get you to this page! If you would like a more elaborate starting point, I recommend starting projects with commands like these:
47−
48−```bash
49−git clone https://github.com/evancz/elm-todomvc.git
50−git clone https://github.com/rtfeldman/elm-spa-example.git
51−```
52−
53−The idea is that Elm projects should be so simple that nobody needs a tool to generate a bunch of stuff. This also captures the fact that project structure _should_ evolve organically as your application develops, never ending up exactly the same as other projects.
54−
55−But if you have something particular you want, I recommend creating your own starter recipe and using `git clone` when you start new projects. That way (1) you can get exactly what you want and (2) we do not end up with a complex `elm init` that ends up being confusing for beginners!
hints/missing-patterns.mddeleted−139
@@ -1,139 +0,0 @@
1−
2−# Hints for Missing Patterns
3−
4−Elm checks to make sure that all possible inputs to a function or `case` are handled. This gives us the guarantee that no Elm code is ever going to crash because data had an unexpected shape.
5−
6−There are a couple techniques for making this work for you in every scenario.
7−
8−
9−## The danger of wildcard patterns
10−
11−A common scenario is that you want to add a tag to a custom type that is used in a bunch of places. For example, maybe you are working different variations of users in a chat room:
12−
13−```elm
14−type User
15− = Regular String Int
16− | Anonymous
17−
18−toName : User -> String
19−toName user =
20− case user of
21− Regular name _ ->
22− name
23−
24− _ ->
25− "anonymous"
26−```
27−
28−Notice the wildcard pattern in `toName`. This will hurt us! Say we add a `Visitor String` variant to `User` at some point. Now we have a bug that visitor names are reported as `"anonymous"`, and the compiler cannot help us!
29−
30−So instead, it is better to explicitly list all possible variants, like this:
31−
32−```elm
33−type User
34− = Regular String Int
35− | Visitor String
36− | Anonymous
37−
38−toName : User -> String
39−toName user =
40− case user of
41− Regular name _ ->
42− name
43−
44− Anonymous ->
45− "anonymous"
46−```
47−
48−Now the compiler will say "hey, what should `toName` do when it sees a `Visitor`?" This is a tiny bit of extra work, but it is very worth it!
49−
50−
51−## I want to go fast!
52−
53−Imagine that the `User` type appears in 20 or 30 functions across your project. When we add a `Visitor` variant, the compiler points out all the places that need to be updated. That is very convenient, but in a big project, maybe you want to get through it extra quickly.
54−
55−In that case, it can be helpful to use [`Debug.todo`](https://package.elm-lang.org/packages/elm-lang/core/latest/Debug#todo) to leave some code incomplete:
56−
57−```elm
58−type User
59− = Regular String Int
60− | Visitor String
61− | Anonymous
62−
63−toName : User -> String
64−toName user =
65− case user of
66− Regular name _ ->
67− name
68−
69− Visitor _ ->
70− Debug.todo "give the visitor name"
71−
72− Anonymous ->
73− "anonymous"
74−
75−-- and maybe a bunch of other things
76−```
77−
78−In this case it is easier to just write the implementation, but the point is that on more complex functions, you can put things off a bit.
79−
80−The Elm compiler is actually aware of `Debug.todo` so when it sees it in a `case` like this, it will crash with a bunch of helpful information. It will tell you:
81−
82− 1. The name of the module that contains the code.
83− 2. The line numbers of the `case` containing the TODO.
84− 3. The particular value that led to this TODO.
85−
86−From that information you have a pretty good idea of what went wrong and can go fix it.
87−
88−I tend to use `Debug.todo` as the message when my goal is to go quick because it makes it easy to go and find all remaining todos in my code before a release.
89−
90−
91−## A list that definitely is not empty
92−
93−This can come up from time to time, but Elm **will not** let you write code like this:
94−
95−```elm
96−last : List a -> a
97−last list =
98− case list of
99− [x] ->
100− x
101−
102− _ :: rest ->
103− last rest
104−```
105−
106−This is no good. It does not handle the empty list. There are two ways to handle this. One is to make the function return a `Maybe` like this:
107−
108−```elm
109−last : List a -> Maybe a
110−last list =
111− case list of
112− [] ->
113− Nothing
114−
115− [x] ->
116− Just x
117−
118− _ :: rest ->
119− last rest
120−```
121−
122−This is nice because it lets users know that there might be a failure, so they can recover from it however they want.
123−
124−The other option is to “unroll the list” one level to ensure that no one can ever provide an empty list in the first place:
125−
126−```elm
127−last : a -> List a -> a
128−last first rest =
129− case rest of
130− [] ->
131− first
132−
133− newFirst :: newRest ->
134− last newFirst newRest
135−```
136−
137−By demanding the first element of the list as an argument, it becomes impossible to call this function if you have an empty list!
138−
139−This “unroll the list” trick is quite useful. I recommend using it directly, not through some external library. It is nothing special. Just a useful idea!
hints/optimize.mddeleted−59
@@ -1,59 +0,0 @@
1−
2−# How to optimize Elm code
3−
4−When you are serving a website, there are two kinds of optimizations you want to do:
5−
6−1. **Asset Size** &mdash; How can we send as few bits as possible?
7−2. **Performance** &mdash; How can those bits run as quickly as possible?
8−
9−It turns out that Elm does really well on both! We have [very small assets](https://elm-lang.org/news/small-assets-without-the-headache) and [very fast code](https://elm-lang.org/news/blazing-fast-html-round-two) when compared to the popular alternatives.
10−
11−Okay, but how do we get those numbers?
12−
13−
14−## Instructions
15−
16−Step one is to compile with the `--optimize` flag. This does things like shortening record field names and unboxing values.
17−
18−Step two is to call `uglifyjs` with a bunch of special flags. The flags unlock optimizations that are unreliable in normal JS code, but because Elm does not have side-effects, they work fine for us!
19−
20−Putting those together, here is how I would optimize `src/Main.elm` with two terminal commands:
21−
22−```bash
23−elm make src/Main.elm --optimize --output=elm.js
24−uglifyjs elm.js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output elm.min.js
25−```
26−
27−After this you will have an `elm.js` and a significantly smaller `elm.min.js` file!
28−
29−**Note 1:** `uglifyjs` is called twice there. First to `--compress` and second to `--mangle`. This is necessary! Otherwise `uglifyjs` will ignore our `pure_funcs` flag.
30−
31−**Note 2:** If the `uglifyjs` command is not available in your terminal, you can run the command `npm install uglify-js --global` to download it. You probably already have `npm` from getting `elm repl` working, but if not, it is bundled with [nodejs](https://nodejs.org/).
32−
33−## Scripts
34−
35−It is hard to remember all that, so it is probably a good idea to write a script that does it.
36−
37−I would maybe want to run `./optimize.sh src/Main.elm` and get out `elm.js` and `elm.min.js`, so on Mac or Linux, I would make a script called `optimize.sh` like this:
38−
39−```bash
40−#!/bin/sh
41−
42−set -e
43−
44−js="elm.js"
45−min="elm.min.js"
46−
47−elm make --optimize --output=$js $@
48−
49−uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min
50−
51−echo "Initial size: $(cat $js | wc -c) bytes ($js)"
52−echo "Minified size:$(cat $min | wc -c) bytes ($min)"
53−echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes"
54−```
55−
56−It also prints out all the asset sizes for you! Your server should be configured to gzip the assets it sends, so the last line is telling you how many bytes would _actually_ get sent to the user.
57−
58−Again, the important commands are `elm` and `uglifyjs` which work on any platform, so it should not be too tough to do something similar on Windows.
59−
hints/port-modules.mddeleted−32
@@ -1,32 +0,0 @@
1−
2−# No Ports in Packages
3−
4−The package ecosystem is one of the most important parts of Elm. Right now, our ecosystem has some compelling benefits:
5−
6− - There are many obvious default packages that work well.
7− - Adding dependencies cannot introduce runtime exceptions.
8− - Patch changes cannot lead to surprise build failures.
9−
10−These are really important factors if you want to *quickly* create *reliable* applications. The Elm community thinks this is valuable.
11−
12−Other communities think that the *number* of packages is a better measure of ecosystem health. That is a fine metric to use, but it is not the one we use for Elm. We would rather have 50 great packages than 100k packages of wildly varying quality.
13−
14−
15−## So what about ports?
16−
17−Imagine you install a new package that claims to support `localStorage`. You get it set up, working through any compile errors. You run it, but it does not seem to work! After trying to figure it out for hours, you realize there is some poorly documented `port` to hook up...
18−
19−Okay, now you need to hook up some JavaScript code. Is that JS file in the Elm package? Or is it on `npm`? Wait, what version on `npm` though? And is this patch version going to work as well? Also, how does this file fit into my build process? And assuming we get through all that, maybe the `port` has the same name as one of the ports in your project. Or it clashes with a `port` name in another package.
20−
21−**Suddenly adding dependencies is much more complicated and risky!** An experienced developer would always check for ports up front, spending a bunch of time manually classifying unacceptable packages. Most people would not know to do that and learn all the pitfalls through personal experience, ultimately spending even *more* time than the person who defensively checks to avoid these issues.
22−
23−So “ports in packages” would impose an enormous cost on application developers, and in the end, we would have a less reliable package ecosystem overall.
24−
25−
26−## Conclusion
27−
28−Our wager with the Elm package ecosystem is that it is better to get a package *right* than to get it *right now*. So while we could use “ports in packages” as a way to get twenty `localStorage` packages of varying quality *right now*, we are choosing not to go that route. Instead we ask that developers use ports directly in their application code, getting the same result a different way.
29−
30−Now this may not be the right choice for your particular project, and that is okay! We will be expanding our core libraries over time, as explained [here](https://github.com/elm-lang/projects/blob/master/roadmap.md#where-is-the-localstorage-package), and we hope you will circle back later to see if Elm has grown into a better fit!
31−
32−If you have more questions about this choice or what it means for your application, please come ask in [the Elm slack](http://elmlang.herokuapp.com/). Folks are friendly and happy to help out! Chances are that a `port` in your application will work great for your case once you learn more about how they are meant to be used.
hints/recursive-alias.mddeleted−162
@@ -1,162 +0,0 @@
1−
2−# Hints for Recursive Type Aliases
3−
4−At the root of this issue is the distinction between a `type` and a `type alias`.
5−
6−
7−## What is a type alias?
8−
9−When you create a type alias, you are just creating a shorthand to refer to an existing type. So when you say the following:
10−
11−```elm
12−type alias Time = Float
13−
14−type alias Degree = Float
15−
16−type alias Weight = Float
17−```
18−
19−You have not created any *new* types, you just made some alternate names for `Float`. You can write down things like this and it'll work fine:
20−
21−```elm
22−add : Time -> Degree -> Weight
23−add time degree =
24− time + degree
25−```
26−
27−This is kind of a weird way to use type aliases though. The typical usage would be for records, where you do not want to write out the whole thing every time. Stuff like this:
28−
29−```elm
30−type alias Person =
31− { name : String
32− , age : Int
33− , height : Float
34− }
35−```
36−
37−It is much easier to write down `Person` in a type, and then it will just expand out to the underlying type when the compiler checks the program.
38−
39−
40−## Recursive type aliases?
41−
42−Okay, so let's say you have some type that may contain itself. In Elm, a common example of this is a comment that might have subcomments:
43−
44−```elm
45−type alias Comment =
46− { message : String
47− , upvotes : Int
48− , downvotes : Int
49− , responses : List Comment
50− }
51−```
52−
53−Now remember that type *aliases* are just alternate names for the real type. So to make `Comment` into a concrete type, the compiler would start expanding it out.
54−
55−```elm
56− { message : String
57− , upvotes : Int
58− , downvotes : Int
59− , responses :
60− List
61− { message : String
62− , upvotes : Int
63− , downvotes : Int
64− , responses :
65− List
66− { message : String
67− , upvotes : Int
68− , downvotes : Int
69− , responses : List ...
70− }
71− }
72− }
73−```
74−
75−The compiler cannot deal with values like this. It would just keep expanding forever.
76−
77−
78−## Recursive types!
79−
80−In cases where you want a recursive type, you need to actually create a brand new type. This is what the `type` keyword is for. A simple example of this can be seen when defining a linked list:
81−
82−```elm
83−type List
84− = Empty
85− | Node Int List
86−```
87−
88−No matter what, the type of `Node n xs` is going to be `List`. There is no expansion to be done. This means you can represent recursive structures with types that do not explode into infinity.
89−
90−So let's return to wanting to represent a `Comment` that may have responses. There are a couple ways to do this:
91−
92−
93−### Obvious, but kind of annoying
94−
95−```elm
96−type Comment =
97− Comment
98− { message : String
99− , upvotes : Int
100− , downvotes : Int
101− , responses : List Comment
102− }
103−```
104−
105−Now let's say you want to register an upvote on a comment:
106−
107−```elm
108−upvote : Comment -> Comment
109−upvote (Comment comment) =
110− Comment { comment | upvotes = 1 + comment.upvotes }
111−```
112−
113−It is kind of annoying that we now have to unwrap and wrap the record to do anything with it.
114−
115−
116−### Less obvious, but nicer
117−
118−```elm
119−type alias Comment =
120− { message : String
121− , upvotes : Int
122− , downvotes : Int
123− , responses : Responses
124− }
125−
126−type Responses = Responses (List Comment)
127−```
128−
129−In this world, we introduce the `Responses` type to capture the recursion, but `Comment` is still an alias for a record. This means the `upvote` function looks nice again:
130−
131−```elm
132−upvote : Comment -> Comment
133−upvote comment =
134− { comment | upvotes = 1 + comment.upvotes }
135−```
136−
137−So rather than having to unwrap a `Comment` to do *anything* to it, you only have to do some unwrapping in the cases where you are doing something recursive. In practice, this means you will do less unwrapping which is nice.
138−
139−
140−## Mutually recursive type aliases
141−
142−It is also possible to build type aliases that are *mutually* recursive. That might be something like this:
143−
144−```elm
145−type alias Comment =
146− { message : String
147− , upvotes : Int
148− , downvotes : Int
149− , responses : Responses
150− }
151−
152−type alias Responses =
153− { sortBy : SortBy
154− , responses : List Comment
155− }
156−
157−type SortBy = Time | Score | MostResponses
158−```
159−
160−When you try to expand `Comment` you have to expand `Responses` which needs to expand `Comment` which needs to expand `Responses`, etc.
161−
162−So this is just a fancy case of a self-recursive type alias. The solution is the same. Somewhere in that cycle, you need to define an actual `type` to end the infinite expansion.
hints/repl.mddeleted−73
@@ -1,73 +0,0 @@
1−
2−# REPL
3−
4−The REPL lets you interact with Elm values and functions in your terminal.
5−
6−
7−## Use
8−
9−You can type in expressions, definitions, custom types, and module imports using normal Elm syntax.
10−
11−```elm
12−> 1 + 1
13−2 : number
14−
15−> "hello" ++ "world"
16−"helloworld" : String
17−```
18−
19−The same can be done with definitions and custom types:
20−
21−```elm
22−> fortyTwo = 42
23−42 : number
24−
25−> increment n = n + 1
26−<function> : number -> number
27−
28−> increment 41
29−42 : number
30−
31−> factorial n =
32−| if n < 1 then
33−| 1
34−| else
35−| n * factorial (n-1)
36−|
37−<function> : number -> number
38−
39−> factorial 5
40−120 : number
41−
42−> type User
43−| = Regular String
44−| | Visitor String
45−|
46−
47−> case Regular "Tom" of
48−| Regular name -> "Hey again!"
49−| Visitor name -> "Nice to meet you!"
50−|
51−"Hey again!" : String
52−```
53−
54−When you run `elm repl` in a project with an [`elm.json`](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md) file, you can import any module available in the project. So if your project has an `elm/html` dependency, you could say:
55−
56−```elm
57−> import Html exposing (Html)
58−
59−> Html.text "hello"
60−<internals> : Html msg
61−
62−> Html.text
63−<function> : String -> Html msg
64−```
65−
66−If you create a module in your project named `MyThing` in your project, you can say `import MyThing` in the REPL as well. Any module that is accessible in your project should be accessible in the REPL.
67−
68−
69−## Exit
70−
71−To exit the REPL, you can type `:exit`.
72−
73−You can also press `ctrl-d` or `ctrl-c` on some platforms.
hints/shadowing.mddeleted−70
@@ -1,70 +0,0 @@
1−
2−# Variable Shadowing
3−
4−Variable shadowing is when you define the same variable name twice in an ambiguous way. Here is a pretty reasonable use of shadowing:
5−
6−```elm
7−viewName : Maybe String -> Html msg
8−viewName name =
9− case name of
10− Nothing ->
11− ...
12−
13− Just name ->
14− ...
15−```
16−
17−I define a `name` with type `Maybe String` and then in that second branch, I define a `name` that is a `String`. Now that there are two `name` values, it is not 100% obvious which one you want in that second branch.
18−
19−Most linters produce warnings on variable shadowing, so Elm makes “best practices” the default. Just rename the first one to `maybeName` and move on.
20−
21−This choice is relatively uncommon in programming languages though, so I want to provide the reasoning behind it.
22−
23−
24−## The Cost of Shadowing
25−
26−The code snippet from above is the best case scenario for variable shadowing. It is pretty clear really. But that is because it is a fake example. It does not even compile.
27−
28−In a large module that is evolving over time, this is going to cause bugs in a very predictable way. You will have two definitions, separated by hundreds of lines. For example:
29−
30−```elm
31−name : String
32−name =
33− "Tom"
34−
35−-- hundreds of lines
36−
37−viewName : String -> Html msg
38−viewName name =
39− ... name ... name ... name ...
40−```
41−
42−Okay, so the `viewName` function has an argument `name` and it uses it three times. Maybe the `viewName` function is 50 lines long in total, so those uses are not totally easy to see. This is fine so far, but say your colleague comes along five months later and wants to support first and last names. They refactor the code like this:
43−
44−```elm
45−viewName : String -> String -> Html msg
46−viewName firstName lastName =
47− ... name ... name ... name ...
48−```
49−
50−The code compiles, but it does not work as intended. They forgot to change all the uses of `name`, and because it shadows the top-level `name` value, it always shows up as `"Tom"`. It is a simple mistake, but it is always the last thing I think of.
51−
52−> Is the data being fetched properly? Let me log all of the JSON requests. Maybe the JSON decoders are messed up? Hmm. Maybe someone is transforming the name in a bad way at some point? Let me check my `update` code.
53−
54−Basically, a bunch of time gets wasted on something that could easily be detected by the compiler. But this bug is rare, right?
55−
56−
57−## Aggregate Cost
58−
59−Thinking of a unique and helpful name takes some extra time. Maybe 30 seconds. But it means that:
60−
61− 1. Your code is easier to read and understand later on. So you spend 30 seconds once `O(1)` rather than spending 10 seconds each time someone reads that code in the future `O(n)`.
62−
63− 2. The tricky shadowing bug described above is impossible. Say there is a 5% chance that any given edit produces a shadowing bug, and that resolving that shadowing bug takes one hour. That means the expected time for each edit increases by three minutes.
64−
65−If you are still skeptical, I encourage you can play around with the number of edits, time costs, and probabilities here. When shadowing is not allowed, the resulting overhead for the entire lifetime of the code is the 30 seconds it takes to pick a better name, so that is what you need to beat!
66−
67−
68−## Summary
69−
70−Without shadowing, the code easier to read and folks spend less time on pointless debugging. The net outcome is that folks have more time to make something wonderful with Elm!
hints/tuples.mddeleted−19
@@ -1,19 +0,0 @@
1−
2−# From Tuples to Records
3−
4−The largest tuple possible in Elm has three entries. Once you get to four, it is best to make a record with named entries.
5−
6−For example, it is _conceivable_ to represent a rectangle as four numbers like `(10,10,100,100)` but it would be more self-documenting to use a record like this:
7−
8−```elm
9−type alias Rectangle =
10− { x : Float
11− , y : Float
12− , width : Float
13− , height : Float
14− }
15−```
16−
17−Now it is clear that the dimensions should be `Float` values. It is also clear that we are not using the convention of specifying the top-left and bottom-right corners. It could be clearer about whether the `x` and `y` is the point in the top-left or in the middle though!
18−
19−Anyway, using records like this also gives you access to syntax like `rect.x`, `.x`, and `{ rect | x = 40 }`. It is not clear how to design features like that for arbitrarily sized tuples, so we did not. We already have a way, and it is more self-documenting!
hints/type-annotations.mddeleted−60
@@ -1,60 +0,0 @@
1−
2−# Hints for Type Annotation Problems
3−
4−At the root of this kind of issue is always the fact that a type annotation in your code does not match the corresponding definition. Now that may mean that the type annotation is "wrong" or it may mean that the definition is "wrong". The compiler cannot figure out your intent, only that there is some mismatch.
5−
6−This document is going to outline the various things that can go wrong and show some examples.
7−
8−
9−## Annotation vs. Definition
10−
11−The most common issue is with user-defined type variables that are too general. So let's say you have defined a function like this:
12−
13−```elm
14−addPair : (a, a) -> a
15−addPair (x, y) =
16− x + y
17−```
18−
19−The issue is that the type annotation is saying "I will accept a tuple containing literally *anything*" but the definition is using `(+)` which requires things to be numbers. So the compiler is going to infer that the true type of the definition is this:
20−
21−```elm
22−addPair : (number, number) -> number
23−```
24−
25−So you will probably see an error saying "I cannot match `a` with `number`" which is essentially saying, you are trying to provide a type annotation that is **too general**. You are saying `addPair` accepts anything, but in fact, it can only handle numbers.
26−
27−In cases like this, you want to go with whatever the compiler inferred. It is good at figuring this kind of stuff out ;)
28−
29−
30−## Annotation vs. Itself
31−
32−It is also possible to have a type annotation that clashes with itself. This is probably more rare, but someone will run into it eventually. Let's use another version of `addPair` with problems:
33−
34−```elm
35−addPair : (Int, Int) -> number
36−addPair (x, y) =
37− x + y
38−```
39−
40−In this case the annotation says we should get a `number` out, but because we were specific about the inputs being `Int`, the output should also be an `Int`.
41−
42−
43−## Annotation vs. Internal Annotation
44−
45−A quite tricky case is when an outer type annotation clashes with an inner type annotation. Here is an example of this:
46−
47−```elm
48−filter : (a -> Bool) -> List a -> List a
49−filter isOkay list =
50− let
51− keepIfOkay : a -> Maybe a
52− keepIfOkay x =
53− if isOkay x then Just x else Nothing
54− in
55− List.filterMap keepIfOkay list
56−```
57−
58−This case is very unfortunate because all the type annotations are correct, but there is a detail of how type inference works right now that **user-defined type variables are not shared between annotations**. This can lead to probably the worst type error messages we have because the problem here is that `a` in the outer annotation does not equal `a` in the inner annotation.
59−
60−For now the best route is to leave off the inner annotation. It is unfortunate, and hopefully we will be able to do a nicer thing in future releases.
installers/README.mddeleted−32
@@ -1,32 +0,0 @@
1−# Installing Elm
2−
3−The normal path is to work through [the guide](https://guide.elm-lang.org/) until you need to install, but you can skip to installation directly by going [here](https://guide.elm-lang.org/install/terminal.html).
4−
5−
6−<br/>
7−
8−## Installing Multiple Versions
9−
10−The secret is that Elm is just a single executable file. If you are developing a project in `~/Desktop/project/` you can download this file into that directory and run commands like `~/Desktop/project/elm make src/Main.elm` or `./elm make src/Main.elm`. You just run the local copy of the executable file!
11−
12−The instructions for [Mac][mac] and [Linux][lin] explain how to do this in more detail. You can follow the same steps on Windows, but you need to do each step by hand. (E.g. download the file through your browser rather than with a terminal command.)
13−
14−[mac]: https://github.com/elm/compiler/blob/master/installers/mac/README.md
15−[lin]: https://github.com/elm/compiler/blob/master/installers/linux/README.md
16−
17−<br/>
18−
19−## Installing Previous Versions
20−
21−The past binaries for Mac, Linux, and Windows are hosted [here](https://github.com/elm/compiler/releases).
22−
23−You can download the executable files directly and use them locally.
24−
25−
26−<br/>
27−
28−## Uninstall
29−
30−- [Mac](https://github.com/elm/compiler/blob/master/installers/mac/README.md#uninstall)
31−- [Linux](https://github.com/elm/compiler/blob/master/installers/linux/README.md#uninstall)
32−- [Windows](https://github.com/elm/compiler/blob/master/installers/win/README.md#uninstall)
installers/linux/Dockerfiledeleted−39
@@ -1,39 +0,0 @@
1−# Based initially on https://gist.github.com/rlefevre/1523f47e75310e28eee243c9c5651ac9
2−#
3−# Build Linux x64 binary from elm compiler top-level directory:
4−# $ docker build -t elm -f installers/linux/Dockerfile .
5−#
6−# Retrieve elm Linux binary:
7−# $ docker cp $(docker create elm):/usr/local/bin/elm DESTINATION_DIRECTORY
8−#
9−# Delete docker elm image:
10−# $ docker rmi elm
11−#
12−# Display all images:
13−# $ docker images -a
14−#
15−# Delete all unused docker images:
16−# $ docker system prune -a
17−
18−# Use Alpine 3.11 with GHC 8.6.5
19−FROM alpine:3.11
20−
21−# Install packages required to build elm
22−RUN apk add --no-cache ghc cabal wget musl-dev zlib-dev zlib-static ncurses-dev ncurses-static
23−
24−WORKDIR /elm
25−
26−# Import source code
27−COPY builder builder
28−COPY compiler compiler
29−COPY reactor reactor
30−COPY terminal terminal
31−COPY cabal.config elm.cabal LICENSE ./
32−
33−# Build statically linked elm binary
34−RUN cabal new-update
35−RUN cabal new-build --ghc-option=-optl=-static --ghc-option=-split-sections
36−RUN cp ./dist-newstyle/build/x86_64-linux/ghc-*/elm-*/x/elm/build/elm/elm /usr/local/bin/elm
37−
38−# Remove debug symbols to optimize the binary size
39−RUN strip -s /usr/local/bin/elm
installers/linux/README.mddeleted−93
@@ -1,93 +0,0 @@
1−# Install Instructions
2−
3−The pre-compiled binary for Linux works on a very wide range of distributions.
4−
5−It should be possible to install it by running the following commands in your terminal:
6−
7−```bash
8−# Move to your Desktop so you can see what is going on easier.
9−#
10−cd ~/Desktop/
11−
12−# Download the 0.19.1 binary for Linux.
13−#
14−# +-----------+----------------------+
15−# | FLAG | MEANING |
16−# +-----------+----------------------+
17−# | -L | follow redirects |
18−# | -o elm.gz | name the file elm.gz |
19−# +-----------+----------------------+
20−#
21−curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz
22−
23−# There should now be a file named `elm.gz` on your Desktop.
24−#
25−# The downloaded file is compressed to make it faster to download.
26−# This next command decompresses it, replacing `elm.gz` with `elm`.
27−#
28−gunzip elm.gz
29−
30−# There should now be a file named `elm` on your Desktop!
31−#
32−# Every file has "permissions" about whether it can be read, written, or executed.
33−# So before we use this file, we need to mark this file as executable:
34−#
35−chmod +x elm
36−
37−# The `elm` file is now executable. That means running `~/Desktop/elm --help`
38−# should work. Saying `./elm --help` works the same.
39−#
40−# But we want to be able to say `elm --help` without specifying the full file
41−# path every time. We can do this by moving the `elm` binary to one of the
42−# directories listed in your `PATH` environment variable:
43−#
44−sudo mv elm /usr/local/bin/
45−
46−# Now it should be possible to run the `elm` binary just by saying its name!
47−#
48−elm --help
49−```
50−
51−<br/>
52−
53−## Wait, what is the `PATH` variable?
54−
55−When you run a command like `elm make src/Main.elm`, your computer starts by trying to find an executable file called `elm`.
56−
57−The `PATH` is the list of directories that get searched. You can see these directories by running:
58−
59−```bash
60−echo $PATH
61−```
62−
63−This prints `/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin` on my computer. The directories are separated by a `:` so there are five possibilities listed here.
64−
65−When I run `elm make src/Main.elm`, my terminal starts by searching these five directories for an executable file named `elm`. It finds `/usr/local/bin/elm` and then runs `/usr/local/bin/elm make src/Main.elm` with whatever arguments I gave.
66−
67−So the `PATH` environment variable is a convention that allows you to refer to a specific executable file without knowing exactly where it lives on your computer. This is actually how all "terminal commands" work! Commands like `ls` are really executable files that live in directories listed in your `PATH` variable.
68−
69−So the point of running `sudo mv elm /usr/local/bin/` is to turn the `elm` binary into a terminal command, allowing us to call it just like `ls` and `cd`.
70−
71−**Note:** Why do we need to use `sudo` for that one command? Imagine if some program was able to add executables named `ls` or `cd` to `/usr/local/bin` that did something tricky and unexpected. That would be a security problem! Many distributions make this scenario less likely by requiring special permissions to modify the `/usr/local/bin/` directory.
72−
73−
74−<br/>
75−
76−## Uninstall
77−
78−The following commands should remove everything:
79−
80−```bash
81−# Remove the `elm` executable.
82−#
83−sudo rm /usr/local/bin/elm
84−
85−# Remove any cached files. The files here reduce compile times when
86−# starting new projects and make it possible to work offline in more
87−# cases. No need to keep it around if you are uninstalling though!
88−#
89−rm -r ~/.elm/
90−```
91−
92−If you have any Elm projects still on your computer, you can remove their `elm-stuff/` directories as well.
93−
installers/mac/Distribution.xml+3−5
@@ -1,6 +1,6 @@
1<?xml version="1.0" encoding="utf-8" standalone="no"?>
1<?xml version="1.0" encoding="utf-8" standalone="no"?>
2<installer-script minSpecVersion="1.000000" authoringTool="com.apple.PackageMaker" authoringToolVersion="3.0.6" authoringToolBuild="201">
2<installer-script minSpecVersion="1.000000" authoringTool="com.apple.PackageMaker" authoringToolVersion="3.0.6" authoringToolBuild="201">
3− <title>Elm</title>
3+ <title>Elm Platform</title>
4 <options customize="allow" allow-external-scripts="no"/>
4 <options customize="allow" allow-external-scripts="no"/>
5 <domains enable_localSystem="true"/>
5 <domains enable_localSystem="true"/>
6 <volume-check script="pm_volume_check();"/>
6 <volume-check script="pm_volume_check();"/>
@@ -10,7 +10,7 @@
10function pm_volume_check() {
10function pm_volume_check() {
11 if(!(my.target.systemVersion &amp;&amp; /* >= */ system.compareVersions(my.target.systemVersion.ProductVersion, '10.6.0') >= 0)) {
11 if(!(my.target.systemVersion &amp;&amp; /* >= */ system.compareVersions(my.target.systemVersion.ProductVersion, '10.6.0') >= 0)) {
12 my.result.title = 'Failure';
12 my.result.title = 'Failure';
13− my.result.message = 'This version of Elm requires Mac OS X 10.6 or later.';
13+ my.result.message = 'This version of Elm Platform requires Mac OS X 10.6 or later.';
14 my.result.type = 'Fatal';
14 my.result.type = 'Fatal';
15 return false;
15 return false;
16 }
16 }
@@ -18,15 +18,13 @@ function pm_volume_check() {
18}
18}
19
19
20</script>
20</script>
21− <!--
22 <background file="background.png" alignment="bottomleft" scaling="none" mime-type="image/png"/>
21 <background file="background.png" alignment="bottomleft" scaling="none" mime-type="image/png"/>
23− -->
24 <welcome mime-type="text/rtf" file="welcome.rtf" />
22 <welcome mime-type="text/rtf" file="welcome.rtf" />
25 <conclusion mime-type="text/rtf" file="conclusion.rtf" />
23 <conclusion mime-type="text/rtf" file="conclusion.rtf" />
26 <choices-outline>
24 <choices-outline>
27 <line choice="choice2"/>
25 <line choice="choice2"/>
28 </choices-outline>
26 </choices-outline>
29− <choice id="choice2" title="Elm">
27+ <choice id="choice2" title="Elm Platform ">
30 <pkg-ref id="org.elm-lang.binaries.pkg"/>
28 <pkg-ref id="org.elm-lang.binaries.pkg"/>
31 </choice>
29 </choice>
32 <pkg-ref id="org.elm-lang.binaries.pkg" installKBytes="19444" version="1" auth="Root">binaries.pkg</pkg-ref>
30 <pkg-ref id="org.elm-lang.binaries.pkg" installKBytes="19444" version="1" auth="Root">binaries.pkg</pkg-ref>
installers/mac/README.mddeleted−93
@@ -1,93 +0,0 @@
1−# Install Instructions
2−
3−The easiest way to install is to to use [the Mac installer](https://github.com/elm/compiler/releases/download/0.19.1/installer-for-mac.pkg)!
4−
5−But it is also possible to install by running the following commands in your terminal:
6−
7−```bash
8−# Move to your Desktop so you can see what is going on easier.
9−#
10−cd ~/Desktop/
11−
12−# Download the 0.19.1 binary for Linux.
13−#
14−# +-----------+----------------------+
15−# | FLAG | MEANING |
16−# +-----------+----------------------+
17−# | -L | follow redirects |
18−# | -o elm.gz | name the file elm.gz |
19−# +-----------+----------------------+
20−#
21−curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-mac-64-bit.gz
22−
23−# There should now be a file named `elm.gz` on your Desktop.
24−#
25−# The downloaded file is compressed to make it faster to download.
26−# This next command decompresses it, replacing `elm.gz` with `elm`.
27−#
28−gunzip elm.gz
29−
30−# There should now be a file named `elm` on your Desktop!
31−#
32−# Every file has "permissions" about whether it can be read, written, or executed.
33−# So before we use this file, we need to mark this file as executable:
34−#
35−chmod +x elm
36−
37−# The `elm` file is now executable. That means running `~/Desktop/elm --help`
38−# should work. Saying `./elm --help` works the same.
39−#
40−# But we want to be able to say `elm --help` without specifying the full file
41−# path every time. We can do this by moving the `elm` binary to one of the
42−# directories listed in your `PATH` environment variable:
43−#
44−sudo mv elm /usr/local/bin/
45−
46−# Now it should be possible to run the `elm` binary just by saying its name!
47−#
48−elm --help
49−```
50−
51−<br/>
52−
53−## What is the `PATH` variable?
54−
55−When you run a command like `elm make src/Main.elm`, your computer starts by trying to find an executable file called `elm`.
56−
57−The `PATH` is the list of directories that get searched. You can see these directories by running:
58−
59−```bash
60−echo $PATH
61−```
62−
63−This prints `/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin` on my computer. The directories are separated by a `:` so there are five possibilities listed here.
64−
65−When I run `elm make src/Main.elm`, my terminal starts by searching these five directories for an executable file named `elm`. It finds `/usr/local/bin/elm` and then runs `/usr/local/bin/elm make src/Main.elm` with whatever arguments I gave.
66−
67−So the `PATH` environment variable is a convention that allows you to refer to a specific executable file without knowing exactly where it lives on your computer. This is actually how all "terminal commands" work! Commands like `ls` are really executable files that live in directories listed in your `PATH` variable.
68−
69−So the point of running `sudo mv elm /usr/local/bin/` is to turn the `elm` binary into a terminal command, allowing us to call it just like `ls` and `cd`.
70−
71−**Note:** Why do we need to use `sudo` for that one command? Imagine if some program was able to add executables named `ls` or `cd` to `/usr/local/bin` that did something tricky and unexpected. That would be a security problem! Many distributions make this scenario less likely by requiring special permissions to modify the `/usr/local/bin/` directory.
72−
73−
74−<br/>
75−
76−## Uninstall
77−
78−The following commands should remove everything:
79−
80−```bash
81−# Remove the `elm` executable.
82−#
83−sudo rm /usr/local/bin/elm
84−
85−# Remove any cached files. The files here reduce compile times when
86−# starting new projects and make it possible to work offline in more
87−# cases. No need to keep it around if you are uninstalling though!
88−#
89−rm -r ~/.elm/
90−```
91−
92−If you have any Elm projects still on your computer, you can remove their `elm-stuff/` directories as well.
93−
installers/mac/Resources/en.lproj/background.pngnew file

Binary file not shown.

installers/mac/Resources/en.lproj/conclusion.rtf+6−13
@@ -1,16 +1,9 @@
1−{\rtf1\ansi\ansicpg1252\cocoartf2509
1+{\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400
2−\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;}
2+{\fonttbl\f0\fswiss\fcharset0 Helvetica;}
3{\colortbl;\red255\green255\blue255;}
3{\colortbl;\red255\green255\blue255;}
4−{\*\expandedcolortbl;;}
5−\paperw11900\paperh16840\margl1440\margr1440\vieww11180\viewh8400\viewkind0
4+\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0
6−\pard\tx720\tx1440\tx2160\tx2880\tx3600\tx4320\tx5040\tx5760\tx6480\tx7200\tx7920\tx8640\pardirnatural\partightenfactor0
5+\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural
7
6
8−\f0\fs28 \cf0 Try opening the terminal and running commands like:\
7+\f0\fs26 \cf0 A bunch of useful programs were just placed in /usr/local/bin/\
9\
8\
10−
11−\f1 elm init\
12−elm make src/Main.elm --optimize\
13−elm repl
14−\f0 \
15−\
16−Check out {\field{\*\fldinst{HYPERLINK "https://guide.elm-lang.org/"}}{\fldrslt this tutorial}} for more advice!}
9+Check out {\field{\*\fldinst HYPERLINK "http://elm-lang.org/Get-Started.elm"}{\fldrslt this tutorial}} to learn how to use them!}
installers/mac/Resources/en.lproj/welcome.rtf+4−9
@@ -1,12 +1,7 @@
1−{\rtf1\ansi\ansicpg1252\cocoartf2509
1+{\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400
2−\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;}
2+{\fonttbl\f0\fswiss\fcharset0 Helvetica;}
3{\colortbl;\red255\green255\blue255;}
3{\colortbl;\red255\green255\blue255;}
4−{\*\expandedcolortbl;;}
5\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0
4\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0
6−\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural\partightenfactor0
5+\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural
7
6
8−\f0\fs28 \cf0 Thank you for trying out Elm!\
7+\f0\fs28 \cf0 This package will install Elm on your machine.}
9−\
10−This installer makes
11−\f1 elm
12−\f0 available in your terminal.}
installers/mac/helper-scripts/elm-startup.sh+1−1
@@ -1,3 +1,3 @@
1#!/bin/sh
1#!/bin/sh
2
2
3−open 'http://guide.elm-lang.org'
3+open 'http://elm-lang.org'
installers/mac/make-installer.sh+3−30
@@ -29,8 +29,7 @@ cp $(pwd)/preinstall $pkg_scripts
29cp $(pwd)/postinstall $pkg_scripts
29cp $(pwd)/postinstall $pkg_scripts
30
30
31pkgbuild \
31pkgbuild \
32− --sign "Developer ID Installer: <NAME>" \
33− --identifier org.elm-lang.binary \
32+ --identifier org.elm-lang.binaries.pkg \
34 --install-location $usr_binaries \
33 --install-location $usr_binaries \
35 --scripts $pkg_scripts \
34 --scripts $pkg_scripts \
36 --filter 'Scripts.*' \
35 --filter 'Scripts.*' \
@@ -40,42 +39,16 @@ pkgbuild \
40
39
41#### BUNDLE ASSETS ####
40#### BUNDLE ASSETS ####
42
41
43−rm -f installer-for-mac.pkg
42+rm -f Elm.pkg
44
43
45productbuild \
44productbuild \
46− --sign "Developer ID Installer: <NAME>" \
47− --identifier org.elm-lang.installer \
48 --distribution Distribution.xml \
45 --distribution Distribution.xml \
49 --package-path . \
46 --package-path . \
50 --resources Resources \
47 --resources Resources \
51− installer-for-mac.pkg
48+ Elm.pkg
52
49
53
50
54#### CLEAN UP ####
51#### CLEAN UP ####
55
52
56rm binaries.pkg
53rm binaries.pkg
57rm -rf $pkg_root
54rm -rf $pkg_root
58−
59−
60−#### BEGIN NOTARIZATION ####
61−
62−xcrun altool \
63− --notarize-app \
64− --primary-bundle-id "org.elm-lang.installer" \
65− --username "<EMAIL>" \
66− --password "@keychain:Developer-altool" \
67− --file "installer-for-mac.pkg"
68−
69−# From https://scriptingosx.com/2019/09/notarize-a-command-line-tool/
70−#
71−#### Check on notarization:
72−#
73−# xcrun altool \
74−# --notarization-info "<RequestUUID>" \
75−# --username "<EMAIL>" \
76−# --password "@keychain:Developer-altool"
77−#
78−#
79−#### Staple Notarization:
80−#
81−# xcrun stapler staple installer-for-mac.pkg
installers/npm/PUBLISHING.md+141−29
@@ -1,59 +1,171 @@
1−# Publishing
1+# Publishing a new release
2
2
3−Here's how to update the `npm` installer.
3+A new version of Elm came out. Huzzah! Here's how to update the `npm` installer.
4
4
5+## 1. Create tarballs of binaries
5
6
6−## 1. GitHub Release
7+You can find a list of what binaries we'll need to tar up in `index.js`.
7
8
8−Create a [GitHub Release](https://github.com/elm/compiler/releases) with the following files:
9+For example:
9
10
10−1. `binary-for-mac-64-bit.gz`
11+```javascript
11−2. `binary-for-windows-64-bit.gz`
12+var root =
12−3. `binary-for-linux-64-bit.gz`
13+ "https://github.com/elm/compiler/releases/download/" +
14+ binVersion +
15+ "/binaries-for-";
13
16
14−Create each of these by running the `elm` executable for each platform through `gzip elm`.
17+module.exports = binwrap({
18+ binaries: ["elm"],
19+ urls: {
20+ "darwin-x64": root + "mac.tar.gz",
21+ "win32-x64": root + "windows.tar.gz",
22+ "win32-ia32": root + "windows.tar.gz",
23+ "linux-x64": root + "linux.tar.gz"
24+ }
25+});
26+```
27+
28+If this is the end of your `index.js`, you'll need to create these files:
15
29
30+1. `binaries-for-mac.tar.gz`
31+2. `binaries-for-windows.tar.gz`
32+3. `binaries-for-linux.tar.gz`
16
33
17−## 2. Try a beta release
34+Each of these tarballs should have **only the Elm binary** inside them - no
35+directories!
18
36
19−In `package.json`, bump the version to `"0.19.2-beta"`.
37+So create them by making a directory, putting all the binaries in it, `cd`-ing
38+into that directory, and then running something like this:
20
39
21−```bash
40+```shell
22−npm publish --tag beta
41+$ tar cvzf binaries-for-linux.tar.gz elm
23```
42```
24
43
25−To test that it works, run these commands:
44+Make sure each tarball contains all the binaries listed in that `binaries:` list
45+in `index.js`. (The Windows ones should have `.exe` at the end; `binwrap`
46+expects that they will, for Windows only.)
47+
48+## 2. Update the `bin/` binary wrappers
49+
50+Inside the npm installer's `bin/` directory, there should be a file for each of
51+the binaries that will be included in this release.
52+
53+Each of these must be executable! If you're not sure whether they are,
54+run `chmod +x` on them just to be sure.
55+
56+Their paths must also must all be listed in `package.json` in two places:
57+
58+1. The `"files":` field
59+2. The `"bin":` field
60+
61+If the executables are the same as they were for the last release, great!
62+You can proceed to the next step. If any binaries were removed, make sure to
63+remove them from these lists!
64+
65+## 3. Update `package.json` for a beta release
66+
67+In `package.json`, bump the version to the next applicable release, and add
68+a `"-beta"` suffix to it.
69+
70+For example, if it was on `"0.18.0"` you might bump it to `"0.19.0-beta"`.
71+The version number should match the release of Elm, such that if people do
72+`npm install elm@0.19.0@beta` they get what they would expect.
73+
74+## 4. Tag the beta release
75+
76+Commit this change and tag it with the name of the release **without** the
77+`-beta` suffix. (We will overwrite this tag later.)
78+
79+For example:
26
80
27−```bash
81+```shell
28−npm dist-tags ls elm
82+$ git tag 0.19.0
29−npm install elm@beta --ignore-scripts
83+$ git push origin 0.19.0
30```
84```
31
85
32−The `latest` tag should not be changed, and there should be an additional `beta` tag.
86+Now this tag should exist on GitHub, allowing us to upload binaries to it.
33
87
34−Try this on Windows, Linux, and Mac.
88+## 5. Upload binaries
35
89
90+Visit the [Create a New Release](https://github.com/elm-lang/elm-platform/releases/new)
91+page and use the `Tag version` dropdown to select the tag you just pushed. Give
92+it a title like `0.19.0`. Don't mention the `-beta` in it. The "beta" concept
93+is for `npm` only.
36
94
37−## 3. Publish final release
95+Upload the tarballs you created in step 1.
38
96
39−Remove the `-beta` suffix from the version in `package.json`. Then run:
97+## 6. Publish beta release
40
98
41−```bash
99+Run this to publish the beta release. The `--tag beta` is **crucial** here.
100+Without it, `npm` will by default publish a new top-level release, which would
101+mean that what you just published would become what everyone gets when they
102+`npm install -g elm` without any additional qualifiers.
103+
104+```shell
42−npm publish
105+$ npm publish --tag beta
43```
106```
44
107
108+Afterwards you should be able to do `npm info elm | less` and see something
109+like this in the JSON:
110+
111+```
112+'dist-tags': { latest: '0.18.0', beta: '0.19.0-beta' }
113+```
45
114
46−## 4. Tag the `latest-0.19.1` version
115+If you messed this up, and the `latest` tag now points to the beta you just
116+published, don't panic - it's fixable! `dist-tags` can always be modified after
117+the fact. Read up on `npm` [dist-tags](https://docs.npmjs.com/cli/dist-tag)
118+to learn how to fix things.
47
119
48−Many compiler releases have needed multiple `npm` publications. Maybe something does not work on Windows or some dependency becomes insecure. Normal `npm` problems.
120+## 7. Verify beta installer
49
121
50−The convention for each Elm release is to create a tag the latest one.
122+Make an empty directory and run `npm init` inside it.
51
123
52−```bash
124+Then run this:
53−npm dist-tag add elm@0.19.1-3 latest-0.19.1
125+
126+```shell
127+$ npm install elm@beta --ignore-scripts
54```
128```
55
129
56−That way people who want a specific version can point to `latest-0.19.1` or `latest-0.18.0` instead of knowing the particular names of all the various publications.
130+This should succeed with an exit code of `0`.
131+If it did, look in `node_modules/.bin/` for the binaries you expect.
132+They should be present, and they should also work as expected when you run them.
133+Because you installed them with `--ignore-scripts`, the first thing they should
134+do is to download themselves and then execute whatever command you requested
135+(e.g. `node_modules/.bin/elm make Main.elm`). If you run the same command a
136+second time, it should run faster because it doesn't have to download the binary
137+first.
138+
139+Now try it again with `--ignore-scripts` turned off:
140+
141+```shell
142+$ rm -r node_modules
143+$ npm install elm@beta --ignore-scripts=false
144+```
145+
146+This time it should download the binaries during the installation phase. Once
147+again you should be able to run the binaries from `node_modules/.bin/`, and
148+this time they should be fast from the first run because they're already
149+downloaded.
150+
151+## 8. Publish for real
152+
153+It's a good idea to ask others to try out the beta installer before doing this!
154+Especially on multiple operating systems.
155+
156+To publish the real version:
157+
158+1. Edit `package.json` to remove the `-beta` suffix from the version.
159+2. Commit that change and push it.
160+3. Use `git tag --force` to overwrite the previous tag (e.g. `0.19.0` - whatever you used before).
161+4. Force push the tag, e.g. `git push origin 0.19.0 --force-with-lease`.
162+5. `npm publish`
57
163
58−You can read more about dist-tags [here](https://docs.npmjs.com/cli/dist-tag).
164+You're done! Now whenever anyone does `npm install -g elm` they'll get the
165+version you just uploaded.
59
166
167+The reason we only used the `-beta` suffix for `npm` was so that when we ran
168+tests on the beta version, it was all against the same (non-beta) URLs we'd end
169+up using for the real version. This means there's no opportunity for us to
170+introduce some sort of mismatch between the beta that we verified and the real
171+version.
installers/npm/README.md+23−30
@@ -1,45 +1,38 @@
1−# Elm Installer
1+npm install elm [![Travis build Status](https://travis-ci.org/elm-lang/elm-platform.svg?branch=master)](http://travis-ci.org/elm-lang/elm-platform) [![AppVeyor build status](https://ci.appveyor.com/api/projects/status/6mcub79i04ianpm9/branch/master?svg=true)](https://ci.appveyor.com/project/rtfeldman/elm-platform/branch/master)
2+===============
2
3
3−[Elm](https://elm-lang.org) is a functional programming language that compiles to JavaScript.
4+Install the [Elm Platform](https://github.com/elm-lang/elm-platform) via [`npm`](https://www.npmjs.com).
4
5
5−Head over to [The Official Guide](https://guide.elm-lang.org/) to start learning Elm!
6+## Installing
6
7
8+Run this to get the binaries:
7
9
8−<br/>
10+```
9−
11+$ npm install -g elm
10−## What is this package for?
12+```
11−
12−**Normal installs** ❌
13−
14−Use the instructions [here](https://guide.elm-lang.org/install/elm.html) instead.
15−
16−**Multiple versions** ✅
17−
18−People using Elm at work may use different versions of Elm in different projects. They can run `npm install elm@latest-0.19.1` in each project and use the binary at `./node_modules/.bin/elm` for compilation.
19−
20−**Continuous integration** ⚠️
21−
22−This works, but there are usually faster and more reliable options:
23−
24−1. You can download `elm` directly from GitHub with [this script](https://github.com/elm/compiler/blob/master/installers/linux/README.md). This is all the `npm` installer does, but with extra HTTP requests to `npmjs.com` servers, making it slower and adding more failure points.
25−2. Many continuous integration have ways to cache files ([example](https://docs.travis-ci.com/user/caching/)) to make builds faster and more reliable.
26−
27−That said, it will definitely work to use the `npm` installer on CI if you prefer that option.
28
13
14+## Installing behind a proxy server
29
15
30−<br/>
16+If you are behind a proxy server, set the environment variable "HTTPS_PROXY".
31
17
32−## Install Locally
18+```
19+$ export HTTPS_PROXY=$YourProxyServer$
20+$ npm install -g elm
21+```
33
22
34−The following command should download the latest Elm 0.19.1 binary:
23+Or on Windows:
35
24
36```
25```
26+$ set HTTPS_PROXY=$YourProxyServer$
37−npm install elm@latest-0.19.1
27+$ npm install -g elm
38```
28```
39
29
40−You should be able to run `./node_modules/bin/elm --version` within your project and see `0.19.1`. Now you can compile with `./node_modules/bin/elm make src/Main.elm` and not disrupt other packages.
30+## Troubleshooting
41
31
42−Use `npm install elm@latest-0.19.0` or `npm install elm@latest-0.18.0` for earlier versions.
32+1. [Troubleshooting npm](https://github.com/npm/npm/wiki/Troubleshooting)
33+2. On Debian/Ubuntu systems, you may have to install the nodejs-legacy package: `apt-get install nodejs-legacy`.
34+3. If the installer says that it cannot find any usable binaries for your operating system and architecture, check the [Build from Source](https://github.com/elm-lang/elm-platform/blob/master/README.md#build-from-source) documentation.
43
35
44−**Note:** The `latest-X.Y.Z` convention is used in case we need to publish patches for the `npm` installer within a given Elm release. For example, say `npm` decides that some transitive dependency is not secure. Nothing is changing about Elm or the binaries, but we need to publish a new `npm` installer that fixes this issue.
36+## Getting Started
45
37
38+Once everything has installed successfully, head over to the [Get Started](http://elm-lang.org/Get-Started.elm) page!
installers/npm/bin/elm+16−42
@@ -1,54 +1,28 @@
1#!/usr/bin/env node
1#!/usr/bin/env node
2
2
3var child_process = require('child_process');
3var child_process = require('child_process');
4−var path = require('path');
4+var download = require('../download.js');
5var fs = require('fs');
5var fs = require('fs');
6
6
7
7
8−// Some npm users enable --ignore-scripts (a good security measure) so
8+// Some npm users enable --ignore-scripts (a good security measure)
9−// they do not run the post-install hook and install.js does not run.
10−// Instead they will run this script.
11//
9//
12−// On Mac and Linux, we download the elm executable into the exact same
10+// They do not run the post-install hook, so install.js does not run.
13−// location as this file. Since npm uses symlinks on these platforms,
14−// that means that the first run will invoke this file and subsequent
15−// runs will call the elm binary directly.
16//
11//
17−// On Windows, we must download a file named elm.exe for it to run properly.
12+// This file pretends to be the downloaded binary. It then downloads
18−// Instead of symlinks, npm creates two files:
13+// the real binary over itself. So in that case, the first run would
19−//
14+// also make an HTTPS request to fetch the real binary.
20−// - node_modules/.bin/elm (a bash file)
21−// - node_modules/.bin/elm.cmd (a batch file)
22−//
23−// Both files specifically invoke `node` to run the file listed at package.bin,
24−// so there is no way around instantiating node for no reason on Windows. So
25−// the existsSync check is needed so that it is not downloaded more than once.
26
15
27
16
28−// figure out where to put the binary (calls path.resolve() to get path separators right on Windows)
29−//
30−var binaryPath = path.resolve(__dirname, 'elm') + (process.platform === 'win32' ? '.exe' : '');
31−
32−// Run the command directly if possible, otherwise download and then run.
33−// This check is important for Windows where this file will be run all the time.
34−//
35−if (process.platform === 'win32')
36−{
37− fs.existsSync(binaryPath)
38− ? runCommand()
39− : require('../download.js')(runCommand);
40−}
41−else
42−{
43− require('../download.js')(runCommand);
44−}
45
17
18+// Make sure we get the right path even if we're executing from the symlinked
19+// node_modules/.bin/ executable
20+var pathToThisFile = fs.realpathSync(process.argv[1]);
46
21
47−function runCommand()
22+download(pathToThisFile, function() {
48−{
49− // Need double quotes and { shell: true } when there are spaces in the path on windows:
23+ // Need double quotes and { shell: true } when there are spaces in the path on windows:
50− // https://github.com/nodejs/node/issues/7367#issuecomment-229721296
24+ // https://github.com/nodejs/node/issues/7367#issuecomment-229721296
51− child_process
25+ child_process
52− .spawn('"' + binaryPath + '"', process.argv.slice(2), { stdio: 'inherit', shell: true })
26+ .spawn('"' + pathToThisFile + '"', process.argv.slice(2), { stdio: 'inherit', shell: true })
53− .on('exit', process.exit);
27+ .on('exit', process.exit);
54−}
28+});
installers/npm/download.js+67−68
@@ -1,7 +1,7 @@
1var fs = require('fs');
1var fs = require('fs');
2var package = require('./package.json');
2var package = require('./package.json');
3−var path = require('path');
3+var URL = require('url').URL;
4−var request = require('request');
4+var https = require('https');
5var zlib = require('zlib');
5var zlib = require('zlib');
6
6
7
7
@@ -12,72 +12,87 @@ var zlib = require('zlib');
12// called when --ignore-scripts is enabled. That's why install.js is so weird.
12// called when --ignore-scripts is enabled. That's why install.js is so weird.
13
13
14
14
15−module.exports = function(callback)
15+module.exports = function(destinationPath, callback)
16{
16{
17− // figure out URL of binary
18 var version = package.version.replace(/^(\d+\.\d+\.\d+).*$/, '$1'); // turn '1.2.3-alpha' into '1.2.3'
17 var version = package.version.replace(/^(\d+\.\d+\.\d+).*$/, '$1'); // turn '1.2.3-alpha' into '1.2.3'
18+ var os = { 'darwin': 'mac', 'win32': 'windows', 'linux': 'linux' }[process.platform];
19+ var arch = { 'x64': '64-bit', 'ia32': '32-bit' }[process.arch];
19
20
20− var platform = {
21+ download(
21− darwin_x64: 'mac-64-bit',
22+ process.platform === 'win32' ? destinationPath + '.exe' : destinationPath,
22− darwin_arm64: 'mac-64-bit',
23− win32_x64: 'windows-64-bit',
24− linux_x64: 'linux-64-bit'
25− }[process.platform + '_' + process.arch];
26−
27− verifyPlatform(version, platform);
28−
29− var url = 'https://github.com/elm/compiler/releases/download/' + version + '/binary-for-' + platform + '.gz';
23+ 'https://github.com/elm/compiler/releases/download/' + version + '/binary-for-' + os + '-' + arch + '.gz',
24+ callback
25+ );
26+};
30
27
31− reportDownload(version, url);
32
28
33− // figure out where to put the binary (calls path.resolve() to get path separators right on Windows)
34− var binaryPath = path.resolve(__dirname, package.bin.elm) + (process.platform === 'win32' ? '.exe' : '');
35
29
36− // set up handler for request failure
30+// DOWNLOAD
37− function reportDownloadFailure(error)
38− {
39− exitFailure(url,'Something went wrong while fetching the following URL:\n\n' + url + '\n\nIt is saying:\n\n' + error);
40− }
41
31
42− // set up decompression pipe
43− var gunzip = zlib.createGunzip().on('error', function(error) {
44− exitFailure(url, 'I ran into trouble decompressing the downloaded binary. It is saying:\n\n' + error);
45− });
46
32
47− // set up file write pipe
33+function download(destinationPath, url, callback)
34+{
35+ requestWithRedirects(url, 10,
36+ function(error) {
37+ exitFailure(url, 'I ran into trouble while fetching ' + url + '\n\n' + error);
38+ },
39+ function(response) {
40+ if (response.statusCode == 404)
41+ {
42+ exitFailure(url, 'I got a "404 Not Found" trying to download from the following URL:\n'
43+ + url
44+ + '\n\nThis may mean you are trying to install on an unsupported platform. (e.g. some 32-bit systems?)'
45+ );
46+ }
47+
48+ response.on('error', function() {
49+ exitFailure(url, 'Something went wrong while receiving the following URL:\n\n' + url);
50+ });
51+
52+ var gunzip = zlib.createGunzip().on('error', function(error) {
53+ exitFailure(url, 'I ran into trouble decompressing the downloaded binary. It is saying:\n\n' + error);
54+ });
48− var write = fs.createWriteStream(binaryPath, {
55+ var write = fs.createWriteStream(destinationPath, {
49− encoding: 'binary',
56+ encoding: 'binary',
50− mode: 0o755
57+ mode: 0o755
51− }).on('finish', callback).on('error', function(error) {
58+ }).on('finish', callback).on('error', function(error) {
52− exitFailure(url, 'I had some trouble writing file to disk. It is saying:\n\n' + error);
59+ exitFailure(url, 'I had some trouble writing file to disk. It is saying:\n\n' + error);
53− });
60+ });
54−
61+
55− // put it all together
56− request(url).on('error', reportDownloadFailure).pipe(gunzip).pipe(write);
62+ response.pipe(gunzip).pipe(write);
63+ }
64+ );
57}
65}
58
66
59
67
60
68
61−// VERIFY PLATFORM
69+// HANDLE REDIRECTS
62
70
63
71
64−function verifyPlatform(version, platform)
72+function requestWithRedirects(url, maxRedirects, failure, success)
65{
73{
66− if (platform) return;
74+ var req = https.request(url);
75+
76+ req.on('response', function(response) {
77+ // Check for redirects
78+
79+ var redirectUrl = new URL(response.headers['location'], new URL(url).origin).href;
80+
81+ if (typeof redirectUrl === 'string' && response.statusCode >= 300 && response.statusCode < 400)
82+ {
83+ return (maxRedirects <= 0)
84+ ? failure(new Error('followed 10 redirects and gave up'))
85+ : requestWithRedirects(redirectUrl, maxRedirects - 1, failure, success);
86+ }
87+ else
88+ {
89+ return success(response);
90+ }
91+ });
67
92
68− var situation = process.platform + '_' + process.arch;
93+ req.on('error', failure);
69− console.error(
94+
70− '-- ERROR -----------------------------------------------------------------------\n\n'
95+ req.end();
71− + 'I am detecting that your computer (' + situation + ') may not be compatible with any\n'
72− + 'of the official pre-built binaries.\n\n'
73− + 'I recommend against using the npm installer for your situation. Check out the\n'
74− + 'alternative installers at https://github.com/elm/compiler/releases/tag/' + version + '\n'
75− + 'to see if there is something that will work better for you.\n\n'
76− + 'From there I recommend asking for guidance on Slack or Discourse to find someone\n'
77− + 'who can help with your specific situation.\n\n'
78− + '--------------------------------------------------------------------------------\n'
79− );
80− process.exit(1);
81}
96}
82
97
83
98
@@ -96,19 +111,3 @@ function exitFailure(url, message)
96 );
111 );
97 process.exit(1);
112 process.exit(1);
98}
113}
99−
100−
101−
102−// REPORT DOWNLOAD
103−
104−
105−function reportDownload(version, url)
106−{
107− console.log(
108− '--------------------------------------------------------------------------------\n\n'
109− + 'Downloading Elm ' + version + ' from GitHub.'
110− + '\n\nNOTE: You can avoid npm entirely by downloading directly from:\n'
111− + url + '\nAll this package does is download that file and put it somewhere.\n\n'
112− + '--------------------------------------------------------------------------------\n'
113− );
114−}
installers/npm/install.js+7−1
@@ -1,4 +1,10 @@
1
1
2var download = require('./download.js');
2var download = require('./download.js');
3+var package = require('./package.json');
4+var path = require('path');
3
5
6+
7+// get slashes right for Windows
8+var targetPath = path.resolve(__dirname, Object.values(package.bin)[0]);
9+
4−download(function() {});
10+download(targetPath, function() {});
installers/npm/package.json+7−6
@@ -1,6 +1,6 @@
1{
1{
2 "name": "elm",
2 "name": "elm",
3− "version": "0.19.1-5",
3+ "version": "0.19.0-no-deps",
4 "description": "Installer for Elm: just downloads the binary into node_modules",
4 "description": "Installer for Elm: just downloads the binary into node_modules",
5 "preferGlobal": true,
5 "preferGlobal": true,
6 "license": "BSD-3-Clause",
6 "license": "BSD-3-Clause",
@@ -11,9 +11,9 @@
11 "homepage": "https://github.com/elm/compiler/tree/master/installers/npm",
11 "homepage": "https://github.com/elm/compiler/tree/master/installers/npm",
12 "bugs": "https://github.com/elm/compiler/issues",
12 "bugs": "https://github.com/elm/compiler/issues",
13 "author": {
13 "author": {
14− "name": "Evan Czaplicki",
14+ "name": "Richard Feldman",
15− "email": "evan@elm-lang.org",
15+ "email": "richard.t.feldman@gmail.com",
16− "url": "https://github.com/evancz"
16+ "url": "https://github.com/rtfeldman"
17 },
17 },
18 "engines": {
18 "engines": {
19 "node": ">=7.0.0"
19 "node": ">=7.0.0"
@@ -35,8 +35,9 @@
35 "install",
35 "install",
36 "installer"
36 "installer"
37 ],
37 ],
38+ "bin": {
38− "bin": { "elm": "bin/elm" },
39+ "elm": "bin/elm"
40+ },
39 "dependencies": {
41 "dependencies": {
40− "request": "^2.88.0"
41 }
42 }
42}
43}
installers/npm/troubleshooting.mddeleted−76
@@ -1,76 +0,0 @@
1−# Troubleshooting
2−
3−I very highly recommend asking for help on [the Elm slack](https://elmlang.herokuapp.com).
4−
5−There are a lot of things that can go wrong when installing software, and it can really help to have a second pair of eyes on your situation!
6−
7−This document goes through a couple options that may help you out.
8−
9−<br/>
10−
11−
12−## Can you skip npm entirely?
13−
14−The most reliable way to get Elm installed using the official installers for Mac and Windows [here][download].
15−
16−You can also download the binaries directly. On Linux, you could do it in the terminal like this:
17−
18−```bash
19−cd ~/Desktop/
20−curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz
21−gunzip elm.gz # unzip the file
22−chmod +x elm # make the file executable
23−sudo mv elm /usr/local/bin/ # put the executable in a directory likely to be listed in your PATH variable
24−```
25−
26−If these exact commands do not work for you, you can try to do the same thing by hand.
27−
28−Read the section below on `PATH` variables if you are not sure what that is!
29−
30−[download]: https://github.com/elm/compiler/releases/tag/0.19.1
31−
32−<br/>
33−
34−
35−## Do you need to use npm for some reason?
36−
37−The company running npm has a list of common troubleshooting situations [here](https://npm.community/c/support/troubleshooting), but it may be better to just try to find your specific case on Stack Overflow. Often there are permissions issues where you may need to use `sudo` with some command.
38−
39−### Firewalls
40−
41−Some companies have a firewall.
42−
43−These companies usually have set the `HTTP_PROXY` or `HTTPS_PROXY` environment variable on your computer. This is more common with Windows computers.
44−
45−The result is that the request for `https://github.com/elm/compiler/releases/download/0.19.1/binary-for-windows-64-bit.gz` is being sent to a "proxy server" where they monitor traffic. Maybe they rule out certain domains, maybe they check data when it comes back from the actual URL, etc.
46−
47−It is probably best to ask someone about the situation on this, but you can test things out by temporarily using an alternate `HTTPS_PROXY` value with something like this:
48−
49−```
50−# Mac and Linux
51−HTTPS_PROXY=http://proxy.example.com npm install -g elm
52−
53−# Windows
54−set HTTPS_PROXY=http://proxy.example.com
55−npm install -g elm
56−```
57−
58−Check out [this document](https://www.npmjs.com/package/request#controlling-proxy-behaviour-using-environment-variables) for more information on how environment variables like `NO_PROXY`, `HTTP_PROXY`, and `HTTPS_PROXY` are handled by the npm.
59−
60−<br/>
61−
62−
63−## Do you know what a `PATH` variable is?
64−
65−When you run a command like `elm make src/Main.elm`, your computer starts by trying to find a file called `elm`.
66−
67−The `PATH` is a list of directories to search within. On Mac and Linux, you can see these directories by running:
68−
69−```
70−$ echo $PATH
71−/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin:/usr/local/git/bin
72−```
73−
74−The are separated by `:` for some reason. So running `elm make src/Main.elm` starts by searching the `PATH` for files named `elm`. On my computer, it finds `/usr/local/bin/elm` and then can actually run the command.
75−
76−Is `elm` in one of the directories listed in your `PATH` variable? I recommend asking for help if you are in this scenario and unsure how to proceed.
installers/win/Nsisfile.nsi+16−16
@@ -75,7 +75,7 @@ Function un.onInit
75FunctionEnd
75FunctionEnd
76
76
77Function LaunchLink
77Function LaunchLink
78− ExecShell "open" "https://guide.elm-lang.org"
78+ ExecShell "open" "http://elm-lang.org/get-started"
79FunctionEnd
79FunctionEnd
80
80
81;--------------------------------
81;--------------------------------
@@ -135,20 +135,20 @@ SectionEnd
135
135
136SectionGroup "Update system settings" SecGr
136SectionGroup "Update system settings" SecGr
137
137
138−;Section "Associate with .elm files" SecAssoc
138+Section "Associate with .elm files" SecAssoc
139−;
139+
140−; SectionIn 1
140+ SectionIn 1
141−;
141+
142−; ; File associations
142+ ; File associations
143−; WriteRegStr HKCR ".elm" "" "elm"
143+ WriteRegStr HKCR ".elm" "" "elm"
144−; WriteRegStr HKCR "elm" "" "Elm Source File"
144+ WriteRegStr HKCR "elm" "" "Elm Source File"
145−; WriteRegStr HKCR "elm\DefaultIcon" "" "$INSTDIR\file.ico"
145+ WriteRegStr HKCR "elm\DefaultIcon" "" "$INSTDIR\file.ico"
146−; WriteRegStr HKCR "elm\shell\open\command" "" '"$INSTDIR\bin\elm.exe" "%1"'
146+ ;WriteRegStr HKCR "elm\shell\open\command" "" '"$INSTDIR\bin\elm.exe" "%1"'
147−;
147+
148−; ;Remember that we registered associations
148+ ;Remember that we registered associations
149−; WriteRegDWORD HKLM "${PRODUCT_DIR_REG_KEY}" Assocs 0x1
149+ WriteRegDWORD HKLM "${PRODUCT_DIR_REG_KEY}" Assocs 0x1
150−;
150+
151−;SectionEnd
151+SectionEnd
152
152
153Section "Update the PATH environment variable" SecPath
153Section "Update the PATH environment variable" SecPath
154
154
@@ -261,4 +261,4 @@ Section "Uninstall"
261 ; Update environment variables
261 ; Update environment variables
262 SendMessage ${HWND_BROADCAST} ${WM_SETTINGCHANGE} 0 "STR:Environment" /TIMEOUT=5000
262 SendMessage ${HWND_BROADCAST} ${WM_SETTINGCHANGE} 0 "STR:Environment" /TIMEOUT=5000
263
263
264−SectionEnd
264+SectionEnd
installers/win/README.md+3−18
@@ -1,24 +1,9 @@
1−# Installing on Windows
2−
3−The installer for Windows is available [here](https://guide.elm-lang.org/install.html).
4−
5−
6−<br/>
7−
8−## Uninstall
9−
10−First run the `C:\Program Files (x86)\Elm\0.19\uninstall.exe` file. This will remove Elm stuff from your `PATH`.
11−
12−Then remove the whole `C:\Users\<username>\AppData\Roaming\elm` directory. Elm caches some packages and build artifacts to reduce compile times and to help you work offline. Getting rid of this directory will clear that information out!
13−
14−<br/>
15−
16−## Building the Windows installer
1+# Building Windows installer
17
2
18You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed.
3You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed.
19
4
20Once everything is installed, run something like this command:
5Once everything is installed, run something like this command:
21
6
22− make_installer.cmd 0.19.0
7+ make_installer.cmd 0.19
23
8
24−It will build an installer called `Elm-0.19.0-setup.exe`.
9+It will build an installer called `Elm-0.19-setup.exe`.
installers/win/file.iconew file

Binary file not shown.

installers/win/inst.dat+2−1
@@ -2,5 +2,6 @@ SetOutPath "$INSTDIR\bin"
2File "${FILES_SOURCE_PATH}\bin\elm.exe"
2File "${FILES_SOURCE_PATH}\bin\elm.exe"
3
3
4SetOutPath "$INSTDIR"
4SetOutPath "$INSTDIR"
5+File "file.ico"
5File "updatepath.vbs"
6File "updatepath.vbs"
6−File "removefrompath.vbs"
7+File "removefrompath.vbs"
installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+2−1
@@ -1,6 +1,7 @@
1Delete "$INSTDIR\bin\elm.exe"
1Delete "$INSTDIR\bin\elm.exe"
2RmDir "$INSTDIR\bin"
2RmDir "$INSTDIR\bin"
3
3
4+Delete "$INSTDIR\file.ico"
4Delete "$INSTDIR\updatepath.vbs"
5Delete "$INSTDIR\updatepath.vbs"
5Delete "$INSTDIR\removefrompath.vbs"
6Delete "$INSTDIR\removefrompath.vbs"
6−RmDir "$INSTDIR"
7+RmDir "$INSTDIR"
installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifnew file

Binary file not shown.

reactor/elm.json+2−2
@@ -3,7 +3,7 @@
3 "source-directories": [
3 "source-directories": [
4 "src"
4 "src"
5 ],
5 ],
6− "elm-version": "0.19.1",
6+ "elm-version": "0.19.0",
7 "dependencies": {
7 "dependencies": {
8 "direct": {
8 "direct": {
9 "elm/browser": "1.0.1",
9 "elm/browser": "1.0.1",
@@ -28,4 +28,4 @@
28 "direct": {},
28 "direct": {},
29 "indirect": {}
29 "indirect": {}
30 }
30 }
31−}
31+}
reactor/src/Index.elm+15−20
@@ -64,7 +64,7 @@ decoder =
64 (D.field "dirs" (D.list D.string))
64 (D.field "dirs" (D.list D.string))
65 (D.field "files" (D.list fileDecoder))
65 (D.field "files" (D.list fileDecoder))
66 (D.field "readme" (D.nullable D.string))
66 (D.field "readme" (D.nullable D.string))
67− (D.field "outline" (D.nullable Project.decoder))
67+ (D.field "project" (D.nullable Project.decoder))
68 (D.field "exactDeps" (D.dict Version.decoder))
68 (D.field "exactDeps" (D.dict Version.decoder))
69
69
70
70
@@ -219,10 +219,10 @@ viewDeps exactDeps project =
219 dependencies =
219 dependencies =
220 case project of
220 case project of
221 Project.Application info ->
221 Project.Application info ->
222− List.map viewVersion info.depsDirect
222+ List.map (viewDependency exactDeps) info.depsDirect
223
223
224 Project.Package info ->
224 Project.Package info ->
225− List.map (viewConstraint exactDeps) info.deps
225+ List.map (viewDependency exactDeps) info.deps
226 in
226 in
227 Skeleton.box
227 Skeleton.box
228 { title = "Dependencies"
228 { title = "Dependencies"
@@ -237,10 +237,10 @@ viewTestDeps exactDeps project =
237 dependencies =
237 dependencies =
238 case project of
238 case project of
239 Project.Application info ->
239 Project.Application info ->
240− List.map viewVersion info.testDepsDirect
240+ List.map (viewDependency exactDeps) info.testDepsDirect
241
241
242 Project.Package info ->
242 Project.Package info ->
243− List.map (viewConstraint exactDeps) info.testDeps
243+ List.map (viewDependency exactDeps) info.testDeps
244 in
244 in
245 Skeleton.box
245 Skeleton.box
246 { title = "Test Dependencies"
246 { title = "Test Dependencies"
@@ -249,22 +249,9 @@ viewTestDeps exactDeps project =
249 }
249 }
250
250
251
251
252−viewVersion : (Package.Name, Version.Version) -> List (Html msg)
253−viewVersion (pkg, version) =
254− [ div [ style "float" "left" ]
255− [ Icon.package
256− , a [ href (toPackageUrl pkg version) ] [ text (Package.toString pkg) ]
257− ]
258− , div [ style "float" "right" ] [ text (Version.toString version) ]
259− ]
260−
261−
262−viewConstraint : ExactDeps -> (Package.Name, constraint) -> List (Html msg)
252+viewDependency : ExactDeps -> (Package.Name, vsn) -> List (Html msg)
263−viewConstraint exactDeps (pkg, _) =
253+viewDependency exactDeps (pkg, _) =
264 case Dict.get (Package.toString pkg) exactDeps of
254 case Dict.get (Package.toString pkg) exactDeps of
265− Just vsn ->
266− viewVersion (pkg, vsn)
267−
268 Nothing ->
255 Nothing ->
269 [ div [ style "float" "left" ]
256 [ div [ style "float" "left" ]
270 [ Icon.package
257 [ Icon.package
@@ -273,6 +260,14 @@ viewConstraint exactDeps (pkg, _) =
273 , div [ style "float" "right" ] [ text "???" ]
260 , div [ style "float" "right" ] [ text "???" ]
274 ]
261 ]
275
262
263+ Just version ->
264+ [ div [ style "float" "left" ]
265+ [ Icon.package
266+ , a [ href (toPackageUrl pkg version) ] [ text (Package.toString pkg) ]
267+ ]
268+ , div [ style "float" "right" ] [ text (Version.toString version) ]
269+ ]
270+
276
271
277toPackageUrl : Package.Name -> Version.Version -> String
272toPackageUrl : Package.Name -> Version.Version -> String
278toPackageUrl name version =
273toPackageUrl name version =
reactor/src/Index/Navigator.elm+1−1
@@ -19,7 +19,7 @@ view root dirs =
19 , style "align-items" "center"
19 , style "align-items" "center"
20 , style "height" "40px"
20 , style "height" "40px"
21 ]
21 ]
22− (makeLinks root dirs "" [])
22+ (makeLinks root dirs "/" [])
23
23
24
24
25makeLinks : String -> List String -> String -> List (Html msg) -> List (Html msg)
25makeLinks : String -> List String -> String -> List (Html msg) -> List (Html msg)
roadmap.mddeleted−29
@@ -1,29 +0,0 @@
1−# Roadmap
2−
3−If you like what you see now, that's pretty much what Elm is going to be for a while.
4−
5−I'm currently doing some exploratory work with compiler techniques and targets, but it is still too early to tell which parts of that might work out. I know many readers take "exploring X" as a promise that "X will definitely happen", so I want to be careful in setting expectations low since there is still so much uncertainty in the work. So while there is no real news to share at this point, I can give some expectations about future stability of Elm:
6−
7−**If this exploratory work goes well**, even in the wildest version of success, I wouldn't expect the language or core packages to change very much. Maybe two or three years down the line it could reveal something that'd be good to fix up, but I don't really foresee notable changes right now.
8−
9−**If this exploratory work does not work out**, I have some more conservative projects that are good ideas that I want to circle back to at some point. Things like:
10−
11−- add a constrained type variable `eq` to get rid of the runtime error for `(==)` on functions
12−- try to integrate `elm test` so it can run only tests that changed
13−- try to get `elm format` using the latest parsing infrastructure so it's not a perf bottleneck during development anymore
14−- do another round on perf because I have one last idea that can squeeze out a bit more speed
15−
16−These are all nice quality of life things, but with 0.19.0 and 0.19.1 taking so long, I got pretty burnt out on "incremental improvements that are good ideas, but take a very long time and aren't very exciting to non-Elm users." Without getting too into the details, I really needed to change things up before returning to these particular ideas.
17−
18−If someone has a security issue from the compiler or core libraries, please DM me about it on the Elm Slack. Outside of security issues, I think capacity for more discretionary changes will increase once the lessons from the compiler explorations become more clear. Hopefully the discussion [here](https://discourse.elm-lang.org/t/costs-funding-in-open-source-languages/5722) clarifies the thinking on these capacity questions a bit.
19−
20−<br>
21−<br>
22−
23−**Taking a step back**, I have found that working in this looser style has produced a high baseline of quality, and I think that is an important part of Elm. For example, all the error message work in Elm began as a project to implement the `--report=json` flag. That work happened to reveal some cool ideas on improving error messages, and if I had been using a rigid roadmap, I might have skipped those ideas to meet the publicly-stated arbitrary deadline. We'd have a clearer roadmap, but error messages no different than other type-inferred languages.
24−
25−So I think having more flexibility in planning is a competitive advantage for Elm in certain ways, but it is obviously a trade off that does not work for everyone. If someone needs more certainty, I generally recommend looking into other languages to see if they have a balance that works better for their needs. For example, languages made by big corporations are generally "less risky" on things like this, but I think you see the fruits of that kind of process in the design decisions as well. Trade offs!
26−
27−Anyway, like I said at the beginning, if you like what you see now, that's what it's going to be for a while. Even in the best case scenario with my current explorations!
28−
29−I hope this is helpful information, and I hope you have a good experience with Elm, even if you ultimately find a different language that works better for you!
terminal/src/Bump.hs+29−43
@@ -6,15 +6,11 @@ module Bump
6
6
7
7
8import qualified Data.List as List
8import qualified Data.List as List
9−import qualified Data.NonEmptyList as NE
10
9
11−import qualified BackgroundWriter as BW
12−import qualified Build
13import qualified Deps.Bump as Bump
10import qualified Deps.Bump as Bump
14import qualified Deps.Diff as Diff
11import qualified Deps.Diff as Diff
15import qualified Deps.Registry as Registry
12import qualified Deps.Registry as Registry
16import qualified Elm.Details as Details
13import qualified Elm.Details as Details
17−import qualified Elm.Docs as Docs
18import qualified Elm.Magnitude as M
14import qualified Elm.Magnitude as M
19import qualified Elm.Outline as Outline
15import qualified Elm.Outline as Outline
20import qualified Elm.Version as V
16import qualified Elm.Version as V
@@ -48,7 +44,7 @@ data Env =
48 , _cache :: Stuff.PackageCache
44 , _cache :: Stuff.PackageCache
49 , _manager :: Http.Manager
45 , _manager :: Http.Manager
50 , _registry :: Registry.Registry
46 , _registry :: Registry.Registry
51− , _outline :: Outline.PkgOutline
47+ , _outline :: Outline.Outline
52 }
48 }
53
49
54
50
@@ -63,13 +59,13 @@ getEnv =
63 do cache <- Task.io $ Stuff.getPackageCache
59 do cache <- Task.io $ Stuff.getPackageCache
64 manager <- Task.io $ Http.getManager
60 manager <- Task.io $ Http.getManager
65 registry <- Task.eio Exit.BumpMustHaveLatestRegistry $ Registry.latest manager cache
61 registry <- Task.eio Exit.BumpMustHaveLatestRegistry $ Registry.latest manager cache
66− outline <- Task.eio Exit.BumpBadOutline $ Outline.read root
62+ outlineResult <- Task.io $ Outline.read root
67− case outline of
63+ case outlineResult of
68− Outline.App _ ->
64+ Right outline ->
69− Task.throw Exit.BumpApplication
65+ return $ Env root cache manager registry outline
70
66
71− Outline.Pkg pkgOutline ->
67+ Left problem ->
72− return $ Env root cache manager registry pkgOutline
68+ Task.throw $ Exit.BumpBadOutline problem
73
69
74
70
75
71
@@ -77,21 +73,26 @@ getEnv =
77
73
78
74
79bump :: Env -> Task.Task Exit.Bump ()
75bump :: Env -> Task.Task Exit.Bump ()
80−bump env@(Env root _ _ registry outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
76+bump env@(Env root _ _ registry outline) =
77+ case outline of
78+ Outline.App _ ->
79+ Task.throw Exit.BumpApplication
80+
81+ Outline.Pkg pkgOutline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _) ->
81− case Registry.getVersions pkg registry of
82+ case Registry.getVersions pkg registry of
82− Just knownVersions ->
83+ Just knownVersions ->
83− let
84+ let
84− bumpableVersions =
85+ bumpableVersions =
85− map (\(old, _, _) -> old) (Bump.getPossibilities knownVersions)
86+ map (\(old, _, _) -> old) (Bump.getPossibilities knownVersions)
86− in
87+ in
87− if elem vsn bumpableVersions
88+ if elem vsn bumpableVersions
88− then suggestVersion env
89+ then suggestVersion env pkgOutline
89− else
90+ else
90− Task.throw $ Exit.BumpUnexpectedVersion vsn $
91+ Task.throw $ Exit.BumpUnexpectedVersion vsn $
91− map head (List.group (List.sort bumpableVersions))
92+ map head (List.group (List.sort bumpableVersions))
92
93
93− Nothing ->
94+ Nothing ->
94− Task.io $ checkNewPackage root outline
95+ Task.io $ checkNewPackage root pkgOutline
95
96
96
97
97
98
@@ -115,10 +116,10 @@ checkNewPackage root outline@(Outline.PkgOutline _ _ _ version _ _ _ _) =
115-- SUGGEST VERSION
116-- SUGGEST VERSION
116
117
117
118
118−suggestVersion :: Env -> Task.Task Exit.Bump ()
119+suggestVersion :: Env -> Outline.PkgOutline -> Task.Task Exit.Bump ()
119−suggestVersion (Env root cache manager _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
120+suggestVersion (Env root cache manager _ _) outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _) =
120 do oldDocs <- Task.eio (Exit.BumpCannotFindDocs pkg vsn) (Diff.getDocs cache manager pkg vsn)
121 do oldDocs <- Task.eio (Exit.BumpCannotFindDocs pkg vsn) (Diff.getDocs cache manager pkg vsn)
121− newDocs <- generateDocs root outline
122+ newDocs <- error "TODO Outline.generateDocs summary"
122 let changes = Diff.diff oldDocs newDocs
123 let changes = Diff.diff oldDocs newDocs
123 let newVersion = Diff.bump changes vsn
124 let newVersion = Diff.bump changes vsn
124 Task.io $ changeVersion root outline newVersion $
125 Task.io $ changeVersion root outline newVersion $
@@ -133,21 +134,6 @@ suggestVersion (Env root cache manager _ outline@(Outline.PkgOutline pkg _ _ vsn
133 <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
134 <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
134
135
135
136
136−generateDocs :: FilePath -> Outline.PkgOutline -> Task.Task Exit.Bump Docs.Documentation
137−generateDocs root (Outline.PkgOutline _ _ _ _ exposed _ _ _) =
138− do details <-
139− Task.eio Exit.BumpBadDetails $ BW.withScope $ \scope ->
140− Details.load Reporting.silent scope root
141−
142− case Outline.flattenExposed exposed of
143− [] ->
144− Task.throw $ Exit.BumpNoExposed
145−
146− e:es ->
147− Task.eio Exit.BumpBadBuild $
148− Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)
149−
150−
151
137
152-- CHANGE VERSION
138-- CHANGE VERSION
153
139
terminal/src/Develop.hs+77−70
@@ -7,31 +7,27 @@ module Develop
7
7
8
8
9import Control.Applicative ((<|>))
9import Control.Applicative ((<|>))
10+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
10−import Control.Monad (guard)
11+import Control.Monad (guard, void)
11import Control.Monad.Trans (MonadIO(liftIO))
12import Control.Monad.Trans (MonadIO(liftIO))
12import qualified Data.ByteString.Builder as B
13import qualified Data.ByteString.Builder as B
13import qualified Data.ByteString as BS
14import qualified Data.ByteString as BS
14import qualified Data.HashMap.Strict as HashMap
15import qualified Data.HashMap.Strict as HashMap
15import Data.Monoid ((<>))
16import Data.Monoid ((<>))
16−import qualified Data.NonEmptyList as NE
17import qualified System.Directory as Dir
17import qualified System.Directory as Dir
18import System.FilePath as FP
18import System.FilePath as FP
19−import Snap.Core hiding (path)
19+import Snap.Core
20import Snap.Http.Server
20import Snap.Http.Server
21import Snap.Util.FileServe
21import Snap.Util.FileServe
22
22
23−import qualified BackgroundWriter as BW
23+import qualified Elm.Project as Project
24−import qualified Build
25−import qualified Elm.Details as Details
26−import qualified Develop.Generate.Help as Help
24+import qualified Develop.Generate.Help as Generate
27import qualified Develop.Generate.Index as Index
25import qualified Develop.Generate.Index as Index
28import qualified Develop.StaticFiles as StaticFiles
26import qualified Develop.StaticFiles as StaticFiles
29−import qualified Generate.Html as Html
27+import qualified Generate.Output as Output
30−import qualified Generate
31−import qualified Reporting
32import qualified Reporting.Exit as Exit
28import qualified Reporting.Exit as Exit
29+import qualified Reporting.Progress as Progress
33import qualified Reporting.Task as Task
30import qualified Reporting.Task as Task
34−import qualified Stuff
35
31
36
32
37
33
@@ -46,19 +42,31 @@ data Flags =
46
42
47run :: () -> Flags -> IO ()
43run :: () -> Flags -> IO ()
48run () (Flags maybePort) =
44run () (Flags maybePort) =
45+ let
46+ port =
49− do let port = maybe 8000 id maybePort
47+ maybe 8000 id maybePort
48+ in
50− putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard."
49+ do putStrLn $ "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."
50+
51− httpServe (config port) $
51+ httpServe (config port) $
52− serveFiles
52+ serveFiles
53− <|> serveDirectoryWith directoryConfig "."
53+ <|> serveDirectoryWith directoryConfig "."
54− <|> serveAssets
54+ <|> serveAssets
55− <|> error404
55+ <|> error404
56
56
57
57
58config :: Int -> Config Snap a
58config :: Int -> Config Snap a
59config port =
59config port =
60+ defaultConfig
60− setVerbose False $ setPort port $
61+ # setVerbose False
62+ # setPort port
61− setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
63+ # setAccessLog ConfigNoLog
64+ # setErrorLog ConfigNoLog
65+
66+
67+(#) :: a -> (a -> b) -> b
68+(#) value func =
69+ func value
62
70
63
71
64
72
@@ -67,12 +75,18 @@ config port =
67
75
68directoryConfig :: MonadSnap m => DirectoryConfig m
76directoryConfig :: MonadSnap m => DirectoryConfig m
69directoryConfig =
77directoryConfig =
70− fancyDirectoryConfig
78+ let
71− { indexFiles = []
79+ customGenerator pwd =
72− , indexGenerator = \pwd ->
73− do modifyResponse $ setContentType "text/html;charset=utf-8"
80+ do modifyResponse $ setContentType "text/html; charset=utf-8"
74− writeBuilder =<< liftIO (Index.generate pwd)
81+ html <- liftIO $
82+ do root <- Dir.getCurrentDirectory
83+ Index.get root pwd
84+ writeBuilder html
85+ in
86+ fancyDirectoryConfig
87+ { indexFiles = []
88+ , indexGenerator = customGenerator
75− }
89+ }
76
90
77
91
78
92
@@ -82,8 +96,8 @@ directoryConfig =
82error404 :: Snap ()
96error404 :: Snap ()
83error404 =
97error404 =
84 do modifyResponse $ setResponseStatus 404 "Not Found"
98 do modifyResponse $ setResponseStatus 404 "Not Found"
85− modifyResponse $ setContentType "text/html;charset=utf-8"
99+ modifyResponse $ setContentType "text/html; charset=utf-8"
86− writeBuilder $ Help.makePageHtml "NotFound" Nothing
100+ writeBuilder $ Generate.makePageHtml "NotFound" Nothing
87
101
88
102
89
103
@@ -92,9 +106,9 @@ error404 =
92
106
93serveFiles :: Snap ()
107serveFiles :: Snap ()
94serveFiles =
108serveFiles =
95− do path <- getSafePath
109+ do file <- getSafePath
96− guard =<< liftIO (Dir.doesFileExist path)
110+ guard =<< liftIO (Dir.doesFileExist file)
97− serveElm path <|> serveFilePretty path
111+ serveElm file <|> serveFilePretty file
98
112
99
113
100
114
@@ -102,33 +116,34 @@ serveFiles =
102
116
103
117
104serveFilePretty :: FilePath -> Snap ()
118serveFilePretty :: FilePath -> Snap ()
105−serveFilePretty path =
119+serveFilePretty file =
106 let
120 let
107 possibleExtensions =
121 possibleExtensions =
108− getSubExts (takeExtensions path)
122+ getSubExts (takeExtensions file)
109 in
123 in
110 case mconcat (map lookupMimeType possibleExtensions) of
124 case mconcat (map lookupMimeType possibleExtensions) of
111 Nothing ->
125 Nothing ->
112− serveCode path
126+ serveCode file
113
127
114 Just mimeType ->
128 Just mimeType ->
115− serveFileAs mimeType path
129+ serveFileAs mimeType file
116
130
117
131
118getSubExts :: String -> [String]
132getSubExts :: String -> [String]
119getSubExts fullExtension =
133getSubExts fullExtension =
120 if null fullExtension then
134 if null fullExtension then
121 []
135 []
136+
122 else
137 else
123 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
138 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
124
139
125
140
126serveCode :: String -> Snap ()
141serveCode :: String -> Snap ()
127−serveCode path =
142+serveCode file =
128− do code <- liftIO (BS.readFile path)
143+ do code <- liftIO (BS.readFile file)
129 modifyResponse (setContentType "text/html")
144 modifyResponse (setContentType "text/html")
130 writeBuilder $
145 writeBuilder $
131− Help.makeCodeHtml ('~' : '/' : path) (B.byteString code)
146+ Generate.makeCodeHtml ('~' : '/' : file) (B.byteString code)
132
147
133
148
134
149
@@ -136,33 +151,31 @@ serveCode path =
136
151
137
152
138serveElm :: FilePath -> Snap ()
153serveElm :: FilePath -> Snap ()
139−serveElm path =
154+serveElm file =
140− do guard (takeExtension path == ".elm")
155+ do guard (takeExtension file == ".elm")
141 modifyResponse (setContentType "text/html")
156 modifyResponse (setContentType "text/html")
142− result <- liftIO $ compile path
157+ writeBuilder =<< liftIO (compileToHtmlBuilder file)
143− case result of
144− Right builder ->
145− writeBuilder builder
146
158
147− Left exit ->
148− writeBuilder $ Help.makePageHtml "Errors" $ Just $
149− Exit.toJson $ Exit.reactorToReport exit
150
159
160+compileToHtmlBuilder :: FilePath -> IO B.Builder
161+compileToHtmlBuilder file =
162+ do mvar1 <- newEmptyMVar
163+ mvar2 <- newEmptyMVar
151
164
152−compile :: FilePath -> IO (Either Exit.Reactor B.Builder)
165+ let reporter = Progress.Reporter (\_ -> return ()) (\_ -> return True) (putMVar mvar1)
153−compile path =
166+ let output = Just (Output.HtmlBuilder mvar2)
154− do maybeRoot <- Stuff.findRoot
167+
155− case maybeRoot of
168+ void $ Task.try reporter $
156− Nothing ->
169+ do summary <- Project.getRoot
157− return $ Left $ Exit.ReactorNoOutline
170+ Project.compile Output.Dev Output.Client output summary [file]
158
171
159− Just root ->
172+ result <- takeMVar mvar1
160− BW.withScope $ \scope -> Stuff.withRootLock root $ Task.run $
173+ case result of
161− do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root
174+ Just exit ->
162− artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details (NE.List path [])
175+ return $ Generate.makePageHtml "Errors" (Just (Exit.toJson exit))
163− javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts
176+
164− let (NE.List name _) = Build.getRootNames artifacts
177+ Nothing ->
165− return $ Html.sandwich name javascript
178+ takeMVar mvar2
166
179
167
180
168
181
@@ -171,8 +184,8 @@ compile path =
171
184
172serveAssets :: Snap ()
185serveAssets :: Snap ()
173serveAssets =
186serveAssets =
174− do path <- getSafePath
187+ do file <- getSafePath
175− case StaticFiles.lookup path of
188+ case StaticFiles.lookup file of
176 Nothing ->
189 Nothing ->
177 pass
190 pass
178
191
@@ -218,16 +231,13 @@ mimeTypeDict =
218 , ".m3u" ==> "audio/x-mpegurl"
231 , ".m3u" ==> "audio/x-mpegurl"
219 , ".mov" ==> "video/quicktime"
232 , ".mov" ==> "video/quicktime"
220 , ".mp3" ==> "audio/mpeg"
233 , ".mp3" ==> "audio/mpeg"
221− , ".mp4" ==> "video/mp4"
222 , ".mpeg" ==> "video/mpeg"
234 , ".mpeg" ==> "video/mpeg"
223 , ".mpg" ==> "video/mpeg"
235 , ".mpg" ==> "video/mpeg"
224 , ".ogg" ==> "application/ogg"
236 , ".ogg" ==> "application/ogg"
225− , ".otf" ==> "font/otf"
226 , ".pac" ==> "application/x-ns-proxy-autoconfig"
237 , ".pac" ==> "application/x-ns-proxy-autoconfig"
227 , ".pdf" ==> "application/pdf"
238 , ".pdf" ==> "application/pdf"
228 , ".png" ==> "image/png"
239 , ".png" ==> "image/png"
229 , ".qt" ==> "video/quicktime"
240 , ".qt" ==> "video/quicktime"
230− , ".sfnt" ==> "font/sfnt"
231 , ".sig" ==> "application/pgp-signature"
241 , ".sig" ==> "application/pgp-signature"
232 , ".spl" ==> "application/futuresplash"
242 , ".spl" ==> "application/futuresplash"
233 , ".svg" ==> "image/svg+xml"
243 , ".svg" ==> "image/svg+xml"
@@ -238,19 +248,16 @@ mimeTypeDict =
238 , ".tbz" ==> "application/x-bzip-compressed-tar"
248 , ".tbz" ==> "application/x-bzip-compressed-tar"
239 , ".text" ==> "text/plain"
249 , ".text" ==> "text/plain"
240 , ".tgz" ==> "application/x-tgz"
250 , ".tgz" ==> "application/x-tgz"
241− , ".ttf" ==> "font/ttf"
251+ , ".ttf" ==> "application/x-font-truetype"
242 , ".txt" ==> "text/plain"
252 , ".txt" ==> "text/plain"
243 , ".wav" ==> "audio/x-wav"
253 , ".wav" ==> "audio/x-wav"
244 , ".wax" ==> "audio/x-ms-wax"
254 , ".wax" ==> "audio/x-ms-wax"
245− , ".webm" ==> "video/webm"
246− , ".webp" ==> "image/webp"
247 , ".wma" ==> "audio/x-ms-wma"
255 , ".wma" ==> "audio/x-ms-wma"
248 , ".wmv" ==> "video/x-ms-wmv"
256 , ".wmv" ==> "video/x-ms-wmv"
249− , ".woff" ==> "font/woff"
250− , ".woff2" ==> "font/woff2"
251 , ".xbm" ==> "image/x-xbitmap"
257 , ".xbm" ==> "image/x-xbitmap"
252 , ".xml" ==> "text/xml"
258 , ".xml" ==> "text/xml"
253 , ".xpm" ==> "image/x-xpixmap"
259 , ".xpm" ==> "image/x-xpixmap"
254 , ".xwd" ==> "image/x-xwindowdump"
260 , ".xwd" ==> "image/x-xwindowdump"
255 , ".zip" ==> "application/zip"
261 , ".zip" ==> "application/zip"
256 ]
262 ]
263+
terminal/src/Develop/Generate/Index.hs+74−149
@@ -1,37 +1,36 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Develop.Generate.Index
3module Develop.Generate.Index
4− ( generate
4+ ( get
5 )
5 )
6 where
6 where
7
7
8
8
9import Control.Monad (filterM)
9import Control.Monad (filterM)
10import qualified Data.ByteString.Builder as B
10import qualified Data.ByteString.Builder as B
11−import qualified Data.List as List
12import qualified Data.Map as Map
11import qualified Data.Map as Map
12+import qualified Data.Text as Text
13+import qualified Data.Text.IO as Text
13import qualified System.Directory as Dir
14import qualified System.Directory as Dir
14import System.FilePath ((</>), splitDirectories, takeExtension)
15import System.FilePath ((</>), splitDirectories, takeExtension)
15
16
16−import qualified BackgroundWriter as BW
17import qualified Develop.Generate.Help as Help
17import qualified Develop.Generate.Help as Help
18−import qualified Elm.Details as Details
19−import qualified Elm.Outline as Outline
20import qualified Elm.Package as Pkg
18import qualified Elm.Package as Pkg
21−import qualified Elm.Version as V
19+import qualified Elm.Project.Json as Project
20+import qualified Elm.Project.Summary as Summary
22import qualified Json.Encode as E
21import qualified Json.Encode as E
23−import Json.Encode ((==>))
22+import qualified Reporting.Progress as Progress
24−import qualified Reporting
23+import qualified Reporting.Task as Task
25−import qualified Stuff
24+import qualified Stuff.Verify as Verify
26
25
27
26
28
27
29−-- GENERATE
28+-- GET
30
29
31
30
32−generate :: FilePath -> IO B.Builder
31+get :: FilePath -> FilePath -> IO B.Builder
33−generate pwd =
32+get root pwd =
34− do flags <- getFlags pwd
33+ do flags <- getFlags root pwd
35 return $ Help.makePageHtml "Index" (Just (encode flags))
34 return $ Help.makePageHtml "Index" (Just (encode flags))
36
35
37
36
@@ -44,33 +43,60 @@ data Flags =
44 { _root :: FilePath
43 { _root :: FilePath
45 , _pwd :: [String]
44 , _pwd :: [String]
46 , _dirs :: [FilePath]
45 , _dirs :: [FilePath]
47− , _files :: [File]
46+ , _files :: [(FilePath, Bool)]
48− , _readme :: Maybe String
47+ , _readme :: Maybe Text.Text
49− , _outline :: Maybe Outline.Outline
48+ , _project :: Maybe Project.Project
50− , _exactDeps :: Map.Map Pkg.Name V.Version
49+ , _exactDeps :: Map.Map Pkg.Name Pkg.Version
51 }
50 }
52
51
53
52
54−data File =
53+
55− File
54+-- JSON
56− { _path :: FilePath
55+
57− , _runnable :: Bool
56+
58− }
57+encode :: Flags -> E.Value
58+encode (Flags root pwd dirs files readme project exactDeps) =
59+ E.object
60+ [ ( "root", encodeFilePath root )
61+ , ( "pwd", E.list encodeFilePath pwd )
62+ , ( "dirs", E.list encodeFilePath dirs )
63+ , ( "files", E.list encodeFile files )
64+ , ( "readme", maybe E.null E.text readme )
65+ , ( "project", maybe E.null Project.encode project )
66+ , ( "exactDeps", E.dict Pkg.toText Pkg.encodeVersion exactDeps)
67+ ]
68+
69+
70+encodeFilePath :: FilePath -> E.Value
71+encodeFilePath filePath =
72+ E.text (Text.pack filePath)
73+
74+
75+encodeFile :: (FilePath, Bool) -> E.Value
76+encodeFile (file, hasMain) =
77+ E.object
78+ [ ("name", encodeFilePath file)
79+ , ("runnable", E.bool hasMain)
80+ ]
59
81
60
82
61
83
62-- GET FLAGS
84-- GET FLAGS
63
85
64
86
65−getFlags :: FilePath -> IO Flags
87+getFlags :: FilePath -> FilePath -> IO Flags
66−getFlags pwd =
88+getFlags root pwd =
67− do contents <- Dir.getDirectoryContents pwd
89+ do (dirs, files) <- getDirsAndFiles pwd
68− root <- Dir.getCurrentDirectory
69− dirs <- getDirs pwd contents
70− files <- getFiles pwd contents
71 readme <- getReadme pwd
90 readme <- getReadme pwd
72− outline <- getOutline
91+ exists <- Dir.doesFileExist (root </> "elm.json")
73− exactDeps <- getExactDeps outline
92+
93+ maybeSummary <-
94+ if exists then
95+ Task.try Progress.silentReporter $
96+ Verify.verify root =<< Project.read (root </> "elm.json")
97+ else
98+ return Nothing
99+
74 return $
100 return $
75 Flags
101 Flags
76 { _root = root
102 { _root = root
@@ -78,136 +104,35 @@ getFlags pwd =
78 , _dirs = dirs
104 , _dirs = dirs
79 , _files = files
105 , _files = files
80 , _readme = readme
106 , _readme = readme
81− , _outline = outline
107+ , _project = fmap Summary._project maybeSummary
82− , _exactDeps = exactDeps
108+ , _exactDeps = maybe Map.empty (Map.map fst . Summary._depsGraph) maybeSummary
83 }
109 }
84
110
85
111
86−
87−-- README
88−
89−
90−getReadme :: FilePath -> IO (Maybe String)
112+getReadme :: FilePath -> IO (Maybe Text.Text)
91getReadme dir =
113getReadme dir =
92 do let readmePath = dir </> "README.md"
114 do let readmePath = dir </> "README.md"
93 exists <- Dir.doesFileExist readmePath
115 exists <- Dir.doesFileExist readmePath
94 if exists
116 if exists
95− then Just <$> readFile readmePath
117+ then Just <$> Text.readFile readmePath
96 else return Nothing
118 else return Nothing
97
119
98
120
99−
100−-- GET DIRECTORIES
101−
102−
103−getDirs :: FilePath -> [FilePath] -> IO [FilePath]
121+getDirsAndFiles :: FilePath -> IO ([FilePath], [(FilePath, Bool)])
104−getDirs pwd contents =
122+getDirsAndFiles pwd =
123+ do contents <- Dir.getDirectoryContents pwd
105− filterM (Dir.doesDirectoryExist . (pwd </>)) contents
124+ dirs <- filterM (Dir.doesDirectoryExist . (pwd </>)) contents
106−
107−
108−
109−-- GET FILES
110−
111−
112−getFiles :: FilePath -> [FilePath] -> IO [File]
113−getFiles pwd contents =
114− do paths <- filterM (Dir.doesFileExist . (pwd </>)) contents
125+ filePaths <- filterM (Dir.doesFileExist . (pwd </>)) contents
115− mapM (toFile pwd) paths
126+ files <- mapM (inspectFile pwd) filePaths
127+ return (dirs, files)
116
128
117
129
118−toFile :: FilePath -> FilePath -> IO File
130+inspectFile :: FilePath -> FilePath -> IO (FilePath, Bool)
119−toFile pwd path =
131+inspectFile pwd path =
120 if takeExtension path == ".elm" then
132 if takeExtension path == ".elm" then
121− do source <- readFile (pwd </> path)
133+ do source <- Text.readFile (pwd </> path)
122− let hasMain = List.isInfixOf "\nmain " source
134+ let hasMain = Text.isInfixOf "\nmain " source
123− return (File path hasMain)
135+ return (path, hasMain)
124− else
125− return (File path False)
126−
127
136
128−
137+ else
129−-- GET OUTLINE
130−
131−
132−getOutline :: IO (Maybe Outline.Outline)
133−getOutline =
134− do maybeRoot <- Stuff.findRoot
135− case maybeRoot of
136− Nothing ->
137− return Nothing
138−
139− Just root ->
140− do result <- Outline.read root
141− case result of
142− Left _ -> return Nothing
143− Right outline -> return (Just outline)
144−
145−
146−
147−-- GET EXACT DEPS
148−
149−
150−-- TODO revamp how `elm reactor` works so that this can go away.
151−-- I am trying to "just get it working again" at this point though.
152−--
153−getExactDeps :: Maybe Outline.Outline -> IO (Map.Map Pkg.Name V.Version)
154−getExactDeps maybeOutline =
155− case maybeOutline of
156− Nothing ->
157− return Map.empty
138+ return (path, False)
158−
159− Just outline ->
160− case outline of
161− Outline.App _ ->
162− return Map.empty
163−
164− Outline.Pkg _ ->
165− do maybeRoot <- Stuff.findRoot
166− case maybeRoot of
167− Nothing ->
168− return Map.empty
169−
170− Just root ->
171− BW.withScope $ \scope ->
172− do result <- Details.load Reporting.silent scope root
173− case result of
174− Left _ ->
175− return Map.empty
176−
177− Right (Details.Details _ validOutline _ _ _ _) ->
178− case validOutline of
179− Details.ValidApp _ ->
180− return Map.empty
181−
182− Details.ValidPkg _ _ solution ->
183− return solution
184−
185−
186−
187−-- ENCODE
188−
189−
190−encode :: Flags -> E.Value
191−encode (Flags root pwd dirs files readme outline exactDeps) =
192− E.object
193− [ "root" ==> encodeFilePath root
194− , "pwd" ==> E.list encodeFilePath pwd
195− , "dirs" ==> E.list encodeFilePath dirs
196− , "files" ==> E.list encodeFile files
197− , "readme" ==> maybe E.null E.chars readme
198− , "outline" ==> maybe E.null Outline.encode outline
199− , "exactDeps" ==> E.dict Pkg.toJsonString V.encode exactDeps
200− ]
201−
202−
203−encodeFilePath :: FilePath -> E.Value
204−encodeFilePath filePath =
205− E.chars filePath
206−
207−
208−encodeFile :: File -> E.Value
209−encodeFile (File path hasMain) =
210− E.object
211− [ "name" ==> encodeFilePath path
212− , "runnable" ==> E.bool hasMain
213− ]
terminal/src/Develop/StaticFiles.hs+7−1
@@ -36,6 +36,7 @@ dict :: HM.HashMap FilePath (BS.ByteString, MimeType)
36dict =
36dict =
37 HM.fromList
37 HM.fromList
38 [ faviconPath ==> (favicon , "image/x-icon")
38 [ faviconPath ==> (favicon , "image/x-icon")
39+ , waitingPath ==> (waiting , "image/gif")
39 , elmPath ==> (elm , "application/javascript")
40 , elmPath ==> (elm , "application/javascript")
40 , cssPath ==> (css , "text/css")
41 , cssPath ==> (css , "text/css")
41 , codeFontPath ==> (codeFont, "font/ttf")
42 , codeFontPath ==> (codeFont, "font/ttf")
@@ -88,7 +89,7 @@ sansFontPath =
88
89
89elm :: BS.ByteString
90elm :: BS.ByteString
90elm =
91elm =
91− $(bsToExp =<< runIO Build.buildReactorFrontEnd)
92+ $(bsToExp =<< runIO Build.compile)
92
93
93
94
94
95
@@ -121,3 +122,8 @@ sansFont =
121favicon :: BS.ByteString
122favicon :: BS.ByteString
122favicon =
123favicon =
123 $(bsToExp =<< runIO (Build.readAsset "favicon.ico"))
124 $(bsToExp =<< runIO (Build.readAsset "favicon.ico"))
125+
126+
127+waiting :: BS.ByteString
128+waiting =
129+ $(bsToExp =<< runIO (Build.readAsset "waiting.gif"))
terminal/src/Develop/StaticFiles/Build.hs+29−46
@@ -1,25 +1,19 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Develop.StaticFiles.Build
2module Develop.StaticFiles.Build
3 ( readAsset
3 ( readAsset
4− , buildReactorFrontEnd
4+ , compile
5 )
5 )
6 where
6 where
7
7
8
8
9import qualified Data.ByteString as BS
9import qualified Data.ByteString as BS
10−import qualified Data.ByteString.Builder as B
11−import qualified Data.ByteString.Lazy as LBS
12−import qualified Data.NonEmptyList as NE
13import qualified System.Directory as Dir
10import qualified System.Directory as Dir
14import System.FilePath ((</>))
11import System.FilePath ((</>))
15
12
16−import qualified BackgroundWriter as BW
13+import qualified Elm.Project as Project
17−import qualified Build
18−import qualified Elm.Details as Details
19−import qualified Generate
14+import qualified Generate.Output as Output
20−import qualified Reporting
21−import qualified Reporting.Exit as Exit
22import qualified Reporting.Task as Task
15import qualified Reporting.Task as Task
16+import qualified Reporting.Progress.Terminal as Terminal
23
17
24
18
25
19
@@ -32,42 +26,31 @@ readAsset path =
32
26
33
27
34
28
35−-- BUILD REACTOR ELM
29+-- COMPILE
36
30
37
31
38−buildReactorFrontEnd :: IO BS.ByteString
32+compile :: IO BS.ByteString
39−buildReactorFrontEnd =
33+compile =
40− BW.withScope $ \scope ->
41 Dir.withCurrentDirectory "reactor" $
34 Dir.withCurrentDirectory "reactor" $
42− do root <- Dir.getCurrentDirectory
35+ do reporter <- Terminal.create
43− runTaskUnsafe $
36+ Task.run reporter $
44− do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root
37+ do summary <- Project.getRoot
45− artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details paths
38+ let jsOutput = Just (Output.JavaScript Nothing tempFileName)
46− javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.prod root details artifacts
39+ Project.compile Output.Prod Output.Client jsOutput summary rootPaths
47− return (LBS.toStrict (B.toLazyByteString javascript))
40+
48−
41+ result <- BS.readFile tempFileName
49−
42+ seq (BS.length result) (Dir.removeFile tempFileName)
43+ return result
44+
45+
46+tempFileName :: FilePath
47+tempFileName =
48+ "elm.js"
49+
50+
50−paths :: NE.List FilePath
51+rootPaths :: [FilePath]
51−paths =
52+rootPaths =
52− NE.List
53− ("src" </> "NotFound.elm")
54− [ "src" </> "Errors.elm"
53+ [ "src" </> "Errors.elm"
55− , "src" </> "Index.elm"
54+ , "src" </> "Index.elm"
56− ]
55+ , "src" </> "NotFound.elm"
57−
56+ ]
58−
59−runTaskUnsafe :: Task.Task Exit.Reactor a -> IO a
60−runTaskUnsafe task =
61− do result <- Task.run task
62− case result of
63− Right a ->
64− return a
65−
66− Left exit ->
67− do Exit.toStderr (Exit.reactorToReport exit)
68− error
69− "\n--------------------------------------------------------\
70− \\nError in Develop.StaticFiles.Build.buildReactorFrontEnd\
71− \\nCompile with `elm make` directly to figure it out faster\
72− \\n--------------------------------------------------------\
73− \\n"
terminal/src/Diff.hs+24−20
@@ -13,7 +13,6 @@ import qualified Data.Maybe as Maybe
13import qualified Data.Name as Name
13import qualified Data.Name as Name
14import qualified Data.NonEmptyList as NE
14import qualified Data.NonEmptyList as NE
15
15
16−import qualified BackgroundWriter as BW
17import qualified Build
16import qualified Build
18import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..))
17import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..))
19import qualified Deps.Diff as DD
18import qualified Deps.Diff as DD
@@ -73,7 +72,7 @@ getEnv =
73 do maybeRoot <- Task.io $ Stuff.findRoot
72 do maybeRoot <- Task.io $ Stuff.findRoot
74 cache <- Task.io $ Stuff.getPackageCache
73 cache <- Task.io $ Stuff.getPackageCache
75 manager <- Task.io $ Http.getManager
74 manager <- Task.io $ Http.getManager
76− registry <- Task.eio Exit.DiffMustHaveLatestRegistry $ Registry.latest manager cache
75+ registry <- Task.eio Exit.DiffBadRegistry $ Registry.latest manager cache
77 return (Env maybeRoot cache manager registry)
76 return (Env maybeRoot cache manager registry)
78
77
79
78
@@ -105,15 +104,13 @@ diff env@(Env _ _ _ registry) args =
105 writeDiff oldDocs newDocs
104 writeDiff oldDocs newDocs
106
105
107 CodeVsLatest ->
106 CodeVsLatest ->
108− do (name, vsns) <- readOutline env
107+ do (newDocs, name, vsns) <- generateDocs env
109 oldDocs <- getLatestDocs env name vsns
108 oldDocs <- getLatestDocs env name vsns
110− newDocs <- generateDocs env
111 writeDiff oldDocs newDocs
109 writeDiff oldDocs newDocs
112
110
113 CodeVsExactly version ->
111 CodeVsExactly version ->
114− do (name, vsns) <- readOutline env
112+ do (newDocs, name, vsns) <- generateDocs env
115 oldDocs <- getDocs env name vsns version
113 oldDocs <- getDocs env name vsns version
116− newDocs <- generateDocs env
117 writeDiff oldDocs newDocs
114 writeDiff oldDocs newDocs
118
115
119
116
@@ -124,13 +121,13 @@ diff env@(Env _ _ _ registry) args =
124getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation
121getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation
125getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version =
122getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version =
126 if latest == version || elem version previous
123 if latest == version || elem version previous
127− then Task.eio (Exit.DiffDocsProblem version) $ DD.getDocs cache manager name version
124+ then Task.eio Exit.DiffDocsProblem $ DD.getDocs cache manager name version
128 else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous)
125 else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous)
129
126
130
127
131getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation
128getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation
132getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) =
129getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) =
133− Task.eio (Exit.DiffDocsProblem latest) $ DD.getDocs cache manager name latest
130+ Task.eio Exit.DiffDocsProblem $ DD.getDocs cache manager name latest
134
131
135
132
136
133
@@ -164,29 +161,36 @@ readOutline (Env maybeRoot _ _ registry) =
164-- GENERATE DOCS
161-- GENERATE DOCS
165
162
166
163
167−generateDocs :: Env -> Task Docs.Documentation
164+generateDocs :: Env -> Task (Docs.Documentation, Pkg.Name, Registry.KnownVersions)
168−generateDocs (Env maybeRoot _ _ _) =
165+generateDocs (Env maybeRoot _ _ registry) =
169 case maybeRoot of
166 case maybeRoot of
170 Nothing ->
167 Nothing ->
171 Task.throw $ Exit.DiffNoOutline
168 Task.throw $ Exit.DiffNoOutline
172
169
173 Just root ->
170 Just root ->
174 do details <-
171 do details <-
175− Task.eio Exit.DiffBadDetails $ BW.withScope $ \scope ->
172+ Task.eio Exit.DiffBadDetails $
176− Details.load Reporting.silent scope root
173+ Details.load Reporting.silent root
177
174
178 case Details._outline details of
175 case Details._outline details of
179 Details.ValidApp _ ->
176 Details.ValidApp _ ->
180 Task.throw $ Exit.DiffApplication
177 Task.throw $ Exit.DiffApplication
181
178
182− Details.ValidPkg _ exposed _ ->
179+ Details.ValidPkg pkg exposed ->
180+ case Registry.getVersions pkg registry of
181+ Just vsns ->
183− case exposed of
182+ case exposed of
184− [] ->
183+ [] ->
185− Task.throw $ Exit.DiffNoExposed
184+ Task.throw Exit.DiffNoExposed
186−
185+
187− e:es ->
186+ e:es ->
187+ do docs <-
188− Task.eio Exit.DiffBadBuild $
188+ Task.eio Exit.DiffBadBuild $
189− Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)
189+ Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)
190+ return ( docs, pkg, vsns )
191+
192+ Nothing ->
193+ Task.throw Exit.DiffUnpublished
190
194
191
195
192
196
terminal/src/Init.hs+1−1
@@ -90,7 +90,7 @@ init =
90 in
90 in
91 do Dir.createDirectoryIfMissing True "src"
91 do Dir.createDirectoryIfMissing True "src"
92 Outline.write "." $ Outline.App $
92 Outline.write "." $ Outline.App $
93− Outline.AppOutline V.compiler (NE.List (Outline.RelativeSrcDir "src") []) directs indirects Map.empty Map.empty
93+ Outline.AppOutline V.compiler (NE.List "src" []) directs indirects Map.empty Map.empty
94 putStrLn "Okay, I created it. Now read that link!"
94 putStrLn "Okay, I created it. Now read that link!"
95 return (Right ())
95 return (Right ())
96
96
terminal/src/Install.hs+30−15
@@ -10,7 +10,6 @@ import Data.Map ((!))
10import qualified Data.Map as Map
10import qualified Data.Map as Map
11import qualified Data.Map.Merge.Strict as Map
11import qualified Data.Map.Merge.Strict as Map
12
12
13−import qualified BackgroundWriter as BW
14import qualified Deps.Solver as Solver
13import qualified Deps.Solver as Solver
15import qualified Deps.Registry as Registry
14import qualified Deps.Registry as Registry
16import qualified Elm.Constraint as C
15import qualified Elm.Constraint as C
@@ -41,7 +40,7 @@ run args () =
41 do maybeRoot <- Stuff.findRoot
40 do maybeRoot <- Stuff.findRoot
42 case maybeRoot of
41 case maybeRoot of
43 Nothing ->
42 Nothing ->
44− return (Left Exit.InstallNoOutline)
43+ return (Left Exit.InstallNoProject)
45
44
46 Just root ->
45 Just root ->
47 case args of
46 case args of
@@ -51,8 +50,8 @@ run args () =
51
50
52 Install pkg ->
51 Install pkg ->
53 Task.run $
52 Task.run $
54− do env <- Task.eio Exit.InstallBadRegistry $ Solver.initEnv
53+ do env <- getEnv
55− oldOutline <- Task.eio Exit.InstallBadOutline $ Outline.read root
54+ oldOutline <- getOutline root
56 case oldOutline of
55 case oldOutline of
57 Outline.App outline ->
56 Outline.App outline ->
58 do changes <- makeAppPlan env pkg outline
57 do changes <- makeAppPlan env pkg outline
@@ -64,6 +63,23 @@ run args () =
64
63
65
64
66
65
66+getEnv :: Task Solver.Env
67+getEnv =
68+ do eitherEnv <- Task.io Solver.initEnv
69+ case eitherEnv of
70+ Right env -> return env
71+ Left problem -> Task.throw (error "TODO getEnv" problem)
72+
73+
74+getOutline :: FilePath -> Task Outline.Outline
75+getOutline root =
76+ do eitherOutline <- Task.io (Outline.read root)
77+ case eitherOutline of
78+ Right outline -> return outline
79+ Left exit -> Task.throw (error "TODO getOutline" exit)
80+
81+
82+
67-- ATTEMPT CHANGES
83-- ATTEMPT CHANGES
68
84
69
85
@@ -124,13 +140,12 @@ attemptChanges root env oldOutline toChars changes =
124
140
125attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
141attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
126attemptChangesHelp root env oldOutline newOutline question =
142attemptChangesHelp root env oldOutline newOutline question =
127− Task.eio Exit.InstallBadDetails $
143+ Task.eio Exit.InstallHasBadDetails $
128− BW.withScope $ \scope ->
129 do approved <- Reporting.ask question
144 do approved <- Reporting.ask question
130 if approved
145 if approved
131 then
146 then
132 do Outline.write root newOutline
147 do Outline.write root newOutline
133− result <- Details.verifyInstall scope root env newOutline
148+ result <- Details.verifyInstall root env newOutline
134 case result of
149 case result of
135 Left exit ->
150 Left exit ->
136 do Outline.write root oldOutline
151 do Outline.write root oldOutline
@@ -188,8 +203,8 @@ makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOut
188 case Registry.getVersions' pkg registry of
203 case Registry.getVersions' pkg registry of
189 Left suggestions ->
204 Left suggestions ->
190 case connection of
205 case connection of
191− Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
206+ Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline suggestions)
192− Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)
207+ Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline suggestions)
193
208
194 Right _ ->
209 Right _ ->
195 do result <- Task.io $ Solver.addToApp cache connection registry pkg outline
210 do result <- Task.io $ Solver.addToApp cache connection registry pkg outline
@@ -198,10 +213,10 @@ makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOut
198 return (Changes (detectChanges old new) (Outline.App app))
213 return (Changes (detectChanges old new) (Outline.App app))
199
214
200 Solver.NoSolution ->
215 Solver.NoSolution ->
201− Task.throw (Exit.InstallNoOnlineAppSolution pkg)
216+ Task.throw Exit.InstallNoOnlineSolution
202
217
203 Solver.NoOfflineSolution ->
218 Solver.NoOfflineSolution ->
204− Task.throw (Exit.InstallNoOfflineAppSolution pkg)
219+ Task.throw Exit.InstallNoOfflineSolution
205
220
206 Solver.Err exit ->
221 Solver.Err exit ->
207 Task.throw (Exit.InstallHadSolverTrouble exit)
222 Task.throw (Exit.InstallHadSolverTrouble exit)
@@ -230,8 +245,8 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOut
230 case Registry.getVersions' pkg registry of
245 case Registry.getVersions' pkg registry of
231 Left suggestions ->
246 Left suggestions ->
232 case connection of
247 case connection of
233− Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
248+ Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline suggestions)
234− Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)
249+ Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline suggestions)
235
250
236 Right (Registry.KnownVersions _ _) ->
251 Right (Registry.KnownVersions _ _) ->
237 do let old = Map.union deps test
252 do let old = Map.union deps test
@@ -254,10 +269,10 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOut
254 }
269 }
255
270
256 Solver.NoSolution ->
271 Solver.NoSolution ->
257− Task.throw (Exit.InstallNoOnlinePkgSolution pkg)
272+ Task.throw Exit.InstallNoOnlineSolution
258
273
259 Solver.NoOfflineSolution ->
274 Solver.NoOfflineSolution ->
260− Task.throw (Exit.InstallNoOfflinePkgSolution pkg)
275+ Task.throw Exit.InstallNoOfflineSolution
261
276
262 Solver.Err exit ->
277 Solver.Err exit ->
263 Task.throw (Exit.InstallHadSolverTrouble exit)
278 Task.throw (Exit.InstallHadSolverTrouble exit)
terminal/src/Main.hs+36−32
@@ -6,14 +6,17 @@ module Main
6
6
7
7
8import Prelude hiding (init)
8import Prelude hiding (init)
9+import GHC.IO.Encoding (setLocaleEncoding, utf8)
9import qualified Data.List as List
10import qualified Data.List as List
10import qualified Text.PrettyPrint.ANSI.Leijen as P
11import qualified Text.PrettyPrint.ANSI.Leijen as P
11import Text.PrettyPrint.ANSI.Leijen ((<>))
12import Text.PrettyPrint.ANSI.Leijen ((<>))
12import Text.Read (readMaybe)
13import Text.Read (readMaybe)
13
14
15+import qualified Elm.Diff as Diff
14import qualified Elm.Version as V
16import qualified Elm.Version as V
17+import qualified Generate.Output as Output
15−import Terminal
18+import Terminal.Args
16−import Terminal.Helpers
19+import Terminal.Args.Helpers
17
20
18import qualified Bump
21import qualified Bump
19import qualified Develop
22import qualified Develop
@@ -31,16 +34,17 @@ import qualified Repl
31
34
32main :: IO ()
35main :: IO ()
33main =
36main =
37+ do setLocaleEncoding utf8
34− Terminal.app intro outro
38+ complex intro outro
35− [ repl
39+ [ repl
36− , init
40+ , init
37− , reactor
41+ , reactor
38− , make
42+ , make
39− , install
43+ , install
40− , bump
44+ , bump
41− , diff
45+ , diff
42− , publish
46+ , publish
43− ]
47+ ]
44
48
45
49
46intro :: P.Doc
50intro :: P.Doc
@@ -72,7 +76,7 @@ outro =
72-- INIT
76-- INIT
73
77
74
78
75−init :: Terminal.Command
79+init :: Interface
76init =
80init =
77 let
81 let
78 summary =
82 summary =
@@ -87,14 +91,14 @@ init =
87 "It will ask permission to create an elm.json file, the one thing common\
91 "It will ask permission to create an elm.json file, the one thing common\
88 \ to all Elm projects. It also provides a link explaining what to do from there."
92 \ to all Elm projects. It also provides a link explaining what to do from there."
89 in
93 in
90− Terminal.Command "init" (Common summary) details example noArgs noFlags Init.run
94+ Interface "init" (Common summary) details example noArgs noFlags Init.run
91
95
92
96
93
97
94-- REPL
98-- REPL
95
99
96
100
97−repl :: Terminal.Command
101+repl :: Interface
98repl =
102repl =
99 let
103 let
100 summary =
104 summary =
@@ -115,7 +119,7 @@ repl =
115 |-- flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs."
119 |-- flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs."
116 |-- onOff "no-colors" "Turn off the colors in the REPL. This can help if you are having trouble reading the values. Some terminals use a custom color scheme that diverges significantly from the standard ANSI colors, so another path may be to pick a more standard color scheme."
120 |-- onOff "no-colors" "Turn off the colors in the REPL. This can help if you are having trouble reading the values. Some terminals use a custom color scheme that diverges significantly from the standard ANSI colors, so another path may be to pick a more standard color scheme."
117 in
121 in
118− Terminal.Command "repl" (Common summary) details example noArgs replFlags Repl.run
122+ Interface "repl" (Common summary) details example noArgs replFlags Repl.run
119
123
120
124
121interpreter :: Parser String
125interpreter :: Parser String
@@ -133,7 +137,7 @@ interpreter =
133-- REACTOR
137-- REACTOR
134
138
135
139
136−reactor :: Terminal.Command
140+reactor :: Interface
137reactor =
141reactor =
138 let
142 let
139 summary =
143 summary =
@@ -154,7 +158,7 @@ reactor =
154 flags Develop.Flags
158 flags Develop.Flags
155 |-- flag "port" port_ "The port of the server (default: 8000)"
159 |-- flag "port" port_ "The port of the server (default: 8000)"
156 in
160 in
157− Terminal.Command "reactor" (Common summary) details example noArgs reactorFlags Develop.run
161+ Interface "reactor" (Common summary) details example noArgs reactorFlags Develop.run
158
162
159
163
160port_ :: Parser Int
164port_ :: Parser Int
@@ -172,7 +176,7 @@ port_ =
172-- MAKE
176-- MAKE
173
177
174
178
175−make :: Terminal.Command
179+make :: Interface
176make =
180make =
177 let
181 let
178 details =
182 details =
@@ -184,26 +188,26 @@ make =
184 "For example:"
188 "For example:"
185 , P.indent 4 $ P.green "elm make src/Main.elm"
189 , P.indent 4 $ P.green "elm make src/Main.elm"
186 , reflow
190 , reflow
187− "This tries to compile an Elm file named src/Main.elm, generating an index.html\
191+ "This tries to compile an Elm file named src/Main.elm, putting the resulting\
188− \ file if possible."
192+ \ JavaScript code in an elm.js file."
189 ]
193 ]
190
194
191 makeFlags =
195 makeFlags =
192 flags Make.Flags
196 flags Make.Flags
193 |-- onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!"
197 |-- onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!"
194 |-- onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation."
198 |-- onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation."
195− |-- flag "output" Make.output "Specify the name of the resulting JS file. For example --output=assets/elm.js to generate the JS at assets/elm.js or --output=/dev/null to generate no output at all!"
199+ |-- flag "output" Output.output "Specify the name of the resulting JS file. For example --output=assets/elm.js to generate the JS at assets/elm.js or --output=/dev/null to generate no output at all!"
196 |-- flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!"
200 |-- flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!"
197 |-- flag "docs" Make.docsFile "Generate a JSON file of documentation for a package. Eventually it will be possible to preview docs with `reactor` because it is quite hard to deal with these JSON files directly."
201 |-- flag "docs" Make.docsFile "Generate a JSON file of documentation for a package. Eventually it will be possible to preview docs with `reactor` because it is quite hard to deal with these JSON files directly."
198 in
202 in
199− Terminal.Command "make" Uncommon details example (zeroOrMore elmFile) makeFlags Make.run
203+ Interface "make" Uncommon details example (zeroOrMore elmFile) makeFlags Make.run
200
204
201
205
202
206
203-- INSTALL
207-- INSTALL
204
208
205
209
206−install :: Terminal.Command
210+install :: Interface
207install =
211install =
208 let
212 let
209 details =
213 details =
@@ -232,14 +236,14 @@ install =
232 , require1 Install.Install package
236 , require1 Install.Install package
233 ]
237 ]
234 in
238 in
235− Terminal.Command "install" Uncommon details example installArgs noFlags Install.run
239+ Interface "install" Uncommon details example installArgs noFlags Install.run
236
240
237
241
238
242
239-- PUBLISH
243-- PUBLISH
240
244
241
245
242−publish :: Terminal.Command
246+publish :: Interface
243publish =
247publish =
244 let
248 let
245 details =
249 details =
@@ -266,17 +270,17 @@ publish =
266 \ it ends up as an experiment on GitHub only. Point is, try to be\
270 \ it ends up as an experiment on GitHub only. Point is, try to be\
267 \ respectful of the community and package ecosystem!"
271 \ respectful of the community and package ecosystem!"
268 , reflow
272 , reflow
269− "Check out <https://package.elm-lang.org/help/design-guidelines> for guidance on how to create great packages!"
273+ "Check out <TODO> for guidance on how to create great packages!"
270 ]
274 ]
271 in
275 in
272− Terminal.Command "publish" Uncommon details example noArgs noFlags Publish.run
276+ Interface "publish" Uncommon details example noArgs noFlags Publish.run
273
277
274
278
275
279
276-- BUMP
280-- BUMP
277
281
278
282
279−bump :: Terminal.Command
283+bump :: Interface
280bump =
284bump =
281 let
285 let
282 details =
286 details =
@@ -289,14 +293,14 @@ bump =
289 \ it is a MAJOR change, and bump your version number to 2.0.0. I do this with\
293 \ it is a MAJOR change, and bump your version number to 2.0.0. I do this with\
290 \ all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!"
294 \ all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!"
291 in
295 in
292− Terminal.Command "bump" Uncommon details example noArgs noFlags Bump.run
296+ Interface "bump" Uncommon details example noArgs noFlags Bump.run
293
297
294
298
295
299
296-- DIFF
300-- DIFF
297
301
298
302
299−diff :: Terminal.Command
303+diff :: Interface
300diff =
304diff =
301 let
305 let
302 details =
306 details =
@@ -321,7 +325,7 @@ diff =
321 , require3 Diff.GlobalInquiry package version version
325 , require3 Diff.GlobalInquiry package version version
322 ]
326 ]
323 in
327 in
324− Terminal.Command "diff" Uncommon details example diffArgs noFlags Diff.run
328+ Interface "diff" Uncommon details example diffArgs noFlags Diff.run
325
329
326
330
327
331
terminal/src/Make.hs+267−112
@@ -1,4 +1,4 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2module Make
2module Make
3 ( Flags(..)
3 ( Flags(..)
4 , Output(..)
4 , Output(..)
@@ -6,30 +6,36 @@ module Make
6 , run
6 , run
7 , reportType
7 , reportType
8 , output
8 , output
9− , docsFile
10 )
9 )
11 where
10 where
12
11
13
12
13+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
14+import Control.Monad (liftM2)
14import qualified Data.ByteString.Builder as B
15import qualified Data.ByteString.Builder as B
16+import qualified Data.Map as Map
15import qualified Data.Maybe as Maybe
17import qualified Data.Maybe as Maybe
16import qualified Data.NonEmptyList as NE
18import qualified Data.NonEmptyList as NE
17−import qualified System.Directory as Dir
18import qualified System.FilePath as FP
19import qualified System.FilePath as FP
19
20
20import qualified AST.Optimized as Opt
21import qualified AST.Optimized as Opt
21−import qualified BackgroundWriter as BW
22import qualified Build
22import qualified Build
23+import qualified Elm.Compiler.Type.Extract as Extract
23import qualified Elm.Details as Details
24import qualified Elm.Details as Details
25+import qualified Elm.Interface as I
24import qualified Elm.ModuleName as ModuleName
26import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Outline as Outline
28+import qualified Elm.Package as Pkg
25import qualified File
29import qualified File
26−import qualified Generate
27import qualified Generate.Html as Html
30import qualified Generate.Html as Html
31+import qualified Generate.JavaScript as Generate
32+import qualified Generate.Mode as Mode
33+import qualified Nitpick.Debug as Nitpick
28import qualified Reporting
34import qualified Reporting
29import qualified Reporting.Exit as Exit
35import qualified Reporting.Exit as Exit
30import qualified Reporting.Task as Task
36import qualified Reporting.Task as Task
31import qualified Stuff
37import qualified Stuff
32−import Terminal (Parser(..))
38+import Terminal.Args (Parser(..))
33
39
34
40
35
41
@@ -42,7 +48,6 @@ data Flags =
42 , _optimize :: Bool
48 , _optimize :: Bool
43 , _output :: Maybe Output
49 , _output :: Maybe Output
44 , _report :: Maybe ReportType
50 , _report :: Maybe ReportType
45− , _docs :: Maybe FilePath
46 }
51 }
47
52
48
53
@@ -64,58 +69,54 @@ type Task a = Task.Task Exit.Make a
64
69
65
70
66run :: [FilePath] -> Flags -> IO ()
71run :: [FilePath] -> Flags -> IO ()
67−run paths flags@(Flags _ _ _ report _) =
72+run paths (Flags debug optimize maybeOutput report) =
68 do style <- getStyle report
73 do style <- getStyle report
69− maybeRoot <- Stuff.findRoot
70− Reporting.attemptWithStyle style Exit.makeToReport $
74+ Reporting.attemptWithStyle style Exit.makeToReport $ Task.run $
71− case maybeRoot of
75+ do root <- getRoot
72− Just root -> runHelp root paths style flags
73− Nothing -> return $ Left $ Exit.MakeNoOutline
74−
75−
76−runHelp :: FilePath -> [FilePath] -> Reporting.Style -> Flags -> IO (Either Exit.Make ())
77−runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) =
78− BW.withScope $ \scope ->
79− Stuff.withRootLock root $ Task.run $
80− do desiredMode <- getMode debug optimize
76+ desiredMode <- getMode debug optimize
81− details <- Task.eio Exit.MakeBadDetails (Details.load style scope root)
77+ details <- getDetails style root
82− case paths of
78+ case paths of
83− [] ->
79+ [] ->
84− do exposed <- getExposed details
80+ do exposed <- getExposed details
85− buildExposed style root details maybeDocs exposed
81+ _ <- buildExposed style root details exposed
86−
82+ return ()
83+
87− p:ps ->
84+ p:ps ->
88− do artifacts <- buildPaths style root details (NE.List p ps)
85+ do artifacts <- buildPaths style root details (NE.List p ps)
89− case maybeOutput of
86+ case maybeOutput of
90− Nothing ->
87+ Nothing ->
91− case getMains artifacts of
88+ case getMains artifacts of
92− [] ->
89+ [] ->
93− return ()
90+ return ()
94−
91+
95− [name] ->
92+ [name] ->
96− do builder <- toBuilder root details desiredMode artifacts
93+ do builder <- toBuilder root details desiredMode artifacts
97− generate style "index.html" (Html.sandwich name builder) (NE.List name [])
94+ generate style "index.html" (Html.sandwich name builder) (NE.List name [])
98−
95+
99− name:names ->
96+ name:names ->
100− do builder <- toBuilder root details desiredMode artifacts
97+ do builder <- toBuilder root details desiredMode artifacts
101− generate style "elm.js" builder (NE.List name names)
98+ generate style "elm.js" builder (NE.List name names)
102−
99+
103− Just DevNull ->
100+ Just DevNull ->
104− return ()
101+ return ()
105−
102+
106− Just (JS target) ->
103+ Just (JS target) ->
107− case getNoMains artifacts of
104+ case getNoMains artifacts of
108− [] ->
105+ [] ->
109− do builder <- toBuilder root details desiredMode artifacts
106+ do builder <- toBuilder root details desiredMode artifacts
110− generate style target builder (Build.getRootNames artifacts)
107+ generate style target builder (getMainNames artifacts)
111−
108+
112− name:names ->
109+ name:names ->
113− Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
110+ Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
114−
111+
115− Just (Html target) ->
112+ Just (Html target) ->
116− do name <- hasOneMain artifacts
113+ case hasOneMain artifacts of
114+ Just name ->
117− builder <- toBuilder root details desiredMode artifacts
115+ do builder <- toBuilder root details desiredMode artifacts
118− generate style target (Html.sandwich name builder) (NE.List name [])
116+ generate style target (Html.sandwich name builder) (NE.List name [])
117+
118+ Nothing ->
119+ Task.throw Exit.MakeMultipleFilesIntoHtml
119
120
120
121
121
122
@@ -129,6 +130,14 @@ getStyle report =
129 Just Json -> return Reporting.json
130 Just Json -> return Reporting.json
130
131
131
132
133+getRoot :: Task FilePath
134+getRoot =
135+ do maybeRoot <- Task.io Stuff.findRoot
136+ case maybeRoot of
137+ Nothing -> Task.throw Exit.MakeNeedsOutline
138+ Just root -> return root
139+
140+
132getMode :: Bool -> Bool -> Task DesiredMode
141getMode :: Bool -> Bool -> Task DesiredMode
133getMode debug optimize =
142getMode debug optimize =
134 case (debug, optimize) of
143 case (debug, optimize) of
@@ -138,13 +147,18 @@ getMode debug optimize =
138 (False, True ) -> return Prod
147 (False, True ) -> return Prod
139
148
140
149
150+getDetails :: Reporting.Style -> FilePath -> Task Details.Details
151+getDetails style root =
152+ Task.eio Exit.MakeBlockedByDetailsProblem (Details.load style root)
153+
154+
141getExposed :: Details.Details -> Task (NE.List ModuleName.Raw)
155getExposed :: Details.Details -> Task (NE.List ModuleName.Raw)
142−getExposed (Details.Details _ validOutline _ _ _ _) =
156+getExposed (Details.Details _ validOutline _ _ _) =
143 case validOutline of
157 case validOutline of
144 Details.ValidApp _ ->
158 Details.ValidApp _ ->
145 Task.throw Exit.MakeAppNeedsFileNames
159 Task.throw Exit.MakeAppNeedsFileNames
146
160
147− Details.ValidPkg _ exposed _ ->
161+ Details.ValidPkg _ exposed ->
148 case exposed of
162 case exposed of
149 [] -> Task.throw Exit.MakePkgNeedsExposing
163 [] -> Task.throw Exit.MakePkgNeedsExposing
150 m:ms -> return (NE.List m ms)
164 m:ms -> return (NE.List m ms)
@@ -154,19 +168,16 @@ getExposed (Details.Details _ validOutline _ _ _ _) =
154-- BUILD PROJECTS
168-- BUILD PROJECTS
155
169
156
170
157−buildExposed :: Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.List ModuleName.Raw -> Task ()
171+buildExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> Task ()
158−buildExposed style root details maybeDocs exposed =
172+buildExposed style root details exposed =
159− let
160− docsGoal = maybe Build.IgnoreDocs Build.WriteDocs maybeDocs
161− in
162 Task.eio Exit.MakeCannotBuild $
173 Task.eio Exit.MakeCannotBuild $
163− Build.fromExposed style root details docsGoal exposed
174+ Build.fromExposed style root details exposed
164
175
165
176
166buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts
177buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts
167buildPaths style root details paths =
178buildPaths style root details paths =
168 Task.eio Exit.MakeCannotBuild $
179 Task.eio Exit.MakeCannotBuild $
169− Build.fromPaths style root details paths
180+ Build.fromMains style root details paths
170
181
171
182
172
183
@@ -174,13 +185,13 @@ buildPaths style root details paths =
174
185
175
186
176getMains :: Build.Artifacts -> [ModuleName.Raw]
187getMains :: Build.Artifacts -> [ModuleName.Raw]
177−getMains (Build.Artifacts _ _ roots modules) =
188+getMains (Build.Artifacts _ _ mains modules) =
178− Maybe.mapMaybe (getMain modules) (NE.toList roots)
189+ Maybe.mapMaybe (getMain modules) (NE.toList mains)
179
190
180
191
181−getMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw
192+getMain :: [Build.Module] -> Build.Main -> Maybe ModuleName.Raw
182−getMain modules root =
193+getMain modules main =
183− case root of
194+ case main of
184 Build.Inside name ->
195 Build.Inside name ->
185 if any (isMain name) modules
196 if any (isMain name) modules
186 then Just name
197 then Just name
@@ -206,11 +217,11 @@ isMain targetName modul =
206-- HAS ONE MAIN
217-- HAS ONE MAIN
207
218
208
219
209−hasOneMain :: Build.Artifacts -> Task ModuleName.Raw
220+hasOneMain :: Build.Artifacts -> Maybe ModuleName.Raw
210−hasOneMain (Build.Artifacts _ _ roots modules) =
221+hasOneMain (Build.Artifacts _ _ mains modules) =
211− case roots of
222+ case mains of
212− NE.List root [] -> Task.mio Exit.MakeNoMain (return $ getMain modules root)
223+ NE.List main [] -> getMain modules main
213− NE.List _ (_:_) -> Task.throw Exit.MakeMultipleFilesIntoHtml
224+ NE.List _ (_:_) -> Nothing
214
225
215
226
216
227
@@ -218,13 +229,13 @@ hasOneMain (Build.Artifacts _ _ roots modules) =
218
229
219
230
220getNoMains :: Build.Artifacts -> [ModuleName.Raw]
231getNoMains :: Build.Artifacts -> [ModuleName.Raw]
221−getNoMains (Build.Artifacts _ _ roots modules) =
232+getNoMains (Build.Artifacts _ _ mains modules) =
222− Maybe.mapMaybe (getNoMain modules) (NE.toList roots)
233+ Maybe.mapMaybe (getNoMain modules) (NE.toList mains)
223
234
224
235
225−getNoMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw
236+getNoMain :: [Build.Module] -> Build.Main -> Maybe ModuleName.Raw
226−getNoMain modules root =
237+getNoMain modules main =
227− case root of
238+ case main of
228 Build.Inside name ->
239 Build.Inside name ->
229 if any (isMain name) modules
240 if any (isMain name) modules
230 then Nothing
241 then Nothing
@@ -237,14 +248,29 @@ getNoMain modules root =
237
248
238
249
239
250
251+-- GET MAIN NAMES
252+
253+
254+getMainNames :: Build.Artifacts -> NE.List ModuleName.Raw
255+getMainNames (Build.Artifacts _ _ mains _) =
256+ fmap getMainName mains
257+
258+
259+getMainName :: Build.Main -> ModuleName.Raw
260+getMainName main =
261+ case main of
262+ Build.Inside name -> name
263+ Build.Outside name _ _ -> name
264+
265+
266+
240-- GENERATE
267-- GENERATE
241
268
242
269
243generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task ()
270generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task ()
244generate style target builder names =
271generate style target builder names =
245 Task.io $
272 Task.io $
246− do Dir.createDirectoryIfMissing True (FP.takeDirectory target)
247− File.writeBuilder target builder
273+ do File.writeBuilder target builder
248 Reporting.reportGenerate style names target
274 Reporting.reportGenerate style names target
249
275
250
276
@@ -256,12 +282,150 @@ data DesiredMode = Debug | Dev | Prod
256
282
257
283
258toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
284toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
259−toBuilder root details desiredMode artifacts =
285+toBuilder root details desiredMode (Build.Artifacts pkg ifaces roots modules) =
260− Task.mapError Exit.MakeBadGenerate $
261− case desiredMode of
286+ case desiredMode of
262− Debug -> Generate.debug root details artifacts
287+ Debug ->
263− Dev -> Generate.dev root details artifacts
288+ do loading <- loadObjects root details modules
264− Prod -> Generate.prod root details artifacts
289+ types <- loadTypes root ifaces modules
290+ objects <- finalizeObjects loading
291+ let mode = Mode.Dev (Just types)
292+ let graph = toGlobalGraph objects
293+ let mains = gatherMains pkg objects roots
294+ return $ Generate.generate mode graph mains
295+
296+ Dev ->
297+ do objects <- finalizeObjects =<< loadObjects root details modules
298+ let mode = Mode.Dev Nothing
299+ let graph = toGlobalGraph objects
300+ let mains = gatherMains pkg objects roots
301+ return $ Generate.generate mode graph mains
302+
303+ Prod ->
304+ do objects <- finalizeObjects =<< loadObjects root details modules
305+ checkForDebugUses objects
306+ let graph = toGlobalGraph objects
307+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
308+ let mains = gatherMains pkg objects roots
309+ return $ Generate.generate mode graph mains
310+
311+
312+checkForDebugUses :: LoadedObjects -> Task ()
313+checkForDebugUses (LoadedObjects _ locals) =
314+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
315+ [] -> return ()
316+ m:ms -> Task.throw (Exit.MakeCannotOptimizeDebugValues m ms)
317+
318+
319+toGlobalGraph :: LoadedObjects -> Opt.GlobalGraph
320+toGlobalGraph (LoadedObjects globals locals) =
321+ foldr Opt.addLocalGraph globals locals
322+
323+
324+
325+-- LOAD OBJECTS
326+
327+
328+data LoadingObjects =
329+ LoadingObjects
330+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
331+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
332+ }
333+
334+
335+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
336+loadObjects root details modules =
337+ Task.io $
338+ do mvar <- Details.loadObjects root details
339+ mvars <- traverse (loadObject root) modules
340+ return $ LoadingObjects mvar (Map.fromList mvars)
341+
342+
343+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
344+loadObject root modul =
345+ case modul of
346+ Build.Fresh name _ graph ->
347+ do mvar <- newMVar (Just graph)
348+ return (name, mvar)
349+
350+ Build.Cached name _ _ ->
351+ do mvar <- newEmptyMVar
352+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
353+ return (name, mvar)
354+
355+
356+data LoadedObjects =
357+ LoadedObjects
358+ { _foreign :: Opt.GlobalGraph
359+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
360+ }
361+
362+
363+finalizeObjects :: LoadingObjects -> Task LoadedObjects
364+finalizeObjects (LoadingObjects mvar mvars) =
365+ Task.eio id $
366+ do result <- readMVar mvar
367+ results <- traverse readMVar mvars
368+ case liftM2 LoadedObjects result (sequence results) of
369+ Just loaded -> return (Right loaded)
370+ Nothing -> return (Left Exit.MakeCannotLoadArtifacts)
371+
372+
373+
374+-- LOAD TYPES
375+
376+
377+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
378+loadTypes root ifaces modules =
379+ Task.eio id $
380+ do mvars <- traverse (loadTypesHelp root) modules
381+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
382+ results <- traverse readMVar mvars
383+ case sequence results of
384+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
385+ Nothing -> return (Left Exit.MakeCannotLoadArtifacts)
386+
387+
388+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
389+loadTypesHelp root modul =
390+ case modul of
391+ Build.Fresh name iface _ ->
392+ newMVar (Just (Extract.fromInterface name iface))
393+
394+ Build.Cached name _ ciMVar ->
395+ do cachedInterface <- readMVar ciMVar
396+ case cachedInterface of
397+ Build.Unneeded ->
398+ do mvar <- newEmptyMVar
399+ _ <- forkIO $
400+ do maybeIface <- File.readBinary (Stuff.elmo root name)
401+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
402+ return mvar
403+
404+ Build.Loaded iface ->
405+ newMVar (Just (Extract.fromInterface name iface))
406+
407+ Build.Corrupted ->
408+ newMVar Nothing
409+
410+
411+
412+-- GATHER MAINS
413+
414+
415+gatherMains :: Pkg.Name -> LoadedObjects -> NE.List Build.Main -> Map.Map ModuleName.Canonical Opt.Main
416+gatherMains pkg (LoadedObjects _ locals) buildMains =
417+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList buildMains)
418+
419+
420+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Main -> Maybe (ModuleName.Canonical, Opt.Main)
421+lookupMain pkg locals buildMain =
422+ let
423+ toPair name (Opt.LocalGraph maybeMain _ _) =
424+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
425+ in
426+ case buildMain of
427+ Build.Inside name -> toPair name =<< Map.lookup name locals
428+ Build.Outside name _ g -> toPair name g
265
429
266
430
267
431
@@ -286,34 +450,25 @@ output =
286 , _plural = "output files"
450 , _plural = "output files"
287 , _parser = parseOutput
451 , _parser = parseOutput
288 , _suggest = \_ -> return []
452 , _suggest = \_ -> return []
289− , _examples = \_ -> return [ "elm.js", "index.html", "/dev/null" ]
453+ , _examples = exampleOutput
290 }
454 }
291
455
292
456
293parseOutput :: String -> Maybe Output
457parseOutput :: String -> Maybe Output
294−parseOutput name
458+parseOutput string =
459+ if string == "/dev/null" || string == "NUL" || string == "$null" then
295− | isDevNull name = Just DevNull
460+ Just DevNull
296− | hasExt ".html" name = Just (Html name)
297− | hasExt ".js" name = Just (JS name)
298− | otherwise = Nothing
299−
300
461
301−docsFile :: Parser FilePath
462+ else if FP.takeExtension string == ".html" && length string > 5 then
302−docsFile =
463+ Just (Html string)
303− Parser
304− { _singular = "json file"
305− , _plural = "json files"
306− , _parser = \name -> if hasExt ".json" name then Just name else Nothing
307− , _suggest = \_ -> return []
308− , _examples = \_ -> return ["docs.json","documentation.json"]
309− }
310
464
465+ else if FP.takeExtension string == ".js" && length string > 3 then
466+ Just (JS string)
311
467
312−hasExt :: String -> String -> Bool
468+ else
313−hasExt ext path =
469+ Nothing
314− FP.takeExtension path == ext && length path > length ext
315
470
316
471
317−isDevNull :: String -> Bool
472+exampleOutput :: String -> IO [String]
318−isDevNull name =
473+exampleOutput _ =
319− name == "/dev/null" || name == "NUL" || name == "$null"
474+ return [ "elm.js", "index.html", "/dev/null" ]
terminal/src/Publish.hs+107−183
@@ -8,22 +8,19 @@ module Publish
8import Control.Exception (bracket_)
8import Control.Exception (bracket_)
9import Control.Monad (void)
9import Control.Monad (void)
10import qualified Data.List as List
10import qualified Data.List as List
11−import qualified Data.NonEmptyList as NE
12import qualified Data.Utf8 as Utf8
11import qualified Data.Utf8 as Utf8
13import qualified System.Directory as Dir
12import qualified System.Directory as Dir
14import qualified System.Exit as Exit
13import qualified System.Exit as Exit
14+import qualified System.FilePath as FP
15import System.FilePath ((</>))
15import System.FilePath ((</>))
16import qualified System.Info as Info
16import qualified System.Info as Info
17import qualified System.IO as IO
17import qualified System.IO as IO
18import qualified System.Process as Process
18import qualified System.Process as Process
19
19
20−import qualified BackgroundWriter as BW
21−import qualified Build
22import qualified Deps.Bump as Bump
20import qualified Deps.Bump as Bump
23import qualified Deps.Diff as Diff
21import qualified Deps.Diff as Diff
24import qualified Deps.Registry as Registry
22import qualified Deps.Registry as Registry
25import qualified Deps.Website as Website
23import qualified Deps.Website as Website
26−import qualified Elm.Details as Details
27import qualified Elm.Docs as Docs
24import qualified Elm.Docs as Docs
28import qualified Elm.Magnitude as M
25import qualified Elm.Magnitude as M
29import qualified Elm.Outline as Outline
26import qualified Elm.Outline as Outline
@@ -72,12 +69,22 @@ data Env =
72
69
73getEnv :: Task.Task Exit.Publish Env
70getEnv :: Task.Task Exit.Publish Env
74getEnv =
71getEnv =
72+ do maybeRoot <- Task.io $ Stuff.findRoot
73+ case maybeRoot of
74+ Nothing ->
75− do root <- Task.mio Exit.PublishNoOutline $ Stuff.findRoot
75+ Task.throw Exit.PublishNoOutline
76+
77+ Just root ->
76− cache <- Task.io $ Stuff.getPackageCache
78+ do cache <- Task.io $ Stuff.getPackageCache
77− manager <- Task.io $ Http.getManager
79+ manager <- Task.io $ Http.getManager
78− registry <- Task.eio Exit.PublishMustHaveLatestRegistry $ Registry.latest manager cache
80+ registry <- Task.eio Exit.PublishMustHaveLatestRegistry $ Registry.latest manager cache
79− outline <- Task.eio Exit.PublishBadOutline $ Outline.read root
81+ outlineResult <- Task.io $ Outline.read root
82+ case outlineResult of
83+ Right outline ->
80− return $ Env root cache manager registry outline
84+ return $ Env root cache manager registry outline
85+
86+ Left problem ->
87+ Task.throw $ Exit.PublishBadOutline problem
81
88
82
89
83
90
@@ -85,7 +92,7 @@ getEnv =
85
92
86
93
87publish :: Env -> Task.Task Exit.Publish ()
94publish :: Env -> Task.Task Exit.Publish ()
88−publish env@(Env root _ manager registry outline) =
95+publish env@(Env root cache manager registry outline) =
89 case outline of
96 case outline of
90 Outline.App _ ->
97 Outline.App _ ->
91 Task.throw Exit.PublishApplication
98 Task.throw Exit.PublishApplication
@@ -100,16 +107,15 @@ publish env@(Env root _ manager registry outline) =
100
107
101 verifyReadme root
108 verifyReadme root
102 verifyLicense root
109 verifyLicense root
103− docs <- verifyBuild root
110+ docs <- error "TODO Project.generateDocs details" details
104 verifyVersion env pkg vsn docs maybeKnownVersions
111 verifyVersion env pkg vsn docs maybeKnownVersions
105− git <- getGit
106− commitHash <- verifyTag git manager pkg vsn
112+ commitHash <- verifyTag manager pkg vsn
107− verifyNoChanges git commitHash vsn
113+ verifyNoChanges commitHash vsn
108− zipHash <- verifyZip env pkg vsn
114+ zipHash <- verifyZip manager pkg vsn
109
115
110− Task.io $ putStrLn ""
111− register manager pkg vsn docs commitHash zipHash
116+ register manager pkg vsn commitHash zipHash
117+
112− Task.io $ putStrLn "Success!"
118+ putStrLn "Success!"
113
119
114
120
115
121
@@ -137,7 +143,7 @@ noExposed exposed =
137
143
138verifyReadme :: FilePath -> Task.Task Exit.Publish ()
144verifyReadme :: FilePath -> Task.Task Exit.Publish ()
139verifyReadme root =
145verifyReadme root =
140− reportReadmeCheck $
146+ reportReadmePhase $
141 do let readmePath = root </> "README.md"
147 do let readmePath = root </> "README.md"
142 exists <- File.exists readmePath
148 exists <- File.exists readmePath
143 case exists of
149 case exists of
@@ -157,7 +163,7 @@ verifyReadme root =
157
163
158verifyLicense :: FilePath -> Task.Task Exit.Publish ()
164verifyLicense :: FilePath -> Task.Task Exit.Publish ()
159verifyLicense root =
165verifyLicense root =
160− reportLicenseCheck $
166+ reportLicensePhase $
161 do let licensePath = root </> "LICENSE"
167 do let licensePath = root </> "LICENSE"
162 exists <- File.exists licensePath
168 exists <- File.exists licensePath
163 if exists
169 if exists
@@ -166,77 +172,19 @@ verifyLicense root =
166
172
167
173
168
174
169−-- VERIFY BUILD
170−
171−
172−verifyBuild :: FilePath -> Task.Task Exit.Publish Docs.Documentation
173−verifyBuild root =
174− reportBuildCheck $ BW.withScope $ \scope ->
175− Task.run $
176− do details@(Details.Details _ outline _ _ _ _) <-
177− Task.eio Exit.PublishBadDetails $
178− Details.load Reporting.silent scope root
179−
180− exposed <-
181− case outline of
182− Details.ValidApp _ -> Task.throw Exit.PublishApplication
183− Details.ValidPkg _ [] _ -> Task.throw Exit.PublishNoExposed
184− Details.ValidPkg _ (e:es) _ -> return (NE.List e es)
185−
186− Task.eio Exit.PublishBuildProblem $
187− Build.fromExposed Reporting.silent root details Build.KeepDocs exposed
188−
189−
190−-- GET GIT
191−
192−
193−newtype Git =
194− Git { _run :: [String] -> IO Exit.ExitCode }
195−
196−
197−getGit :: Task.Task Exit.Publish Git
198−getGit =
199− do maybeGit <- Task.io $ Dir.findExecutable "git"
200− case maybeGit of
201− Nothing ->
202− Task.throw Exit.PublishNoGit
203−
204− Just git ->
205− return $ Git $ \args ->
206− let
207− process =
208− (Process.proc git args)
209− { Process.std_in = Process.CreatePipe
210− , Process.std_out = Process.CreatePipe
211− , Process.std_err = Process.CreatePipe
212− }
213− in
214− Process.withCreateProcess process $ \_ _ _ handle ->
215− Process.waitForProcess handle
216−
217−
218−
219-- VERIFY GITHUB TAG
175-- VERIFY GITHUB TAG
220
176
221
177
222−verifyTag :: Git -> Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish String
178+verifyTag :: Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish String
223−verifyTag git manager pkg vsn =
179+verifyTag manager pkg vsn =
224− reportTagCheck vsn $
180+ reportTagPhase vsn $
225− do -- https://stackoverflow.com/questions/1064499/how-to-list-all-git-tags
181+ Http.post manager (toTagUrl pkg vsn) [Http.accept "application/json"] Exit.PublishCannotGetTag $ \body ->
226− exitCode <- _run git [ "show", "--name-only", V.toChars vsn, "--" ]
182+ case D.fromByteString commitHashDecoder body of
227− case exitCode of
183+ Right hash ->
228− Exit.ExitFailure _ ->
184+ return $ Right hash
229− return $ Left (Exit.PublishMissingTag vsn)
230
185
231− Exit.ExitSuccess ->
186+ Left _ ->
232− let url = toTagUrl pkg vsn in
187+ return $ Left (Exit.PublishMissingTag vsn)
233− Http.get manager url [Http.accept "application/json"] (Exit.PublishCannotGetTag vsn) $ \body ->
234− case D.fromByteString commitHashDecoder body of
235− Right hash ->
236− return $ Right hash
237−
238− Left _ ->
239− return $ Left (Exit.PublishCannotGetTagData vsn url body)
240
188
241
189
242toTagUrl :: Pkg.Name -> V.Version -> String
190toTagUrl :: Pkg.Name -> V.Version -> String
@@ -254,75 +202,60 @@ commitHashDecoder =
254-- VERIFY NO LOCAL CHANGES SINCE TAG
202-- VERIFY NO LOCAL CHANGES SINCE TAG
255
203
256
204
257−verifyNoChanges :: Git -> String -> V.Version -> Task.Task Exit.Publish ()
205+verifyNoChanges :: String -> V.Version -> Task.Task Exit.Publish ()
258−verifyNoChanges git commitHash vsn =
206+verifyNoChanges commitHash vsn =
259− reportLocalChangesCheck $
207+ reportChangesPhase $
260− do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
208+ do maybeGit <- Dir.findExecutable "git"
261− exitCode <- _run git [ "diff-index", "--quiet", commitHash, "--" ]
262− case exitCode of
209+ case maybeGit of
263− Exit.ExitSuccess -> return $ Right ()
210+ Nothing ->
264− Exit.ExitFailure _ -> return $ Left (Exit.PublishLocalChanges vsn)
211+ return $ Left Exit.PublishNoGit
265
212
213+ Just git ->
214+ do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
215+ exitCode <- Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]
216+ case exitCode of
217+ Exit.ExitSuccess -> return $ Right ()
218+ Exit.ExitFailure _ -> return $ Left (Exit.PublishLocalChanges vsn)
266
219
267
220
268−-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
269
221
222+-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
270
223
271−verifyZip :: Env -> Pkg.Name -> V.Version -> Task.Task Exit.Publish Http.Sha
272−verifyZip (Env root _ manager _ _) pkg vsn =
273− withPrepublishDir root $ \prepublishDir ->
274− do let url = toZipUrl pkg vsn
275
224
225+verifyZip :: Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish Http.Sha
226+verifyZip manager pkg vsn =
227+ withTempDir $ \prepublishDir ->
276− (sha, archive) <-
228+ do (sha, archive) <-
277− reportDownloadCheck $
229+ reportDownloadPhase $
278− Http.getArchive manager url
230+ Http.getArchive manager (toZipUrl pkg vsn)
279 Exit.PublishCannotGetZip
231 Exit.PublishCannotGetZip
280− (Exit.PublishCannotDecodeZip url)
232+ Exit.PublishCannotDecodeZip
281 (return . Right)
233 (return . Right)
282
234
283 Task.io $ File.writePackage prepublishDir archive
235 Task.io $ File.writePackage prepublishDir archive
284
236
285− reportZipBuildCheck $
237+ reportBuildPhase $
286 Dir.withCurrentDirectory prepublishDir $
238 Dir.withCurrentDirectory prepublishDir $
287− verifyZipBuild prepublishDir
239+ do error "TODO Build.generateDocs"
240+ return ()
288
241
289 return sha
242 return sha
290
243
291
244
292−toZipUrl :: Pkg.Name -> V.Version -> String
293−toZipUrl pkg vsn =
294− "https://github.com/" ++ Pkg.toUrl pkg ++ "/zipball/" ++ V.toChars vsn ++ "/"
295−
296−
297−withPrepublishDir :: FilePath -> (FilePath -> Task.Task x a) -> Task.Task x a
245+withTempDir :: FilePath -> (FilePath -> IO a) -> IO a
298−withPrepublishDir root callback =
246+withTempDir root callback =
299 let
247 let
300 dir = Stuff.prepublishDir root
248 dir = Stuff.prepublishDir root
301 in
249 in
302− Task.eio id $
303− bracket_
250+ bracket_
304− (Dir.createDirectoryIfMissing True dir)
251+ (Dir.createDirectoryIfMissing True dir)
305− (Dir.removeDirectoryRecursive dir)
252+ (Dir.removeDirectoryRecursive dir)
306− (Task.run (callback dir))
253+ (callback dir)
307−
308−
309−verifyZipBuild :: FilePath -> IO (Either Exit.Publish ())
310−verifyZipBuild root =
311− BW.withScope $ \scope -> Task.run $
312− do details@(Details.Details _ outline _ _ _ _) <-
313− Task.eio Exit.PublishZipBadDetails $
314− Details.load Reporting.silent scope root
315−
316− exposed <-
317− case outline of
318− Details.ValidApp _ -> Task.throw Exit.PublishZipApplication
319− Details.ValidPkg _ [] _ -> Task.throw Exit.PublishZipNoExposed
320− Details.ValidPkg _ (e:es) _ -> return (NE.List e es)
321
254
322− _ <- Task.eio Exit.PublishZipBuildProblem $
323− Build.fromExposed Reporting.silent root details Build.KeepDocs exposed
324
255
325− return ()
256+toZipUrl :: Pkg.Name -> V.Version -> String
257+toZipUrl pkg vsn =
258+ "https://github.com/" ++ Pkg.toUrl pkg ++ "/zipball/" ++ V.toChars vsn ++ "/"
326
259
327
260
328
261
@@ -336,7 +269,7 @@ data GoodVersion
336
269
337verifyVersion :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task.Task Exit.Publish ()
270verifyVersion :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task.Task Exit.Publish ()
338verifyVersion env pkg vsn newDocs publishedVersions =
271verifyVersion env pkg vsn newDocs publishedVersions =
339− reportSemverCheck vsn $
272+ reportVersionPhase vsn $
340 case publishedVersions of
273 case publishedVersions of
341 Nothing ->
274 Nothing ->
342 if vsn == V.one
275 if vsn == V.one
@@ -360,7 +293,7 @@ verifyBump (Env _ cache manager _ _) pkg vsn newDocs knownVersions@(Registry.Kno
360 do result <- Diff.getDocs cache manager pkg old
293 do result <- Diff.getDocs cache manager pkg old
361 case result of
294 case result of
362 Left dp ->
295 Left dp ->
363− return $ Left $ Exit.PublishCannotGetDocs old new dp
296+ return $ Left $ Exit.PublishCannotGetDocs dp
364
297
365 Right oldDocs ->
298 Right oldDocs ->
366 let
299 let
@@ -378,8 +311,8 @@ verifyBump (Env _ cache manager _ _) pkg vsn newDocs knownVersions@(Registry.Kno
378-- REGISTER PACKAGES
311-- REGISTER PACKAGES
379
312
380
313
381−register :: Http.Manager -> Pkg.Name -> V.Version -> Docs.Documentation -> String -> Http.Sha -> Task.Task Exit.Publish ()
314+register :: Http.Manager -> Pkg.Name -> V.Version -> String -> Http.Sha -> Task.Task Exit.Publish ()
382−register manager pkg vsn docs commitHash sha =
315+register manager pkg vsn commitHash sha =
383 let
316 let
384 url =
317 url =
385 Website.route "/register"
318 Website.route "/register"
@@ -391,7 +324,7 @@ register manager pkg vsn docs commitHash sha =
391 Task.eio Exit.PublishCannotRegister $
324 Task.eio Exit.PublishCannotRegister $
392 Http.upload manager url
325 Http.upload manager url
393 [ Http.filePart "elm.json" "elm.json"
326 [ Http.filePart "elm.json" "elm.json"
394− , Http.jsonPart "docs.json" "docs.json" (Docs.encode docs)
327+ , Http.filePart "docs.json" (error "TODO generate docs, maybe in memory only?")
395 , Http.filePart "README.md" "README.md"
328 , Http.filePart "README.md" "README.md"
396 , Http.stringPart "github-hash" (Http.shaToChars sha)
329 , Http.stringPart "github-hash" (Http.shaToChars sha)
397 ]
330 ]
@@ -401,47 +334,38 @@ register manager pkg vsn docs commitHash sha =
401-- REPORTING
334-- REPORTING
402
335
403
336
404−reportPublishStart :: Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> Task.Task x ()
337+reportPublishStart :: Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> IO ()
405reportPublishStart pkg vsn maybeKnownVersions =
338reportPublishStart pkg vsn maybeKnownVersions =
406− Task.io $
407 case maybeKnownVersions of
339 case maybeKnownVersions of
408 Nothing ->
340 Nothing ->
409 putStrLn $ Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n"
341 putStrLn $ Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n"
410
342
411 Just _ ->
343 Just _ ->
412− putStrLn $ "Verifying " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " ...\n"
344+ putStrLn $ "Verifying" ++ Pkg.toChars pkg ++ V.toChars vsn ++ "...\n"
413
345
414
346
415
347
416-- REPORTING PHASES
348-- REPORTING PHASES
417
349
418
350
419−reportReadmeCheck :: IO (Either x a) -> Task.Task x a
351+reportReadmePhase :: IO (Either x a) -> Task.Task x a
420−reportReadmeCheck =
352+reportReadmePhase =
421− reportCheck
353+ reportPhase
422 "Looking for README.md"
354 "Looking for README.md"
423 "Found README.md"
355 "Found README.md"
424 "Problem with your README.md"
356 "Problem with your README.md"
425
357
426
358
427−reportLicenseCheck :: IO (Either x a) -> Task.Task x a
359+reportLicensePhase :: IO (Either x a) -> Task.Task x a
428−reportLicenseCheck =
360+reportLicensePhase =
429− reportCheck
361+ reportPhase
430 "Looking for LICENSE"
362 "Looking for LICENSE"
431 "Found LICENSE"
363 "Found LICENSE"
432 "Problem with your LICENSE"
364 "Problem with your LICENSE"
433
365
434
366
435−reportBuildCheck :: IO (Either x a) -> Task.Task x a
436−reportBuildCheck =
437− reportCheck
438− "Verifying documentation..."
439− "Verified documentation"
440− "Problem with documentation"
441−
442−
443−reportSemverCheck :: V.Version -> IO (Either x GoodVersion) -> Task.Task x ()
367+reportVersionPhase :: V.Version -> IO (Either x GoodVersion) -> Task.Task x ()
444−reportSemverCheck version work =
368+reportVersionPhase version work =
445 let
369 let
446 vsn = V.toChars version
370 vsn = V.toChars version
447
371
@@ -457,48 +381,48 @@ reportSemverCheck version work =
457 ++ M.toChars magnitude ++ " change, "
381 ++ M.toChars magnitude ++ " change, "
458 ++ V.toChars oldVersion ++ " => " ++ vsn ++ ")"
382 ++ V.toChars oldVersion ++ " => " ++ vsn ++ ")"
459 in
383 in
460− void $ reportCustomCheck waiting success failure work
384+ void $ reportCustomPhase waiting success failure work
461
385
462
386
463−reportTagCheck :: V.Version -> IO (Either x a) -> Task.Task x a
387+reportTagPhase :: V.Version -> IO (Either x a) -> Task.Task x a
464−reportTagCheck vsn =
388+reportTagPhase vsn =
465− reportCheck
389+ reportPhase
466 ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?")
390 ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?")
467 ("Version " ++ V.toChars vsn ++ " is tagged on GitHub")
391 ("Version " ++ V.toChars vsn ++ " is tagged on GitHub")
468 ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!")
392 ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!")
469
393
470
394
471−reportDownloadCheck :: IO (Either x a) -> Task.Task x a
395+reportDownloadPhase :: IO (Either x a) -> Task.Task x a
472−reportDownloadCheck =
396+reportDownloadPhase =
473− reportCheck
397+ reportPhase
474 "Downloading code from GitHub..."
398 "Downloading code from GitHub..."
475 "Code downloaded successfully from GitHub"
399 "Code downloaded successfully from GitHub"
476 "Could not download code from GitHub!"
400 "Could not download code from GitHub!"
477
401
478
402
403+reportBuildPhase :: IO (Either x a) -> Task.Task x a
404+reportBuildPhase =
405+ reportPhase
406+ "Building downloaded code and generated docs..."
407+ "Downloaded code compiles successfully / docs generated\n"
408+ "Cannot compile downloaded code!"
409+
410+
479−reportLocalChangesCheck :: IO (Either x a) -> Task.Task x a
411+reportChangesPhase :: IO (Either x a) -> Task.Task x a
480−reportLocalChangesCheck =
412+reportChangesPhase =
481− reportCheck
413+ reportPhase
482 "Checking for uncommitted changes..."
414 "Checking for uncommitted changes..."
483 "No uncommitted changes in local code"
415 "No uncommitted changes in local code"
484 "Your local code is different than the code tagged on GitHub"
416 "Your local code is different than the code tagged on GitHub"
485
417
486
418
487−reportZipBuildCheck :: IO (Either x a) -> Task.Task x a
488−reportZipBuildCheck =
489− reportCheck
490− "Verifying downloaded code..."
491− "Downloaded code compiles successfully"
492− "Cannot compile downloaded code!"
493−
494−
495−reportCheck :: String -> String -> String -> IO (Either x a) -> Task.Task x a
419+reportPhase :: String -> String -> String -> IO (Either x a) -> Task.Task x a
496−reportCheck waiting success failure work =
420+reportPhase waiting success failure work =
497− reportCustomCheck waiting (\_ -> success) failure work
421+ reportCustomPhase waiting (\_ -> success) failure work
498
422
499
423
500−reportCustomCheck :: String -> (a -> String) -> String -> IO (Either x a) -> Task.Task x a
424+reportCustomPhase :: String -> (a -> String) -> String -> IO (Either x a) -> Task.Task x a
501−reportCustomCheck waiting success failure work =
425+reportCustomPhase waiting success failure work =
502 let
426 let
503 putFlush doc =
427 putFlush doc =
504 Help.toStdout doc >> IO.hFlush IO.stdout
428 Help.toStdout doc >> IO.hFlush IO.stdout
terminal/src/Repl.hs+197−522
@@ -1,36 +1,23 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
3module Repl
2module Repl
4 ( Flags(..)
3 ( Flags(..)
5 , run
4 , run
6− --
7− , Lines(..)
8− , Input(..)
9− , Prefill(..)
10− , CategorizedInput(..)
11− , categorize
12− --
13− , State(..)
14− , Output(..)
15− , toByteString
16 )
5 )
17 where
6 where
18
7
19
8
20import Prelude hiding (lines, read)
9import Prelude hiding (lines, read)
21import Control.Applicative ((<|>))
10import Control.Applicative ((<|>))
22−import Control.Monad.Trans (lift, liftIO)
11+import Control.Monad.RWS (lift, liftIO)
23−import qualified Control.Monad.State.Strict as State
12+import qualified Control.Monad.RWS as RWS
24−import qualified Data.ByteString as BS
25import qualified Data.ByteString.Builder as B
13import qualified Data.ByteString.Builder as B
26−import qualified Data.ByteString.Char8 as BSC
27import qualified Data.ByteString.Lazy as LBS
14import qualified Data.ByteString.Lazy as LBS
28−import qualified Data.ByteString.UTF8 as BS_UTF8
29−import qualified Data.Char as Char
30import qualified Data.List as List
15import qualified Data.List as List
31import qualified Data.Map as Map
16import qualified Data.Map as Map
32import Data.Monoid ((<>))
17import Data.Monoid ((<>))
33−import qualified Data.Name as N
18+import qualified Data.Name as Name
19+import qualified Data.Text as Text
20+import qualified Data.Text.Encoding as Text
34import qualified System.Console.Haskeline as Repl
21import qualified System.Console.Haskeline as Repl
35import qualified System.Directory as Dir
22import qualified System.Directory as Dir
36import qualified System.Exit as Exit
23import qualified System.Exit as Exit
@@ -38,35 +25,16 @@ import System.FilePath ((</>))
38import qualified System.IO as IO
25import qualified System.IO as IO
39import qualified System.Process as Proc
26import qualified System.Process as Proc
40
27
41−import qualified AST.Source as Src
28+import qualified Elm.Compiler as Elm (version)
42−import qualified BackgroundWriter as BW
43−import qualified Build
44−import qualified Elm.Constraint as C
45−import qualified Elm.Details as Details
46−import qualified Elm.Licenses as Licenses
47−import qualified Elm.ModuleName as ModuleName
29+import qualified Elm.Project as Project
48−import qualified Elm.Outline as Outline
49import qualified Elm.Package as Pkg
30import qualified Elm.Package as Pkg
50−import qualified Elm.Version as V
31+import qualified Elm.PerUserCache as PerUserCache
51−import qualified Generate
52−import qualified Parse.Expression as PE
53−import qualified Parse.Declaration as PD
54−import qualified Parse.Module as PM
55−import qualified Parse.Primitives as P
56−import qualified Parse.Space as PS
57−import qualified Parse.Type as PT
58−import qualified Parse.Variable as PV
32+import qualified Parse.Repl as Elm
59−import Parse.Primitives (Row, Col)
60−import qualified Reporting
61−import qualified Reporting.Annotation as A
62import Reporting.Doc ((<+>))
33import Reporting.Doc ((<+>))
63import qualified Reporting.Doc as D
34import qualified Reporting.Doc as D
64−import qualified Reporting.Error.Syntax as ES
65−import qualified Reporting.Exit as Exit
66−import qualified Reporting.Render.Code as Code
67−import qualified Reporting.Report as Report
68import qualified Reporting.Task as Task
35import qualified Reporting.Task as Task
69−import qualified Stuff
36+import qualified Reporting.Progress.Repl as Repl
37+import qualified Reporting.Render.Type.Localizer as L
70
38
71
39
72
40
@@ -75,352 +43,174 @@ import qualified Stuff
75
43
76data Flags =
44data Flags =
77 Flags
45 Flags
78− { _maybeInterpreter :: Maybe FilePath
46+ { _interpreter :: Maybe FilePath
79 , _noColors :: Bool
47 , _noColors :: Bool
80 }
48 }
81
49
82
50
83run :: () -> Flags -> IO ()
51run :: () -> Flags -> IO ()
84−run () flags =
52+run () (Flags maybeAlternateInterpreter noColors) =
53+ do interpreter <- getInterpreter maybeAlternateInterpreter
54+ _ <- Project.getRootWithReplFallback
85− do printWelcomeMessage
55+ printWelcomeMessage
86 settings <- initSettings
56 settings <- initSettings
87− env <- initEnv flags
88− let looper = Repl.runInputT settings (Repl.withInterrupt (loop env initialState))
57+ let manager = Repl.runInputT settings (Repl.withInterrupt loop)
89− exitCode <- State.evalStateT looper initialState
58+ (exitCode,_,_) <- RWS.runRWST manager (interpreter, noColors) initialState
90 Exit.exitWith exitCode
59 Exit.exitWith exitCode
91
60
92
61
93−
62+type Runner =
94−-- WELCOME
95−
96−
97−printWelcomeMessage :: IO ()
98−printWelcomeMessage =
99− let
100− vsn = V.toChars V.compiler
101− title = "Elm" <+> D.fromChars vsn
102− dashes = replicate (70 - length vsn) '-'
103− in
104− D.toAnsi IO.stdout $
105− D.vcat
106− [ D.black "----" <+> D.dullcyan title <+> D.black (D.fromChars dashes)
107− , D.black $ D.fromChars $ "Say :help for help and :exit to exit! More at " <> D.makeLink "repl"
108− , D.black "--------------------------------------------------------------------------------"
109− , D.empty
110− ]
111−
112−
113−
114−-- ENV
115−
116−
117−data Env =
118− Env
119− { _root :: FilePath
63+ RWS.RWST (FilePath, Bool) () State IO
120− , _interpreter :: FilePath
121− , _ansi :: Bool
122− }
123−
124−
125−initEnv :: Flags -> IO Env
126−initEnv (Flags maybeAlternateInterpreter noColors) =
127− do root <- getRoot
128− interpreter <- getInterpreter maybeAlternateInterpreter
129− return $ Env root interpreter (not noColors)
130
64
131
65
132
66
133-- LOOP
67-- LOOP
134
68
135
69
136−data Outcome
137− = Loop State
138− | End Exit.ExitCode
139−
140−
141−type M =
142− State.StateT State IO
143−
144−
145−loop :: Env -> State -> Repl.InputT M Exit.ExitCode
70+loop :: Repl.InputT Runner Exit.ExitCode
146−loop env state =
71+loop =
147 do input <- Repl.handleInterrupt (return Skip) read
72 do input <- Repl.handleInterrupt (return Skip) read
148− outcome <- liftIO (eval env state input)
73+ maybe loop return =<< lift (eval input)
149− case outcome of
150− Loop state ->
151− do lift (State.put state)
152− loop env state
153−
154− End exitCode ->
155− return exitCode
156
74
157
75
158
76
159-- READ
77-- READ
160
78
161
79
162−data Input
163− = Import ModuleName.Raw BS.ByteString
164− | Type N.Name BS.ByteString
165− | Port
166− | Decl N.Name BS.ByteString
167− | Expr BS.ByteString
168− --
169− | Reset
170− | Exit
171− | Skip
172− | Help (Maybe String)
173−
174−
175−read :: Repl.InputT M Input
80+read :: Repl.InputT Runner Input
176read =
81read =
177− do maybeLine <- Repl.getInputLine "> "
82+ readHelp "> " []
178− case maybeLine of
179− Nothing ->
180− return Exit
181
83
182− Just chars ->
183− let
184− lines = Lines (stripLegacyBackslash chars) []
185− in
186− case categorize lines of
187− Done input -> return input
188− Continue p -> readMore lines p
189
84
190−
85+readHelp :: String -> [String] -> Repl.InputT Runner Input
191−readMore :: Lines -> Prefill -> Repl.InputT M Input
86+readHelp starter lines =
192−readMore previousLines prefill =
87+ do input <- Repl.getInputLine starter
193− do input <- Repl.getInputLineWithInitial "| " (renderPrefill prefill, "")
194 case input of
88 case input of
195 Nothing ->
89 Nothing ->
196− return Skip
90+ return Exit
197−
198− Just chars ->
199− let
200− lines = addLine (stripLegacyBackslash chars) previousLines
201− in
202− case categorize lines of
203− Done input -> return input
204− Continue p -> readMore lines p
205−
206−
207−-- For compatibility with 0.19.0 such that readers of "Programming Elm" by @jfairbank
208−-- can get through the REPL section successfully.
209−--
210−-- TODO: remove stripLegacyBackslash in next MAJOR release
211−--
212−stripLegacyBackslash :: [Char] -> [Char]
213−stripLegacyBackslash chars =
214− case chars of
215− [] ->
216− []
217−
218− _:_ ->
219− if last chars == '\\'
220− then init chars
221− else chars
222−
223−
224−data Prefill
225− = Indent
226− | DefStart N.Name
227−
228−
229−renderPrefill :: Prefill -> String
230−renderPrefill lineStart =
231− case lineStart of
232− Indent ->
233− " "
234−
235− DefStart name ->
236− N.toChars name ++ " "
237−
238−
239
91
240−-- LINES
92+ Just line ->
93+ if not (null line) && last line == '\\'
94+ then readHelp "| " (init line : lines)
95+ else return $ toInput $ List.intercalate "\n " $ reverse (line : lines)
241
96
242
97
243−data Lines =
244− Lines
245− { _prevLine :: String
246− , _revLines :: [String]
247− }
248
98
99+-- EVAL
249
100
250−addLine :: [Char] -> Lines -> Lines
251−addLine line (Lines x xs) =
252− Lines line (x:xs)
253
101
102+eval :: Input -> Runner (Maybe Exit.ExitCode)
103+eval input =
104+ case input of
105+ Skip ->
106+ return Nothing
254
107
255−isBlank :: Lines -> Bool
108+ Exit ->
256−isBlank (Lines prev rev) =
109+ return (Just Exit.ExitSuccess)
257− null rev && all (==' ') prev
258
110
111+ Reset ->
112+ do RWS.put initialState
113+ report "<reset>"
259
114
260−isSingleLine :: Lines -> Bool
115+ Help info ->
261−isSingleLine (Lines _ rev) =
116+ report (helpMessage info)
262− null rev
263
117
118+ Code entry ->
119+ Repl.handleInterrupt (report "<cancelled>") $
120+ do state@(State _ imports types defs tricks localizer) <- RWS.get
121+ case entry of
122+ Elm.Import name alias exposing src ->
123+ interpret None $
124+ state
125+ { _imports = Map.insert name src imports
126+ , _localizer = L.replAdd name alias exposing localizer
127+ }
264
128
265−endsWithBlankLine :: Lines -> Bool
129+ Elm.Type name src ->
266−endsWithBlankLine (Lines prev _) =
130+ interpret None $ state { _types = Map.insert name src types }
267− all (==' ') prev
268
131
132+ Elm.Def (Just name) src ->
133+ interpret (Def name) $ state { _defs = Map.insert name src defs }
269
134
270−linesToByteString :: Lines -> BS_UTF8.ByteString
135+ Elm.Def Nothing src ->
271−linesToByteString (Lines prev rev) =
136+ interpret None $ state { _tricks = src : tricks }
272− BS_UTF8.fromString (unlines (reverse (prev:rev)))
273
137
138+ Elm.Other src ->
139+ interpret (Expr src) state
274
140
275−getFirstLine :: Lines -> String
141+ Elm.Annotation ->
276−getFirstLine (Lines x xs) =
142+ report "I cannot handle type annotations."
277− case xs of
278− [] -> x
279− y:ys -> getFirstLine (Lines y ys)
280
143
144+ Elm.Port ->
145+ report "I cannot handle port declarations."
281
146
282
147
148+report :: String -> Runner (Maybe a)
149+report msg =
150+ do liftIO (putStrLn msg)
151+ return Nothing
283
152
284−-- CATEGORIZE INPUT
285
153
154+data Output = None | Def Name.Name | Expr Text.Text
286
155
287−data CategorizedInput
288− = Done Input
289− | Continue Prefill
290
156
157+interpret :: Output -> State -> Runner (Maybe a)
158+interpret def state =
159+ do noColors <- RWS.asks snd
160+ result <- liftIO $ Task.try Repl.reporter $ compile noColors def state
291
161
292−categorize :: Lines -> CategorizedInput
162+ case result of
293−categorize lines
163+ Nothing ->
294− | isBlank lines = Done Skip
164+ return ()
295− | startsWithColon lines = Done (toCommand lines)
296− | startsWithKeyword "import" lines = attemptImport lines
297− | otherwise = attemptDeclOrExpr lines
298
165
166+ Just maybePath ->
167+ do RWS.put (state { _count = _count state + 1 })
168+ maybe (return ()) interpretHelp maybePath
299
169
300−attemptImport :: Lines -> CategorizedInput
170+ return Nothing
301−attemptImport lines =
302− let
303− src = linesToByteString lines
304− parser = P.specialize (\_ _ _ -> ()) PM.chompImport
305− in
306− case P.fromByteString parser (\_ _ -> ()) src of
307− Right (Src.Import (A.At _ name) _ _) ->
308− Done (Import name src)
309
171
310− Left () ->
311− ifFail lines (Import "ERR" src)
312
172
173+interpretHelp :: FilePath -> Runner ()
174+interpretHelp path =
175+ do interpreter <- RWS.asks fst
176+ let proc = (Proc.proc interpreter [path]) { Proc.std_in = Proc.CreatePipe }
177+ liftIO $ Proc.withCreateProcess proc $ \_ _ _ handle ->
178+ do _ <- Proc.waitForProcess handle
179+ Dir.removeFile path
313
180
314−ifFail :: Lines -> Input -> CategorizedInput
315−ifFail lines input =
316− if endsWithBlankLine lines
317− then Done input
318− else Continue Indent
319
181
320
182
321−ifDone :: Lines -> Input -> CategorizedInput
183+-- INPUT
322−ifDone lines input =
323− if isSingleLine lines || endsWithBlankLine lines
324− then Done input
325− else Continue Indent
326
184
327
185
328−attemptDeclOrExpr :: Lines -> CategorizedInput
186+data Input
329−attemptDeclOrExpr lines =
187+ = Skip
330− let
188+ | Exit
331− src = linesToByteString lines
332− exprParser = P.specialize (toExprPosition src) PE.expression
333− declParser = P.specialize (toDeclPosition src) PD.declaration
334− in
335− case P.fromByteString declParser (,) src of
336− Right (decl, _) ->
337− case decl of
338− PD.Value _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> ifDone lines (Decl name src)
339− PD.Union _ (A.At _ (Src.Union (A.At _ name) _ _ )) -> ifDone lines (Type name src)
340− PD.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _ )) -> ifDone lines (Type name src)
341− PD.Port _ _ -> Done Port
342−
343− Left declPosition
344− | startsWithKeyword "type" lines ->
345− ifFail lines (Type "ERR" src)
346−
347− | startsWithKeyword "port" lines ->
348− Done Port
349−
350− | otherwise ->
351− case P.fromByteString exprParser (,) src of
352− Right _ ->
353− ifDone lines (Expr src)
354−
355− Left exprPosition ->
356− if exprPosition >= declPosition then
357− ifFail lines (Expr src)
358− else
359− case P.fromByteString annotation (\_ _ -> ()) src of
360− Right name -> Continue (DefStart name)
361− Left () -> ifFail lines (Decl "ERR" src)
362−
363−
364−startsWithColon :: Lines -> Bool
365−startsWithColon lines =
366− case dropWhile (==' ') (getFirstLine lines) of
367− [] -> False
368− c:_ -> c == ':'
369−
370−
371−toCommand :: Lines -> Input
372−toCommand lines =
373− case drop 1 $ dropWhile (==' ') (getFirstLine lines) of
374− "reset" -> Reset
189+ | Reset
375− "exit" -> Exit
190+ | Help (Maybe String)
376− "quit" -> Exit
191+ | Code Elm.Entry
377− "help" -> Help Nothing
378− rest -> Help (Just (takeWhile (/=' ') rest))
379−
380−
381−startsWithKeyword :: [Char] -> Lines -> Bool
382−startsWithKeyword keyword lines =
383− let
384− line = getFirstLine lines
385− in
386− List.isPrefixOf keyword line &&
387− case drop (length keyword) line of
388− [] -> True
389− c:_ -> not (Char.isAlphaNum c)
390
192
391
193
392−toExprPosition :: BS.ByteString -> ES.Expr -> Row -> Col -> (Row, Col)
194+toInput :: String -> Input
393−toExprPosition src expr row col =
195+toInput string =
394− let
196+ case dropWhile (==' ') string of
395− decl = ES.DeclDef N.replValueToPrint (ES.DeclDefBody expr row col) row col
197+ ":exit" ->
396− in
198+ Exit
397− toDeclPosition src decl row col
398
199
200+ ":help" ->
201+ Help Nothing
399
202
400−toDeclPosition :: BS.ByteString -> ES.Decl -> Row -> Col -> (Row, Col)
203+ ":reset" ->
401−toDeclPosition src decl r c =
204+ Reset
402− let
403− err = ES.ParseError (ES.Declarations decl r c)
404− report = ES.toReport (Code.toSource src) err
405
205
406− (Report.Report _ (A.Region (A.Position row col) _) _ _) = report
206+ ':' : rest ->
407− in
207+ Help (Just (takeWhile (/=' ') rest))
408− (row, col)
409
208
209+ "" ->
210+ Skip
410
211
411−annotation :: P.Parser () N.Name
212+ _ ->
412−annotation =
213+ Code (Elm.parseEntry string)
413− let
414− err _ _ = ()
415− err_ _ _ _ = ()
416− in
417− do name <- PV.lower err
418− PS.chompAndCheckIndent err_ err
419− P.word1 0x3A {-:-} err
420− PS.chompAndCheckIndent err_ err
421− (_, _) <- P.specialize err_ PT.expression
422− PS.checkFreshLine err
423− return name
424
214
425
215
426
216
@@ -429,158 +219,132 @@ annotation =
429
219
430data State =
220data State =
431 State
221 State
222+ { _count :: !Int
432− { _imports :: Map.Map N.Name B.Builder
223+ , _imports :: Map.Map Name.Name Text.Text
433− , _types :: Map.Map N.Name B.Builder
224+ , _types :: Map.Map Name.Name Text.Text
434− , _decls :: Map.Map N.Name B.Builder
225+ , _defs :: Map.Map Name.Name Text.Text
226+ , _tricks :: [Text.Text]
227+ , _localizer :: L.Localizer
435 }
228 }
436
229
437
230
438initialState :: State
231initialState :: State
439initialState =
232initialState =
440− State Map.empty Map.empty Map.empty
233+ State 0 Map.empty Map.empty Map.empty [] L.replEmpty
441
234
442
235
236+compile :: Bool -> Output -> State -> Task.Task (Maybe FilePath)
237+compile noColors output (State count imports types defs tricks localizer) =
238+ let
239+ header =
240+ "module " <> Name.toBuilder Name.replModule <> " exposing (..)\n\n"
443
241
444−-- EVAL
242+ elmSourceCode =
445−
243+ (<>) header $
244+ addLines imports $ addLines types $ addLines defs $
245+ List.foldr (<>) mempty (map Text.encodeUtf8Builder tricks)
446
246
447−eval :: Env -> State -> Input -> IO Outcome
247+ compileForRepl builder maybeName =
448−eval env state@(State imports types decls) input =
248+ Project.compileForRepl noColors localizer (LBS.toStrict (B.toLazyByteString builder)) maybeName
449− Repl.handleInterrupt (putStrLn "<cancelled>" >> return (Loop state)) $
249+ in
450− case input of
250+ case output of
451− Skip ->
251+ None ->
452− return (Loop state)
252+ if Map.null types && Map.null defs && null tricks then
253+ compileForRepl (elmSourceCode <> "unit = ()") Nothing
254+ else
255+ compileForRepl elmSourceCode Nothing
453
256
454− Exit ->
257+ Def name ->
455− return (End Exit.ExitSuccess)
258+ compileForRepl elmSourceCode (Just name)
456
259
457− Reset ->
260+ Expr expr ->
458− do putStrLn "<reset>"
261+ let
459− return (Loop initialState)
262+ name = Name.fromReplCount count
263+ text = Text.replace "\n" "\n " expr
264+ def = Name.toBuilder name <> " =\n " <> Text.encodeUtf8Builder text <> "\n"
265+ in
266+ compileForRepl (elmSourceCode <> def) (Just name)
460
267
461− Help maybeUnknownCommand ->
462− do putStrLn (toHelpMessage maybeUnknownCommand)
463− return (Loop state)
464
268
465− Import name src ->
269+addLines :: Map.Map Name.Name Text.Text -> B.Builder -> B.Builder
466− do let newState = state { _imports = Map.insert name (B.byteString src) imports }
270+addLines dict builder =
467− Loop <$> attemptEval env state newState OutputNothing
271+ Map.foldr (\text b -> Text.encodeUtf8Builder text <> "\n" <> b) builder dict
468
272
469− Type name src ->
470− do let newState = state { _types = Map.insert name (B.byteString src) types }
471− Loop <$> attemptEval env state newState OutputNothing
472
273
473− Port ->
474− do putStrLn "I cannot handle port declarations."
475− return (Loop state)
476
274
477− Decl name src ->
275+-- SETTINGS
478− do let newState = state { _decls = Map.insert name (B.byteString src) decls }
479− Loop <$> attemptEval env state newState (OutputDecl name)
480
276
481− Expr src ->
482− Loop <$> attemptEval env state state (OutputExpr src)
483
277
278+initSettings :: IO (Repl.Settings Runner)
279+initSettings =
280+ do cache <- PerUserCache.getReplRoot
281+ return $
282+ Repl.Settings
283+ { Repl.historyFile = Just (cache </> "history")
284+ , Repl.autoAddHistory = True
285+ , Repl.complete = Repl.completeWord Nothing " \n" lookupCompletions
286+ }
484
287
485
288
486−-- ATTEMPT EVAL
289+lookupCompletions :: String -> Runner [Repl.Completion]
290+lookupCompletions string =
291+ do (State _ imports types defs _ _) <- RWS.get
292+ return $
293+ addMatches string False defs $
294+ addMatches string False types $
295+ addMatches string True imports $
296+ addMatches string False commands []
487
297
488
298
489−data Output
299+commands :: Map.Map Name.Name ()
490− = OutputNothing
300+commands =
491− | OutputDecl N.Name
301+ Map.fromList [ (":exit", ()), (":quit", ()), (":reset", ()), (":help", ()) ]
492− | OutputExpr BS.ByteString
493
302
494
303
495−attemptEval :: Env -> State -> State -> Output -> IO State
304+addMatches :: String -> Bool -> Map.Map Name.Name v -> [Repl.Completion] -> [Repl.Completion]
496−attemptEval (Env root interpreter ansi) oldState newState output =
305+addMatches string isFinished dict completions =
497− do result <-
306+ Map.foldrWithKey (addMatch string isFinished) completions dict
498− BW.withScope $ \scope ->
499− Stuff.withRootLock root $ Task.run $
500− do details <-
501− Task.eio Exit.ReplBadDetails $
502− Details.load Reporting.silent scope root
503
307
504− artifacts <-
505− Task.eio id $
506− Build.fromRepl root details (toByteString newState output)
507
308
508− traverse (Task.mapError Exit.ReplBadGenerate . Generate.repl root details ansi artifacts) (toPrintName output)
309+addMatch :: String -> Bool -> Name.Name -> v -> [Repl.Completion] -> [Repl.Completion]
310+addMatch string isFinished name _ completions =
311+ let suggestion = Name.toString name in
312+ if List.isPrefixOf string suggestion then
313+ Repl.Completion suggestion suggestion isFinished : completions
314+ else
315+ completions
509
316
510− case result of
511− Left exit ->
512− do Exit.toStderr (Exit.replToReport exit)
513− return oldState
514
317
515− Right Nothing ->
516− return newState
517
318
518− Right (Just javascript) ->
319+-- WELCOME
519− do exitCode <- interpret interpreter javascript
520− case exitCode of
521− Exit.ExitSuccess -> return newState
522− Exit.ExitFailure _ -> return oldState
523
320
524
321
525−interpret :: FilePath -> B.Builder -> IO Exit.ExitCode
322+printWelcomeMessage :: IO ()
526−interpret interpreter javascript =
323+printWelcomeMessage =
527 let
324 let
528− createProcess = (Proc.proc interpreter []) { Proc.std_in = Proc.CreatePipe }
325+ title = "Elm" <+> D.fromString elmVersion
326+ dashes = replicate (70 - length elmVersion) '-'
529 in
327 in
530− Proc.withCreateProcess createProcess $ \(Just stdin) _ _ handle ->
328+ D.toAnsi IO.stdout $
531− do B.hPutBuilder stdin javascript
329+ D.vcat
532− IO.hClose stdin
330+ [ D.black "----" <+> D.dullcyan title <+> D.black (D.fromString dashes)
533− Proc.waitForProcess handle
331+ , D.black $ D.fromString $ "Say :help for help and :exit to exit! More at " <> D.makeLink "repl"
534−
332+ , D.black "--------------------------------------------------------------------------------"
535−
333+ , D.empty
536−
537−-- TO BYTESTRING
538−
539−
540−toByteString :: State -> Output -> BS.ByteString
541−toByteString (State imports types decls) output =
542− LBS.toStrict $ B.toLazyByteString $
543− mconcat
544− [ "module ", N.toBuilder N.replModule, " exposing (..)\n"
545− , Map.foldr mappend mempty imports
546− , Map.foldr mappend mempty types
547− , Map.foldr mappend mempty decls
548− , outputToBuilder output
549 ]
334 ]
550
335
551
336
552−outputToBuilder :: Output -> B.Builder
337+elmVersion :: String
553−outputToBuilder output =
338+elmVersion =
554− N.toBuilder N.replValueToPrint <> " =" <>
339+ Pkg.versionToString Elm.version
555− case output of
556− OutputNothing ->
557− " ()\n"
558−
559− OutputDecl _ ->
560− " ()\n"
561−
562− OutputExpr expr ->
563− foldr (\line rest -> "\n " <> B.byteString line <> rest) "\n" (BSC.lines expr)
564−
565−
566−
567−-- TO PRINT NAME
568−
569−
570−toPrintName :: Output -> Maybe N.Name
571−toPrintName output =
572− case output of
573− OutputNothing -> Nothing
574− OutputDecl name -> Just name
575− OutputExpr _ -> Just N.replValueToPrint
576
340
577
341
578
342
579-- HELP MESSAGES
343-- HELP MESSAGES
580
344
581
345
582−toHelpMessage :: Maybe String -> String
346+helpMessage :: Maybe String -> String
583−toHelpMessage maybeBadCommand =
347+helpMessage maybeBadCommand =
584 case maybeBadCommand of
348 case maybeBadCommand of
585 Nothing ->
349 Nothing ->
586 genericHelpMessage
350 genericHelpMessage
@@ -601,44 +365,6 @@ genericHelpMessage =
601
365
602
366
603
367
604−-- GET ROOT
605−
606−
607−getRoot :: IO FilePath
608−getRoot =
609− do maybeRoot <- Stuff.findRoot
610− case maybeRoot of
611− Just root ->
612− return root
613−
614− Nothing ->
615− do cache <- Stuff.getReplCache
616− let root = cache </> "tmp"
617− Dir.createDirectoryIfMissing True (root </> "src")
618− Outline.write root $ Outline.Pkg $
619− Outline.PkgOutline
620− Pkg.dummyName
621− Outline.defaultSummary
622− Licenses.bsd3
623− V.one
624− (Outline.ExposedList [])
625− defaultDeps
626− Map.empty
627− C.defaultElm
628−
629− return root
630−
631−
632−defaultDeps :: Map.Map Pkg.Name C.Constraint
633−defaultDeps =
634− Map.fromList
635− [ (Pkg.core, C.anything)
636− , (Pkg.json, C.anything)
637− , (Pkg.html, C.anything)
638− ]
639−
640−
641−
642-- GET INTERPRETER
368-- GET INTERPRETER
643
369
644
370
@@ -673,54 +399,3 @@ exeNotFound name =
673 ++ "I could not find executable `" ++ name ++ "` on your PATH though!\n\n"
399 ++ "I could not find executable `" ++ name ++ "` on your PATH though!\n\n"
674 ++ "You can install node.js from <http://nodejs.org/>. If it is already installed\n"
400 ++ "You can install node.js from <http://nodejs.org/>. If it is already installed\n"
675 ++ "but has a different name, use the --interpreter flag."
401 ++ "but has a different name, use the --interpreter flag."
676−
677−
678−
679−-- SETTINGS
680−
681−
682−initSettings :: IO (Repl.Settings M)
683−initSettings =
684− do cache <- Stuff.getReplCache
685− return $
686− Repl.Settings
687− { Repl.historyFile = Just (cache </> "history")
688− , Repl.autoAddHistory = True
689− , Repl.complete = Repl.completeWord Nothing " \n" lookupCompletions
690− }
691−
692−
693−lookupCompletions :: String -> M [Repl.Completion]
694−lookupCompletions string =
695− do (State imports types decls) <- State.get
696− return $
697− addMatches string False decls $
698− addMatches string False types $
699− addMatches string True imports $
700− addMatches string False commands []
701−
702−
703−commands :: Map.Map N.Name ()
704−commands =
705− Map.fromList
706− [ (":exit", ())
707− , (":quit", ())
708− , (":reset", ())
709− , (":help", ())
710− ]
711−
712−
713−addMatches :: String -> Bool -> Map.Map N.Name v -> [Repl.Completion] -> [Repl.Completion]
714−addMatches string isFinished dict completions =
715− Map.foldrWithKey (addMatch string isFinished) completions dict
716−
717−
718−addMatch :: String -> Bool -> N.Name -> v -> [Repl.Completion] -> [Repl.Completion]
719−addMatch string isFinished name _ completions =
720− let
721− suggestion = N.toChars name
722− in
723− if List.isPrefixOf string suggestion then
724− Repl.Completion suggestion suggestion isFinished : completions
725− else
726− completions
terminal/impl/Terminal.hs → terminal/src/Terminal/Args.hsrenamed+27−33
@@ -1,7 +1,8 @@
1−module Terminal
1+module Terminal.Args
2− ( app
2+ ( simple
3− , Command(..)
3+ , Interface(..)
4 , Summary(..)
4 , Summary(..)
5+ , complex
5 , Flags, noFlags, flags, (|--)
6 , Flags, noFlags, flags, (|--)
6 , Flag, flag, onOff
7 , Flag, flag, onOff
7 , Parser(..)
8 , Parser(..)
@@ -19,25 +20,23 @@ import qualified System.Environment as Env
19import qualified System.Exit as Exit
20import qualified System.Exit as Exit
20import qualified System.FilePath as FP
21import qualified System.FilePath as FP
21import System.FilePath ((</>))
22import System.FilePath ((</>))
22−import GHC.IO.Encoding (setLocaleEncoding, utf8)
23import System.IO (hPutStr, hPutStrLn, stdout)
23import System.IO (hPutStr, hPutStrLn, stdout)
24import qualified Text.PrettyPrint.ANSI.Leijen as P
24import qualified Text.PrettyPrint.ANSI.Leijen as P
25import qualified Text.Read as Read
25import qualified Text.Read as Read
26
26
27import qualified Elm.Version as V
27import qualified Elm.Version as V
28−import Terminal.Internal
28+import Terminal.Args.Internal
29−import qualified Terminal.Chomp as Chomp
29+import qualified Terminal.Args.Chomp as Chomp
30−import qualified Terminal.Error as Error
30+import qualified Terminal.Args.Error as Error
31
31
32
32
33
33
34−-- COMMAND
34+-- GET
35
35
36
36
37−_command :: String -> P.Doc -> Args args -> Flags flags -> (args -> flags -> IO ()) -> IO ()
37+simple :: String -> P.Doc -> Args args -> Flags flags -> (args -> flags -> IO ()) -> IO ()
38−_command details example args_ flags_ callback =
38+simple details example args_ flags_ callback =
39− do setLocaleEncoding utf8
40− argStrings <- Env.getArgs
39+ do argStrings <- Env.getArgs
41 case argStrings of
40 case argStrings of
42 ["--version"] ->
41 ["--version"] ->
43 do hPutStrLn stdout (V.toChars V.compiler)
42 do hPutStrLn stdout (V.toChars V.compiler)
@@ -56,38 +55,33 @@ _command details example args_ flags_ callback =
56 Error.exitWithError err
55 Error.exitWithError err
57
56
58
57
59−
60−-- APP
61−
62−
63−app :: P.Doc -> P.Doc -> [Command] -> IO ()
58+complex :: P.Doc -> P.Doc -> [Interface] -> IO ()
64−app intro outro commands =
59+complex intro outro interfaces =
65− do setLocaleEncoding utf8
66− argStrings <- Env.getArgs
60+ do argStrings <- Env.getArgs
67 case argStrings of
61 case argStrings of
68 [] ->
62 [] ->
69− Error.exitWithOverview intro outro commands
63+ Error.exitWithOverview intro outro interfaces
70
64
71 ["--help"] ->
65 ["--help"] ->
72− Error.exitWithOverview intro outro commands
66+ Error.exitWithOverview intro outro interfaces
73
67
74 ["--version"] ->
68 ["--version"] ->
75 do hPutStrLn stdout (V.toChars V.compiler)
69 do hPutStrLn stdout (V.toChars V.compiler)
76 Exit.exitSuccess
70 Exit.exitSuccess
77
71
78 command : chunks ->
72 command : chunks ->
79− do case List.find (\cmd -> toName cmd == command) commands of
73+ do case List.find (\iface -> toName iface == command) interfaces of
80 Nothing ->
74 Nothing ->
81− Error.exitWithUnknown command (map toName commands)
75+ Error.exitWithUnknown command (map toName interfaces)
82
76
83− Just (Command _ _ details example args_ flags_ callback) ->
77+ Just (Interface _ _ details example args_ flags_ callback) ->
84 if elem "--help" chunks then
78 if elem "--help" chunks then
85 Error.exitWithHelp (Just command) details example args_ flags_
79 Error.exitWithHelp (Just command) details example args_ flags_
86
80
87 else
81 else
88 case snd $ Chomp.chomp Nothing chunks args_ flags_ of
82 case snd $ Chomp.chomp Nothing chunks args_ flags_ of
89− Right (argsValue, flagsValue) ->
83+ Right (argsValue, flagValue) ->
90− callback argsValue flagsValue
84+ callback argsValue flagValue
91
85
92 Left err ->
86 Left err ->
93 Error.exitWithError err
87 Error.exitWithError err
@@ -162,21 +156,21 @@ findIndex index point chunks =
162 findIndex (index + 1) point cs
156 findIndex (index + 1) point cs
163
157
164
158
165−_complexSuggest :: [Command] -> Int -> [String] -> IO [String]
159+_complexSuggest :: [Interface] -> Int -> [String] -> IO [String]
166−_complexSuggest commands index strings =
160+_complexSuggest interfaces index strings =
167 case strings of
161 case strings of
168 [] ->
162 [] ->
169− return (map toName commands)
163+ return (map toName interfaces)
170
164
171 command : chunks ->
165 command : chunks ->
172 if index == 1 then
166 if index == 1 then
173− return (filter (List.isPrefixOf command) (map toName commands))
167+ return (filter (List.isPrefixOf command) (map toName interfaces))
174 else
168 else
175− case List.find (\cmd -> toName cmd == command) commands of
169+ case List.find (\iface -> toName iface == command) interfaces of
176 Nothing ->
170 Nothing ->
177 return []
171 return []
178
172
179− Just (Command _ _ _ _ args_ flags_ _) ->
173+ Just (Interface _ _ _ _ args_ flags_ _) ->
180 fst $ Chomp.chomp (Just (index-1)) chunks args_ flags_
174 fst $ Chomp.chomp (Just (index-1)) chunks args_ flags_
181
175
182
176
terminal/impl/Terminal/Chomp.hs → terminal/src/Terminal/Args/Chomp.hsrenamed+5−4
@@ -1,5 +1,6 @@
1−{-# LANGUAGE GADTs, Rank2Types #-}
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE Rank2Types #-}
2−module Terminal.Chomp
3+module Terminal.Args.Chomp
3 ( chomp
4 ( chomp
4 )
5 )
5 where
6 where
@@ -7,8 +8,8 @@ module Terminal.Chomp
7
8
8import qualified Data.List as List
9import qualified Data.List as List
9
10
10−import Terminal.Error
11+import Terminal.Args.Error
11−import Terminal.Internal
12+import Terminal.Args.Internal
12
13
13
14
14
15
terminal/impl/Terminal/Error.hs → terminal/src/Terminal/Args/Error.hsrenamed+18−28
@@ -1,5 +1,6 @@
1+{-# LANGUAGE GADTs #-}
1−{-# LANGUAGE GADTs, OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−module Terminal.Error
3+module Terminal.Args.Error
3 ( Error(..)
4 ( Error(..)
4 , ArgError(..)
5 , ArgError(..)
5 , FlagError(..)
6 , FlagError(..)
@@ -23,7 +24,7 @@ import System.IO (hPutStrLn, stderr)
23import qualified Text.PrettyPrint.ANSI.Leijen as P
24import qualified Text.PrettyPrint.ANSI.Leijen as P
24
25
25import Reporting.Suggest as Suggest
26import Reporting.Suggest as Suggest
26−import Terminal.Internal
27+import Terminal.Args.Internal
27
28
28
29
29
30
@@ -186,22 +187,22 @@ flagsToDocs flags docs =
186-- OVERVIEW
187-- OVERVIEW
187
188
188
189
189−exitWithOverview :: P.Doc -> P.Doc -> [Command] -> IO a
190+exitWithOverview :: P.Doc -> P.Doc -> [Interface] -> IO a
190−exitWithOverview intro outro commands =
191+exitWithOverview intro outro interfaces =
191 do exeName <- getExeName
192 do exeName <- getExeName
192 exitSuccess
193 exitSuccess
193 [ intro
194 [ intro
194 , "The most common commands are:"
195 , "The most common commands are:"
195− , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) commands
196+ , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) interfaces
196 , "There are a bunch of other commands as well though. Here is a full list:"
197 , "There are a bunch of other commands as well though. Here is a full list:"
197− , P.indent 4 $ P.dullcyan $ toCommandList exeName commands
198+ , P.indent 4 $ P.dullcyan $ toCommandList exeName interfaces
198 , "Adding the --help flag gives a bunch of additional details about each one."
199 , "Adding the --help flag gives a bunch of additional details about each one."
199 , outro
200 , outro
200 ]
201 ]
201
202
202
203
203−toSummary :: String -> Command -> Maybe P.Doc
204+toSummary :: String -> Interface -> Maybe P.Doc
204−toSummary exeName (Command name summary _ _ (Args args) _ _) =
205+toSummary exeName (Interface name summary _ _ (Args args) _ _) =
205 case summary of
206 case summary of
206 Uncommon ->
207 Uncommon ->
207 Nothing
208 Nothing
@@ -214,10 +215,10 @@ toSummary exeName (Command name summary _ _ (Args args) _ _) =
214 ]
215 ]
215
216
216
217
217−toCommandList :: String -> [Command] -> P.Doc
218+toCommandList :: String -> [Interface] -> P.Doc
218−toCommandList exeName commands =
219+toCommandList exeName interfaces =
219 let
220 let
220− names = map toName commands
221+ names = map toName interfaces
221 width = maximum (map length names)
222 width = maximum (map length names)
222
223
223 toExample name =
224 toExample name =
@@ -271,24 +272,13 @@ exitWithError err =
271 BadArgs argErrors ->
272 BadArgs argErrors ->
272 case argErrors of
273 case argErrors of
273 [] ->
274 [] ->
274− return
275+ error "TODO no possible args"
275− [ reflow $ "I was not expecting any arguments for this command."
276− , reflow $ "Try removing them?"
277− ]
278
276
279 [(_args, argError)] ->
277 [(_args, argError)] ->
280 argErrorToDocs argError
278 argErrorToDocs argError
281
279
282 _:_:_ ->
280 _:_:_ ->
283− argErrorToDocs $ head $ List.sortOn toArgErrorRank (map snd argErrors)
281+ error "TODO show possible arg configurations"
284−
285−
286−toArgErrorRank :: ArgError -> Int -- lower is better
287−toArgErrorRank err =
288− case err of
289− ArgBad _ _ -> 0
290− ArgMissing _ -> 1
291− ArgExtras _ -> 2
292
282
293
283
294toGreen :: String -> P.Doc
284toGreen :: String -> P.Doc
@@ -328,10 +318,10 @@ argErrorToDocs argError =
328 return
318 return
329 [ "I am having trouble with this argument:"
319 [ "I am having trouble with this argument:"
330 , P.indent 4 $ toRed string
320 , P.indent 4 $ toRed string
331− , P.fillSep $
321+ , P.fillSep
332 ["It","is","supposed","to","be","a"
322 ["It","is","supposed","to","be","a"
333− ,toYellow (toToken tipe),"value,","like"
323+ ,toYellow (toToken tipe),"value,","like","this:"
334− ] ++ if length examples == 1 then ["this:"] else ["one","of","these:"]
324+ ]
335 , P.indent 4 $ P.green $ P.vcat $ map P.text examples
325 , P.indent 4 $ P.green $ P.vcat $ map P.text examples
336 ]
326 ]
337
327
terminal/impl/Terminal/Helpers.hs → terminal/src/Terminal/Args/Helpers.hsrenamed+7−20
@@ -1,5 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2−module Terminal.Helpers
2+module Terminal.Args.Helpers
3 ( version
3 ( version
4 , elmFile
4 , elmFile
5 , package
5 , package
@@ -14,13 +14,12 @@ import qualified Data.Map as Map
14import qualified Data.Utf8 as Utf8
14import qualified Data.Utf8 as Utf8
15import qualified System.FilePath as FP
15import qualified System.FilePath as FP
16
16
17−import Terminal (Parser(..))
17+import Terminal.Args (Parser(..))
18import qualified Deps.Registry as Registry
18import qualified Deps.Registry as Registry
19import qualified Elm.Package as Pkg
19import qualified Elm.Package as Pkg
20import qualified Elm.Version as V
20import qualified Elm.Version as V
21import qualified Parse.Primitives as P
21import qualified Parse.Primitives as P
22import qualified Stuff
22import qualified Stuff
23−import qualified Reporting.Suggest as Suggest
24
23
25
24
26
25
@@ -118,17 +117,8 @@ parsePackage chars =
118
117
119
118
120suggestPackages :: String -> IO [String]
119suggestPackages :: String -> IO [String]
121−suggestPackages given =
120+suggestPackages _ =
122− do cache <- Stuff.getPackageCache
123− maybeRegistry <- Registry.read cache
124− return $
121+ return []
125− case maybeRegistry of
126− Nothing ->
127− []
128−
129− Just (Registry.Registry _ versions) ->
130− filter (List.isPrefixOf given) $
131− map Pkg.toChars (Map.keys versions)
132
122
133
123
134examplePackages :: String -> IO [String]
124examplePackages :: String -> IO [String]
@@ -138,11 +128,8 @@ examplePackages given =
138 return $
128 return $
139 case maybeRegistry of
129 case maybeRegistry of
140 Nothing ->
130 Nothing ->
141− [ "elm/json"
142− , "elm/http"
143− , "elm/random"
144− ]
131+ []
145
132
146 Just (Registry.Registry _ versions) ->
133 Just (Registry.Registry _ versions) ->
147− map Pkg.toChars $ take 4 $
134+ filter (List.isPrefixOf given) $
148− Suggest.sort given Pkg.toChars (Map.keys versions)
135+ map Pkg.toChars (Map.keys versions)
terminal/impl/Terminal/Internal.hs → terminal/src/Terminal/Args/Internal.hsrenamed+8−8
@@ -1,6 +1,6 @@
1{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2−module Terminal.Internal
2+module Terminal.Args.Internal
3− ( Command(..)
3+ ( Interface(..)
4 , toName
4 , toName
5 , Summary(..)
5 , Summary(..)
6 , Flags(..)
6 , Flags(..)
@@ -17,11 +17,11 @@ import Text.PrettyPrint.ANSI.Leijen (Doc)
17
17
18
18
19
19
20−-- COMMAND
20+-- INTERFACE
21
21
22
22
23−data Command where
23+data Interface where
24− Command
24+ Interface
25 :: String
25 :: String
26 -> Summary
26 -> Summary
27 -> String
27 -> String
@@ -29,11 +29,11 @@ data Command where
29 -> Args args
29 -> Args args
30 -> Flags flags
30 -> Flags flags
31 -> (args -> flags -> IO ())
31 -> (args -> flags -> IO ())
32− -> Command
32+ -> Interface
33
33
34
34
35−toName :: Command -> String
35+toName :: Interface -> String
36−toName (Command name _ _ _ _ _ _) =
36+toName (Interface name _ _ _ _ _ _) =
37 name
37 name
38
38
39
39
docs/upgrade-instructions/0.16.md → upgrade-docs/0.16.mdrenamed

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

worker/elm.cabal+3−25
@@ -43,26 +43,17 @@ Executable worker
43 src
43 src
44 ../compiler/src
44 ../compiler/src
45 ../builder/src
45 ../builder/src
46− ../terminal/src
47
46
48 Main-Is:
47 Main-Is:
49 Main.hs
48 Main.hs
50
49
51 other-modules:
50 other-modules:
52− Artifacts
53− Cors
54− Endpoint.Compile
55− Endpoint.Quotes
56− Endpoint.Repl
57−
58 AST.Canonical
51 AST.Canonical
59 AST.Optimized
52 AST.Optimized
60 AST.Source
53 AST.Source
61 AST.Utils.Binop
54 AST.Utils.Binop
62 AST.Utils.Shader
55 AST.Utils.Shader
63 AST.Utils.Type
56 AST.Utils.Type
64− BackgroundWriter
65− Build
66 Canonicalize.Effects
57 Canonicalize.Effects
67 Canonicalize.Environment
58 Canonicalize.Environment
68 Canonicalize.Environment.Dups
59 Canonicalize.Environment.Dups
@@ -88,8 +79,6 @@ Executable worker
88 Elm.Compiler.Type.Extract
79 Elm.Compiler.Type.Extract
89 Elm.Constraint
80 Elm.Constraint
90 Elm.Details
81 Elm.Details
91− Elm.Docs
92− Elm.Float
93 Elm.Interface
82 Elm.Interface
94 Elm.Kernel
83 Elm.Kernel
95 Elm.Licenses
84 Elm.Licenses
@@ -97,10 +86,8 @@ Executable worker
97 Elm.ModuleName
86 Elm.ModuleName
98 Elm.Outline
87 Elm.Outline
99 Elm.Package
88 Elm.Package
100− Elm.String
101 Elm.Version
89 Elm.Version
102 File
90 File
103− Generate
104 Generate.Html
91 Generate.Html
105 Generate.JavaScript
92 Generate.JavaScript
106 Generate.JavaScript.Builder
93 Generate.JavaScript.Builder
@@ -111,8 +98,6 @@ Executable worker
111 Http
98 Http
112 Json.Decode
99 Json.Decode
113 Json.Encode
100 Json.Encode
114− Json.String
115− Nitpick.Debug
116 Nitpick.PatternMatches
101 Nitpick.PatternMatches
117 Optimize.Case
102 Optimize.Case
118 Optimize.DecisionTree
103 Optimize.DecisionTree
@@ -129,18 +114,16 @@ Executable worker
129 Parse.Primitives
114 Parse.Primitives
130 Parse.Shader
115 Parse.Shader
131 Parse.Space
116 Parse.Space
132− Parse.String
133 Parse.Symbol
117 Parse.Symbol
134 Parse.Type
118 Parse.Type
119+ Parse.Utf8
135 Parse.Variable
120 Parse.Variable
136 Paths_elm
121 Paths_elm
137− Repl
138 Reporting
122 Reporting
139 Reporting.Annotation
123 Reporting.Annotation
140 Reporting.Doc
124 Reporting.Doc
141 Reporting.Error
125 Reporting.Error
142 Reporting.Error.Canonicalize
126 Reporting.Error.Canonicalize
143− Reporting.Error.Docs
144 Reporting.Error.Import
127 Reporting.Error.Import
145 Reporting.Error.Json
128 Reporting.Error.Json
146 Reporting.Error.Main
129 Reporting.Error.Main
@@ -170,20 +153,18 @@ Executable worker
170 Type.UnionFind
153 Type.UnionFind
171
154
172 Build-depends:
155 Build-depends:
173− aeson,
174 ansi-terminal >= 0.8 && < 0.9,
156 ansi-terminal >= 0.8 && < 0.9,
175 ansi-wl-pprint >= 0.6.8 && < 0.7,
157 ansi-wl-pprint >= 0.6.8 && < 0.7,
176 base >=4.11 && <5,
158 base >=4.11 && <5,
177− base64-bytestring,
178 binary >= 0.8 && < 0.9,
159 binary >= 0.8 && < 0.9,
179 bytestring >= 0.9 && < 0.11,
160 bytestring >= 0.9 && < 0.11,
180 containers >= 0.5.8.2 && < 0.6,
161 containers >= 0.5.8.2 && < 0.6,
181 directory >= 1.2.3.0 && < 2.0,
162 directory >= 1.2.3.0 && < 2.0,
182 edit-distance >= 0.2 && < 0.3,
163 edit-distance >= 0.2 && < 0.3,
164+ file-embed,
183 filelock,
165 filelock,
184 filepath >= 1 && < 2.0,
166 filepath >= 1 && < 2.0,
185 ghc-prim >= 0.5.2,
167 ghc-prim >= 0.5.2,
186− haskeline,
187 HTTP >= 4000.2.5 && < 4000.4,
168 HTTP >= 4000.2.5 && < 4000.4,
188 http-client >= 0.6 && < 0.7,
169 http-client >= 0.6 && < 0.7,
189 http-client-tls >= 0.3 && < 0.4,
170 http-client-tls >= 0.3 && < 0.4,
@@ -194,16 +175,13 @@ Executable worker
194 network >= 2.4 && < 2.7,
175 network >= 2.4 && < 2.7,
195 network-uri,
176 network-uri,
196 parsec,
177 parsec,
197− process,
198− random,
199 raw-strings-qq,
178 raw-strings-qq,
200 scientific,
179 scientific,
201 SHA,
180 SHA,
202 snap-core,
181 snap-core,
203 snap-server,
182 snap-server,
204 template-haskell,
183 template-haskell,
205− text,
206− time >= 1.9.1,
184+ time,
207 unordered-containers,
185 unordered-containers,
208 utf8-string,
186 utf8-string,
209 vector,
187 vector,
worker/elm.jsondeleted−26
@@ -1,26 +0,0 @@
1−{
2− "type": "application",
3− "source-directories": [
4− "src"
5− ],
6− "elm-version": "0.19.1",
7− "dependencies": {
8− "direct": {
9− "elm/browser": "1.0.1",
10− "elm/core": "1.0.2",
11− "elm/html": "1.0.0",
12− "elm/json": "1.1.3",
13− "elm/project-metadata-utils": "1.0.0"
14− },
15− "indirect": {
16− "elm/parser": "1.1.0",
17− "elm/time": "1.0.0",
18− "elm/url": "1.0.0",
19− "elm/virtual-dom": "1.0.2"
20− }
21− },
22− "test-dependencies": {
23− "direct": {},
24− "indirect": {}
25− }
26−}
worker/nginx.confdeleted−22
@@ -1,22 +0,0 @@
1−server {
2− listen 80;
3− server_name worker.elm-lang.org;
4−
5− location / {
6− proxy_pass http://localhost:8000;
7− }
8−}
9−
10−server {
11− listen 443 ssl;
12− server_name worker.elm-lang.org;
13−
14− location / {
15− proxy_pass http://localhost:8000;
16− }
17−
18− ssl_certificate /etc/letsencrypt/live/worker.elm-lang.org/fullchain.pem; # managed by Certbot
19− ssl_certificate_key /etc/letsencrypt/live/worker.elm-lang.org/privkey.pem; # managed by Certbot
20− include /etc/letsencrypt/options-ssl-nginx.conf;
21− ssl_dhparam /etc/letsencrypt/ssl-dhparams.pem;
22−}
worker/outlines/compile/elm.jsondeleted−32
@@ -1,32 +0,0 @@
1−{
2− "type": "application",
3− "source-directories": [
4− "../../src"
5− ],
6− "elm-version": "0.19.1",
7− "dependencies": {
8− "direct": {
9− "elm/browser": "1.0.1",
10− "elm/core": "1.0.2",
11− "elm/file": "1.0.5",
12− "elm/html": "1.0.0",
13− "elm/http": "2.0.0",
14− "elm/json": "1.1.3",
15− "elm/random": "1.0.0",
16− "elm/svg": "1.0.1",
17− "elm/time": "1.0.0",
18− "elm-explorations/linear-algebra": "1.0.3",
19− "elm-explorations/webgl": "1.1.0",
20− "evancz/elm-playground": "1.0.2"
21− },
22− "indirect": {
23− "elm/bytes": "1.0.8",
24− "elm/url": "1.0.0",
25− "elm/virtual-dom": "1.0.2"
26− }
27− },
28− "test-dependencies": {
29− "direct": {},
30− "indirect": {}
31− }
32−}
worker/outlines/repl/elm.jsondeleted−19
@@ -1,19 +0,0 @@
1−{
2− "type": "application",
3− "source-directories": [
4− "../../src"
5− ],
6− "elm-version": "0.19.1",
7− "dependencies": {
8− "direct": {
9− "elm/core": "1.0.2"
10− },
11− "indirect": {
12− "elm/json": "1.1.3"
13− }
14− },
15− "test-dependencies": {
16− "direct": {},
17− "indirect": {}
18− }
19−}
worker/src/Artifacts.hsdeleted−155
@@ -1,155 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Artifacts
3− ( Artifacts(..)
4− , loadCompile
5− , loadRepl
6− , toDepsInfo
7− )
8− where
9−
10−
11−import Control.Concurrent (readMVar)
12−import Control.Monad (liftM2)
13−import qualified Data.ByteString as BS
14−import qualified Data.ByteString.Builder as B
15−import qualified Data.ByteString.Lazy as LBS
16−import qualified Data.Map as Map
17−import qualified Data.Name as N
18−import qualified Data.OneOrMore as OneOrMore
19−import qualified System.Directory as Dir
20−import System.FilePath ((</>))
21−
22−import qualified AST.Canonical as Can
23−import qualified AST.Optimized as Opt
24−import qualified BackgroundWriter as BW
25−import qualified Elm.Details as Details
26−import qualified Elm.Interface as I
27−import qualified Elm.ModuleName as ModuleName
28−import qualified Elm.Package as Pkg
29−import Json.Encode ((==>))
30−import qualified Json.Encode as E
31−import qualified Json.String as Json
32−import qualified Reporting
33−
34−
35−
36−-- ARTIFACTS
37−
38−
39−data Artifacts =
40− Artifacts
41− { _ifaces :: Map.Map ModuleName.Raw I.Interface
42− , _graph :: Opt.GlobalGraph
43− }
44−
45−
46−loadCompile :: IO Artifacts
47−loadCompile =
48− load ("outlines" </> "compile")
49−
50−
51−loadRepl :: IO Artifacts
52−loadRepl =
53− load ("outlines" </> "repl")
54−
55−
56−
57−-- LOAD
58−
59−
60−load :: FilePath -> IO Artifacts
61−load dir =
62− BW.withScope $ \scope ->
63− do putStrLn $ "Loading " ++ dir </> "elm.json"
64− style <- Reporting.terminal
65− root <- fmap (</> dir) Dir.getCurrentDirectory
66− result <- Details.load style scope root
67− case result of
68− Left _ ->
69− error $ "Ran into some problem loading elm.json\nTry running `elm make` in: " ++ dir
70−
71− Right details ->
72− do omvar <- Details.loadObjects root details
73− imvar <- Details.loadInterfaces root details
74− mdeps <- readMVar imvar
75− mobjs <- readMVar omvar
76− case liftM2 (,) mdeps mobjs of
77− Nothing ->
78− error $ "Ran into some weird problem loading elm.json\nTry running `elm make` in: " ++ dir
79−
80− Just (deps, objs) ->
81− return $ Artifacts (toInterfaces deps) objs
82−
83−
84−toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
85−toInterfaces deps =
86− Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
87− Map.elems (Map.mapMaybeWithKey getPublic deps)
88−
89−
90−getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
91−getPublic (ModuleName.Canonical _ name) dep =
92− case dep of
93− I.Public iface -> Just (name, OneOrMore.one iface)
94− I.Private _ _ _ -> Nothing
95−
96−
97−toUnique :: OneOrMore.OneOrMore a -> Maybe a
98−toUnique oneOrMore =
99− case oneOrMore of
100− OneOrMore.One value -> Just value
101− OneOrMore.More _ _ -> Nothing
102−
103−
104−
105−-- TO DEPS INFO
106−
107−
108−toDepsInfo :: Artifacts -> BS.ByteString
109−toDepsInfo (Artifacts ifaces _) =
110− LBS.toStrict $ B.toLazyByteString $ E.encodeUgly $ encode ifaces
111−
112−
113−
114−-- ENCODE
115−
116−
117−encode :: Map.Map ModuleName.Raw I.Interface -> E.Value
118−encode ifaces =
119− E.dict Json.fromName encodeInterface ifaces
120−
121−
122−encodeInterface :: I.Interface -> E.Value
123−encodeInterface (I.Interface pkg values unions aliases binops) =
124− E.object
125− [ "pkg" ==> E.chars (Pkg.toChars pkg)
126− , "ops" ==> E.list E.name (Map.keys binops)
127− , "values" ==> E.list E.name (Map.keys values)
128− , "aliases" ==> E.list E.name (Map.keys (Map.filter isPublicAlias aliases))
129− , "types" ==> E.dict Json.fromName (E.list E.name) (Map.mapMaybe toPublicUnion unions)
130− ]
131−
132−
133−isPublicAlias :: I.Alias -> Bool
134−isPublicAlias alias =
135− case alias of
136− I.PublicAlias _ -> True
137− I.PrivateAlias _ -> False
138−
139−
140−toPublicUnion :: I.Union -> Maybe [N.Name]
141−toPublicUnion union =
142− case union of
143− I.OpenUnion (Can.Union _ variants _ _) ->
144− Just (map getVariantName variants)
145−
146− I.ClosedUnion _ ->
147− Just []
148−
149− I.PrivateUnion _ ->
150− Nothing
151−
152−
153−getVariantName :: Can.Ctor -> N.Name
154−getVariantName (Can.Ctor name _ _ _) =
155− name
worker/src/Cors.hsdeleted−48
@@ -1,48 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Cors
3− ( allow
4− )
5− where
6−
7−
8−import qualified Data.HashSet as HashSet
9−import Network.URI (parseURI)
10−import Snap.Core (Snap, Method, method)
11−import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)
12−
13−
14−
15−-- ALLOW
16−
17−
18−allow :: Method -> [String] -> Snap () -> Snap ()
19−allow method_ origins snap =
20− applyCORS (toOptions method_ origins) $ method method_ $
21− snap
22−
23−
24−
25−-- TO OPTIONS
26−
27−
28−toOptions :: (Monad m) => Method -> [String] -> CORSOptions m
29−toOptions method_ origins =
30− let
31− allowedOrigins = toOriginList origins
32− allowedMethods = HashSet.singleton (HashableMethod method_)
33− in
34− CORSOptions
35− { corsAllowOrigin = return allowedOrigins
36− , corsAllowCredentials = return True
37− , corsExposeHeaders = return HashSet.empty
38− , corsAllowedMethods = return allowedMethods
39− , corsAllowedHeaders = return
40− }
41−
42−
43−toOriginList :: [String] -> OriginList
44−toOriginList origins =
45− Origins $ mkOriginSet $
46− case traverse parseURI origins of
47− Just uris -> uris
48− Nothing -> error "invalid entry given to toOriginList list"
worker/src/Endpoint/Compile.hsdeleted−323
@@ -1,323 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
3−module Endpoint.Compile
4− ( endpoint_V1
5− , endpoint_V2
6− , loadErrorJS
7− )
8− where
9−
10−
11−import qualified Data.ByteString as B
12−import qualified Data.ByteString.Builder as B
13−import qualified Data.ByteString.Lazy as LBS
14−import qualified Data.Map as Map
15−import qualified Data.Map.Utils as Map
16−import qualified Data.Name as N
17−import qualified Data.NonEmptyList as NE
18−import Snap.Core
19−import Snap.Util.FileUploads
20−import qualified System.Directory as Dir
21−import qualified System.IO.Streams as Stream
22−import Text.RawString.QQ (r)
23−
24−import qualified Artifacts as A
25−import qualified Cors
26−
27−import qualified AST.Source as Src
28−import qualified AST.Canonical as Can
29−import qualified AST.Optimized as Opt
30−import qualified BackgroundWriter as BW
31−import qualified Build
32−import qualified Compile
33−import qualified Elm.Details as Details
34−import qualified Elm.Interface as I
35−import qualified Elm.ModuleName as ModuleName
36−import qualified Elm.Package as Pkg
37−import qualified File
38−import qualified Generate
39−import qualified Generate.Html as Html
40−import qualified Generate.JavaScript as JS
41−import qualified Generate.Mode as Mode
42−import qualified Json.Encode as Encode
43−import qualified Parse.Module as Parse
44−import qualified Reporting
45−import qualified Reporting.Annotation as A
46−import Reporting.Doc ((<>))
47−import qualified Reporting.Doc as D
48−import qualified Reporting.Error as Error
49−import qualified Reporting.Error.Import as Import
50−import qualified Reporting.Exit as Exit
51−import qualified Reporting.Exit.Help as Help
52−import qualified Reporting.Task as Task
53−
54−
55−
56−-- ALLOWED ORIGINS
57−
58−
59−allowedOrigins :: [String]
60−allowedOrigins =
61− [ "https://elm-lang.org"
62− , "https://package.elm-lang.org"
63− ]
64−
65−
66−
67−-- ENDPOINT (V1)
68−
69−
70−endpoint_V1 :: A.Artifacts -> Snap ()
71−endpoint_V1 artifacts =
72− endpoint artifacts $ \result ->
73− case result of
74− Ok name js -> writeBuilder $ Html.sandwich name js
75− Err report -> writeBuilder $ renderProblem_V1 report
76−
77−
78−
79−-- ENDPOINT (V2)
80−
81−
82−endpoint_V2 :: A.Artifacts -> Snap ()
83−endpoint_V2 artifacts =
84− endpoint artifacts $ \result ->
85− case result of
86− Ok name js -> writeBuilder $ renderSuccess_V2 name js
87− Err report -> writeBuilder $ renderProblem_V2 report
88−
89−
90−
91−-- ENDPOINT
92−
93−
94−data Result
95− = Ok N.Name B.Builder
96− | Err Help.Report
97−
98−
99−endpoint :: A.Artifacts -> (Result -> Snap ()) -> Snap ()
100−endpoint artifacts callback =
101− Cors.allow POST allowedOrigins $
102− do result <- foldMultipart defaultUploadPolicy ignoreFile 0
103− case result of
104− ([("code",source)], 0) ->
105− do modifyResponse $ setContentType "text/html; charset=utf-8"
106− callback $
107− case compile artifacts source of
108− Success name js -> Ok name js
109− NoMain -> Err noMain
110− BadInput name err -> Err $ Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []
111−
112− _ ->
113− do modifyResponse $ setResponseStatus 400 "Bad Request"
114− modifyResponse $ setContentType "text/html; charset=utf-8"
115− writeBS
116− "<p>Unexpected request format. This should not be possible!</p>\
117− \<p>Please report this\
118− \ <a href=\"https://github.com/elm/compiler/issues\">here</a>\
119− \ along with the URL and your browser version.</p>"
120−
121−
122−ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
123−ignoreFile _ _ count =
124− return (count + 1)
125−
126−
127−
128−-- COMPILE
129−
130−
131−data Outcome
132− = Success N.Name B.Builder
133− | NoMain
134− | BadInput ModuleName.Raw Error.Error
135−
136−
137−compile :: A.Artifacts -> B.ByteString -> Outcome
138−compile (A.Artifacts interfaces objects) source =
139− case Parse.fromByteString Parse.Application source of
140− Left err ->
141− BadInput N._Main (Error.BadSyntax err)
142−
143− Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
144− case checkImports interfaces imports of
145− Left err ->
146− BadInput (Src.getName modul) (Error.BadImports err)
147−
148− Right ifaces ->
149− case Compile.compile Pkg.dummyName ifaces modul of
150− Left err ->
151− BadInput (Src.getName modul) err
152−
153− Right (Compile.Artifacts canModule _ locals) ->
154− case locals of
155− Opt.LocalGraph Nothing _ _ ->
156− NoMain
157−
158− Opt.LocalGraph (Just main_) _ _ ->
159− let
160− mode = Mode.Dev Nothing
161− home = Can._name canModule
162− name = ModuleName._module home
163− mains = Map.singleton home main_
164− graph = Opt.addLocalGraph locals objects
165− in
166− Success name $ JS.generate mode graph mains
167−
168−
169−checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
170−checkImports interfaces imports =
171− let
172− importDict = Map.fromValues Src.getImportName imports
173− missing = Map.difference importDict interfaces
174− in
175− case Map.elems missing of
176− [] ->
177− Right (Map.intersection interfaces importDict)
178−
179− i:is ->
180− let
181− unimported =
182− Map.keysSet (Map.difference interfaces importDict)
183−
184− toError (Src.Import (A.At region name) _ _) =
185− Import.Error region name unimported Import.NotFound
186− in
187− Left (fmap toError (NE.List i is))
188−
189−
190−
191−-- RENDER PROBLEM (V1)
192−
193−
194−renderProblem_V1 :: Help.Report -> B.Builder
195−renderProblem_V1 report =
196− [r|<!DOCTYPE HTML>
197−<html>
198−<head>
199− <meta charset="UTF-8">
200− <style>body { padding: 0; margin: 0; background-color: black; }</style>
201− <script src="https://worker.elm-lang.org/compile/errors.js"></script>
202−</head>
203−<body>
204− <script>
205− var app = Elm.Errors.init({flags:|] <> Encode.encodeUgly (Exit.toJson report) <> [r|});
206− app.ports.jumpTo.subscribe(function(region) {
207− window.parent.postMessage(JSON.stringify(region), "*");
208− });
209− </script>
210−</body>
211−</html>|]
212−
213−
214−
215−-- RENDER SUCCESS (V2)
216−
217−
218−renderSuccess_V2 :: N.Name -> B.Builder -> B.Builder
219−renderSuccess_V2 moduleName javascript =
220− let name = N.toBuilder moduleName in
221− [r|<!DOCTYPE HTML>
222−<html>
223−<head>
224− <meta charset="UTF-8">
225− <title>|] <> name <> [r|</title>
226− <style>body { padding: 0; margin: 0; }</style>
227−</head>
228−
229−<body>
230−
231−<pre id="elm"></pre>
232−
233−<script>
234−window.parent.postMessage("SUCCESS", "*");
235−
236−try {
237−|] <> javascript <> [r|
238−
239− var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
240−}
241−catch (e)
242−{
243− // display initialization errors (e.g. bad flags, infinite recursion)
244− var header = document.createElement("h1");
245− header.style.fontFamily = "monospace";
246− header.innerText = "Initialization Error";
247− var pre = document.getElementById("elm");
248− document.body.insertBefore(header, pre);
249− pre.innerText = e;
250− throw e;
251−}
252−</script>
253−
254−</body>
255−</html>|]
256−
257−
258−
259−-- RENDER PROBLEM (V2)
260−
261−
262−renderProblem_V2 :: Help.Report -> B.Builder
263−renderProblem_V2 report =
264− [r|<!DOCTYPE HTML>
265−<html>
266−<head>
267− <meta charset="UTF-8">
268− <style>body { padding: 0; margin: 0; display: none; }</style>
269−</head>
270−<body>
271− <script>
272− var errors = |] <> Encode.encodeUgly (Exit.toJson report) <> [r|;
273− window.parent.postMessage(JSON.stringify(errors), "*");
274− </script>
275−</body>
276−</html>|]
277−
278−
279−
280−-- NO MAIN
281−
282−
283−noMain :: Help.Report
284−noMain =
285− Help.report "NO MAIN" Nothing
286− (
287− "Without a `main` value, I do not know what to show on screen!"
288− )
289− [ D.reflow $
290− "Adding a `main` value can be as brief as:"
291− , D.vcat
292− [ D.fillSep [D.cyan "import","Html"]
293− , ""
294− , D.fillSep [D.green "main","="]
295− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
296− ]
297− , D.reflow $
298− "Try adding something like that!"
299− , D.toSimpleNote $
300− "I recommend looking through https://guide.elm-lang.org for more advice on\
301− \ how to fill in `main` values."
302− ]
303−
304−
305−
306−-- LOAD ERROR JS
307−
308−
309−loadErrorJS :: IO B.ByteString
310−loadErrorJS =
311− let
312− run work =
313− do result <- work
314− case result of
315− Right a -> return a
316− Left _ -> error "problem building src/Errors.elm"
317− in
318− BW.withScope $ \scope ->
319− do root <- Dir.getCurrentDirectory
320− details <- run $ Details.load Reporting.silent scope root
321− artifacts <- run $ Build.fromPaths Reporting.silent root details (NE.List "src/Errors.elm" [])
322− javascript <- run $ Task.run $ Generate.prod root details artifacts
323− return $ LBS.toStrict $ B.toLazyByteString javascript
worker/src/Endpoint/Quotes.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
2−module Endpoint.Quotes
3− ( endpoint
4− )
5− where
6−
7−
8−import Control.Monad.IO.Class (liftIO)
9−import qualified Data.ByteString as BS
10−import GHC.Int (Int(I#))
11−import GHC.Prim
12−import GHC.ST (ST(ST), runST)
13−import qualified System.Random as Random
14−
15−import Snap.Core
16−
17−
18−
19−-- ENDPOINT
20−
21−
22−endpoint :: Snap ()
23−endpoint =
24− do modifyResponse
25− $ setContentType "application/json"
26− . setHeader "Access-Control-Allow-Origin" "*"
27− writeBS =<< liftIO getQuote
28−
29−
30−getQuote :: IO BS.ByteString
31−getQuote =
32− let
33− (Quotes sa#) = quotes
34− in
35− do (I# i#) <- Random.randomRIO (0, I# (sizeofSmallArray# sa# -# 1#))
36− case indexSmallArray# sa# i# of
37− (# json #) ->
38− return json
39−
40−
41−
42−-- QUOTES
43−
44−
45−data Quotes =
46− Quotes (SmallArray# BS.ByteString)
47−
48−
49−quotes :: Quotes
50−quotes =
51− let
52− !(I# len#) = length quoteList
53− in
54− runST $ ST $ \s ->
55− case newSmallArray# len# "" s of
56− (# s, sma# #) ->
57− case quotesHelp# sma# quoteList s of
58− s ->
59− case unsafeFreezeSmallArray# sma# s of
60− (# s, sa# #) ->
61− (# s, Quotes sa# #)
62−
63−
64−quotesHelp# :: SmallMutableArray# s a -> [a] -> State# s -> State# s
65−quotesHelp# sma# =
66− go 0#
67− where
68− go i# list s =
69− case list of
70− [] ->
71− s
72−
73− x:xs ->
74− case writeSmallArray# sma# i# x s of
75− s ->
76− go (i# +# 1#) xs s
77−
78−
79−quoteList :: [BS.ByteString]
80−quoteList =
81− [ "{\"source\":\"Civilization and its Discontents\",\"author\":\"Sigmund Freud\",\"year\":1902,\"quote\":\"The enormous expansion of communications, due to the world-wide telegraph and telephone networks, has entirely transformed the conditions of trade and commerce. Everything is done in haste, at fever pitch. The night is used for travel, the day for business; even \\u201Choliday trips\\u201D put a strain on the nervous system. Great political, industrial and financial crises carry this excitement into far wider areas of the population than ever before. Interest in political life has become universal: tempers are inflamed by political, religious and social struggles, party politics, electioneering and the immense growth of trade-unionism; people are forced to engage in constant mental activity and robbed of the time the need for relaxation, sleep and rest.\"}"
82− , "{\"source\":\"A Preface to Politics\",\"author\":\"Walter Lippmann\",\"year\":1913,\"quote\":\"The Economic Man\\u2014that lazy abstraction\\u2014is still paraded in the lecture room.\"}"
83− , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"You ask me to say what you should consider it particularly important to avoid. My answer is this: a mass crowd. It is something to which you cannot entrust yourself yet without risk. I at any rate am ready to confess my own frailty in this respect. I never come back home with quite the same moral character as I went out with.\"}"
84− , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"December used to be a month but it is now a year\"}"
85− , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"But nothing is as ruinous to the character as sitting away one\\u2019s time at a show - for it is then, through the medium of entertainment, that vices creep into one with more than usual ease.\"}"
86− , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"All this hurrying from place to place won\\u2019t bring you any relief, for you\\u2019re travelling in the company of your own emotions, followed by your troubles all the way. If only they were really following you! They\\u2019d be farther away from you: as it is they\\u2019re not at your back, but on it! That\\u2019s why they weigh you down with just the same uncomfortable chafing wherever you are. It\\u2019s medicine, not a particular part of the world, that a person needs if he\\u2019s ill. Suppose someone has broken his leg or dislocated a joint; he doesn\\u2019t get into a carriage or board a ship: he calls in a doctor to have the fracture set or the dislocation reduced. Well then, when a person\\u2019s spirit is wrenched or broken at so many points, do you imagine that it can be put right by a change of scenery, that that sort of trouble isn\\u2019t so serious that it can\\u2019t be cured by an outing?\"}"
87− , "{\"source\":\"Progress and Poverty\",\"author\":\"Henry George\",\"year\":1879,\"quote\":\"The present century has been marked by a prodigious increase in wealth-producing power. The utilization of steam and electricity, the introduction of improved processes and laborsaving machinery, the greater subdivision and grander scale of production, the wonderful facilitation of exchanges, have multiplied enormously the effectiveness of labor. At the beginning of this marvelous era it was natural to expect, and it was expected, that laborsaving inventions would lighten the toil and improve the condition of the laborer; that the enormous increase in the power of producing wealth would make real poverty a thing of the past.\"}"
88− , "{\"source\":\"Imperialism\",\"author\":\"John Hobson\",\"year\":1902,\"quote\":\"Although the new Imperialism has been bad business for the nation, it has been good business for certain classes and certain trades within the nation. The vast expenditure on armaments, the costly wars, the grave risks and embarrassments of foreign policy, the stoppage of political and social reforms within Great Britain, though fraught with great injury to the nation, have served well the present business interests of certain industries and professions.\"}"
89− , "{\"source\":\"Neo-Colonialism\",\"author\":\"Kwame Nkrumah\",\"year\":1965,\"quote\":\"The essence of neo-colonialism is that the State which is subject to it is, in theory, independent and has all the outward trappings of international sovereignty. In reality its economic system and thus its political policy is directed from the outside. The methods and form of this direction can take various shapes. For example, in an extreme case the troops of the imperial power may garrison the territory of the neo-colonial State and control the government of it. More often, however, neo-colonialist control is exercised through economic or monetary means. The neo-colonial State may be obliged to take the manufactured products of the imperialist power to the exclusion of competing products from elsewhere. Control over government policy in the neo-colonial State may be secured by payments towards the cost of running the State, by the provision of civil servants in positions where they can dictate policy, and by monetary control over foreign exchange through the imposition of a banking system controlled by the imperial power.\"}"
90− , "{\"source\":\"Neo-Colonialism\",\"author\":\"Kwame Nkrumah\",\"year\":1965,\"quote\":\"In the end the situation arises that the only type of aid which the neo-colonialist masters consider as safe is \\u2018military aid\\u2019. Once a neo-colonialist territory is brought to such a state of economic chaos and misery that revolt actually breaks out then, and only then, is there no limit to the generosity of the neo-colonial overlord, provided, of course, that the funds supplied are utilised exclusively for military purposes. Military aid in fact marks the last stage of neo-colonialism and its effect is self-destructive. Sooner or later the weapons supplied pass into the hands of the opponents of the neo-colonialist regime and the war itself increases the social misery which originally provoked it.\"}"
91− , "{\"source\":\"Barnyard in your Backyard\",\"author\":\"Gail Damerow\",\"year\":2002,\"quote\":\"Wild jungle fowl, the ancestors of modern chickens, met their nutritional needs by consuming a variety of plants and insects. Given enough room to roam, some of today\\u2019s breeds remain active foragers.\"}"
92− , "{\"source\":\"Barnyard in your Backyard\",\"author\":\"Gail Damerow\",\"year\":2002,\"quote\":\"Another way to reduce the cost of feed is to let your chickens roam on a lawn or in a pasture for part of the day. By eating plants, seeds, and insects, they will balance their diet and eat less of the expensive commercial stuff. Take care not to put your chickens on grass or around buildings that have been sprayed with toxins.\"}"
93− , "{\"source\":\"Co-operation in Danish Agriculture\",\"author\":\"Harald Faber\",\"year\":1918,\"quote\":\"A plan for improving the butter made from the milk from peasant farms by collecting the milk to be worked at one place was submitted to the Royal Agricultural Society of Denmark as early as 1852, and it pointed out that this could be done on co-operative lines, the peasants being the owners of the factory and sharing the proceeds.\"}"
94− , "{\"source\":\"Co-operation in Danish Agriculture\",\"author\":\"Harald Faber\",\"year\":1918,\"quote\":\"It was the Danish peasants themselves who found a practical way of developing the dairy industry, and they found this by applying the co-operative principles introduced by the Rochdale weavers. They received no support and only lukewarm sympathy from large farmers and estate owners, until later on when the co-operative dairies were doing so well that even owners of estates with two to three hundred cows found it to their advantage to close their private dairies and to join co-operative dairies.\"}"
95− , "{\"source\":\"Beekeeping: A Practical Guide\",\"author\":\"Richard Bonney\",\"year\":1993,\"quote\":\"How many of you have been in a classroom or a training program where the instructor says at the outset, \\u201CLook at the person on your right; now look at the person on your left. One of you won\\u2019t be here next year.\\u201D Beekeeping is like that. Furthermore, not all beekeepers are truly beekeepers. Some are beehavers.\"}"
96− , "{\"source\":\"The Rodale Book of Composting\",\"author\":\"Deborah Martin and Grace Gershuny\",\"year\":1992,\"quote\":\"Earthworms. If bacteria are the champion microscopic decomposers, then the heavyweight champion is doubtless the earthworm. Pages of praise have been written to the earthworm, ever since it became known that this creature spends most of its time tilling and enriching the soil.\"}"
97− , "{\"source\":\"War is a Racket\",\"author\":\"General Smedley Butler\",\"year\":1935,\"quote\":\"There are 40,000,000 men under arms in the world today, and our statesmen and diplomats have the temerity to say that war is not in the making. Hell\\u2019s bells! Are these 40,000,000 men being trained to be dancers?\"}"
98− , "{\"source\":\"Root Cellaring\",\"author\":\"Mike and Nancy Bubel\",\"year\":1991,\"quote\":\"What is not so widely acknowledged is that the soil in which your plants grow can influence the keeping quality of the vegetables you harvest. According to studies reported in E. P. Shirakov\\u2019s \\u201CPractical Course in Storage and Processing of Fruits and Vegetables\\u201D, abundant potash in the soil promotes long storage life of fruits and vegetables grown on that soil.\"}"
99− , "{\"source\":\"Angora Goats the Northern Way\",\"author\":\"Susan Black Drummond\",\"year\":1985,\"quote\":\"Because of its long wearing qualities and resistance to soil, mohair was once a major upholstery fabric in this country, and was the seat cover material in many cars and in British Railroad seats. The synthetic fiber craze put an end to mohair use as upholstery fabric here.\"}"
100− , "{\"source\":\"Making a Newspaper\",\"author\":\"John Given\",\"year\":1912,\"quote\":\"Yellow journalism originated through a desire to gain readers and advertisers, and it produced results. Its original disciples have readers by the hundred thousand and they have about all the advertising that they can well handle.\"}"
101− , "{\"source\":\"Making a Newspaper\",\"author\":\"John Given\",\"year\":1912,\"quote\":\"With the adding of every new train and the improvement of every new time-table, the building of every new trolley road, and the establishment of every new mail route, the big city papers are enabled to reach out further, and, wherever they reach, the local papers suffer [...] There is not a paper published in any city between New York and Boston that has not in the last ten years been hurt by the papers of these two cities.\"}"
102− , "{\"source\":\"Muscles: Testing and Function (4th Edition)\",\"author\":\"Florence Kendall, Elizabeth McCreary, Patricia Provance\",\"year\":1993,\"quote\":\"The mechanics of the low back is inseparable from that of the overall posture but especially that of the pelvis and the lower extremities. Pain manifested in the leg may be due to an underlying problem in the back. Conversely, the symptoms appearing in the low back may be due to underlying faulty mechanics of the feet, legs, or pelvis.\"}"
103− , "{\"source\":\"Farmers of Forty Centuries\",\"author\":\"F. H. King\",\"year\":1911,\"quote\":\"The Sikiang is one of the great rivers of China and indeed of the world. Its width at Wuchow at low water was nearly a mile and our steamer anchored in twenty-four feet of water to a floating dock made fast by huge iron chains reaching three hundred feet up the slop to the city proper, thus providing for a rise of twenty-six feet in the river at its flood stage during the rainy season.\"}"
104− , "{\"source\":\"How to Grow More Vegetables\",\"author\":\"John Jeavons\",\"year\":1974,\"quote\":\"If you are having trouble with birds eating the berries in your berry patch, you could erect a wren house in the middle of it. Wrens are insectivores, and they will not bother the berries. But they will attack any bird, however large, that comes near their nest.\"}"
105− , "{\"source\":\"Confidence Men and Painted Women\",\"author\":\"Karen Halttunen\",\"year\":1982,\"quote\":\"Even one\\u2019s neighbor next door, as a visitor to Pittsburgh commented in 1818, might be a stranger: \\u201CA next door neighbor is, with them, frequently unknown, and months and years pass, without their exchanging with each other the ordinary compliments of friendship and goodwill.\\u201D\"}"
106− , "{\"source\":\"Secondhand Time\",\"author\":\"Svetlana Alexievich\",\"year\":2016,\"quote\":\"I couldn\\u2019t understand what was going on. I remember seeing Gaidar on TV saying, \\u201Clearn how to sell... The market will save us...\\u201D You buy a bottle of mineral water on one corner and sell it on another\\u2014that\\u2019s business. The people listened, bewildered. I would come home, lock the door, and weep.\"}"
107− , "{\"source\":\"Hiroshima\",\"author\":\"John Hersey\",\"year\":1985,\"quote\":\"At exactly fifteen minutes past eight in the morning, on August 6, 1945, Japanese time, at the moment when the atomic bomb flashed above Hiroshima, Miss Toshiko Sasaki, a clerk in the personnel department of the East Asia Tin Works, had just sat down at her place in the plant office and was turning her head to speak to the girl at the next desk.\"}"
108− , "{\"source\":\"The Orphan\",\"author\":\"Maxim Gorky\",\"year\":1899,\"quote\":\"On a foggy and rainy day, by the cemetery gate, a small group of people standing in a muddy puddle were bargaining with the cabman. \\u201CFifteen kopeks!\\u201D The tall and heavy-set priest exclaimed in a deep bass, in response to the cabman\\u2019s shouts asking for twenty-five kopecks.\"}"
109− , "{\"source\":\"Shah of Shahs\",\"author\":\"Ryszard Kapuściński\",\"year\":1982,\"quote\":\"This plane flies out of Teheran every day and lands at Munich at noon. Waiting limousines carry the passengers to elegant restaurants for lunch. After lunch they all fly back to Teheran in the same airplane and eat their suppers at home. Hardly an expensive entertainment, the jaunt costs only two thousand dollars a head. For people in the Shah\\u2019s favor, such a sum is nothing.\"}"
110− , "{\"source\":\"Introduction to Fortran IV\",\"author\":\"Paul Chirlian\",\"year\":1973,\"quote\":\"There are many programming languages that can be used. We shall discuss a language that is almost universally used, and which is particularly applicable to mathematical and scientific computations. This language is FORTRAN IV.\"}"
111− ]
112−
113−
114−
worker/src/Endpoint/Repl.hsdeleted−244
@@ -1,244 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Endpoint.Repl
4− ( endpoint
5− )
6− where
7−
8−
9−import Data.Aeson ((.:))
10−import qualified Data.Aeson as Aeson
11−import qualified Data.Aeson.Types as Aeson
12−import qualified Data.ByteString as BS
13−import qualified Data.ByteString.Builder as B
14−import qualified Data.ByteString.Lazy as LBS
15−import Data.Map ((!))
16−import qualified Data.Map as Map
17−import qualified Data.Map.Utils as Map
18−import qualified Data.Name as N
19−import qualified Data.NonEmptyList as NE
20−import Snap.Core
21−
22−import qualified Artifacts as A
23−import qualified Cors
24−
25−import qualified AST.Source as Src
26−import qualified AST.Canonical as Can
27−import qualified AST.Optimized as Opt
28−import qualified Compile
29−import qualified Elm.Interface as I
30−import qualified Elm.ModuleName as ModuleName
31−import qualified Elm.Package as Pkg
32−import qualified File
33−import qualified Generate.JavaScript as JS
34−import qualified Json.Encode as Encode
35−import qualified Parse.Module as Parse
36−import qualified Repl
37−import qualified Reporting.Annotation as A
38−import qualified Reporting.Error as Error
39−import qualified Reporting.Error.Import as Import
40−import qualified Reporting.Exit as Exit
41−import qualified Reporting.Exit.Help as Help
42−import qualified Reporting.Render.Type.Localizer as L
43−
44−
45−
46−-- ALLOWED ORIGINS
47−
48−
49−allowedOrigins :: [String]
50−allowedOrigins =
51− [ "https://guide.elm-lang.org"
52− , "https://guide.elm-lang.jp"
53− , "http://localhost:8007"
54− ]
55−
56−
57−
58−-- ENDPOINT
59−
60−
61−endpoint :: A.Artifacts -> Snap ()
62−endpoint artifacts =
63− Cors.allow POST allowedOrigins $
64− do body <- readRequestBody (64 * 1024)
65− case decodeBody body of
66− Just (state, entry) ->
67− serveOutcome (toOutcome artifacts state entry)
68−
69− Nothing ->
70− do modifyResponse $ setResponseStatus 400 "Bad Request"
71− modifyResponse $ setContentType "text/html; charset=utf-8"
72− writeBS "Received unexpected JSON body."
73−
74−
75−
76−-- TO OUTCOME
77−
78−
79−data Outcome
80− = NewImport N.Name
81− | NewType N.Name
82− | NewWork B.Builder
83− --
84− | Skip
85− | Indent
86− | DefStart N.Name
87− --
88− | NoPorts
89− | InvalidCommand
90− | Failure BS.ByteString Error.Error
91−
92−
93−toOutcome :: A.Artifacts -> Repl.State -> String -> Outcome
94−toOutcome artifacts state entry =
95− case reverse (lines entry) of
96− [] ->
97− Skip
98−
99− prev : rev ->
100− case Repl.categorize (Repl.Lines prev rev) of
101− Repl.Done input ->
102− case input of
103− Repl.Import name src -> compile artifacts state (ImportEntry name src)
104− Repl.Type name src -> compile artifacts state (TypeEntry name src)
105− Repl.Decl name src -> compile artifacts state (DeclEntry name src)
106− Repl.Expr src -> compile artifacts state (ExprEntry src)
107− Repl.Port -> NoPorts
108− Repl.Skip -> Skip
109− Repl.Reset -> InvalidCommand
110− Repl.Exit -> InvalidCommand
111− Repl.Help _ -> InvalidCommand
112−
113− Repl.Continue prefill ->
114− case prefill of
115− Repl.Indent -> Indent
116− Repl.DefStart name -> DefStart name
117−
118−
119−
120−-- SERVE OUTCOME
121−
122−
123−serveOutcome :: Outcome -> Snap ()
124−serveOutcome outcome =
125− let
126− serveString = serveBuilder "text/plain"
127− in
128− case outcome of
129− NewImport name -> serveString $ "add-import:" <> N.toBuilder name
130− NewType name -> serveString $ "add-type:" <> N.toBuilder name
131− NewWork js -> serveBuilder "application/javascript" js
132− Skip -> serveString $ "skip"
133− Indent -> serveString $ "indent"
134− DefStart name -> serveString $ "def-start:" <> N.toBuilder name
135− NoPorts -> serveString $ "no-ports"
136− InvalidCommand -> serveString $ "invalid-command"
137− Failure source err ->
138− serveBuilder "application/json" $ Encode.encodeUgly $ Exit.toJson $
139− Help.compilerReport "/" (Error.Module N.replModule "/repl" File.zeroTime source err) []
140−
141−
142−serveBuilder :: BS.ByteString -> B.Builder -> Snap ()
143−serveBuilder mime builder =
144− do modifyResponse (setContentType mime)
145− writeBuilder builder
146−
147−
148−
149−-- COMPILE
150−
151−
152−data EntryType
153− = ImportEntry N.Name BS.ByteString
154− | TypeEntry N.Name BS.ByteString
155− | DeclEntry N.Name BS.ByteString
156− | ExprEntry BS.ByteString
157−
158−
159−compile :: A.Artifacts -> Repl.State -> EntryType -> Outcome
160−compile (A.Artifacts interfaces objects) state@(Repl.State imports types decls) entryType =
161− let
162− source =
163− case entryType of
164− ImportEntry name src -> Repl.toByteString (state { Repl._imports = Map.insert name (B.byteString src) imports }) Repl.OutputNothing
165− TypeEntry name src -> Repl.toByteString (state { Repl._types = Map.insert name (B.byteString src) types }) Repl.OutputNothing
166− DeclEntry name src -> Repl.toByteString (state { Repl._decls = Map.insert name (B.byteString src) decls }) (Repl.OutputDecl name)
167− ExprEntry src -> Repl.toByteString state (Repl.OutputExpr src)
168− in
169− case
170− do modul <- mapLeft Error.BadSyntax $ Parse.fromByteString Parse.Application source
171− ifaces <- mapLeft Error.BadImports $ checkImports interfaces (Src._imports modul)
172− artifacts <- Compile.compile Pkg.dummyName ifaces modul
173− return ( modul, artifacts, objects )
174− of
175− Left err ->
176− Failure source err
177−
178− Right info ->
179− case entryType of
180− ImportEntry name _ -> NewImport name
181− TypeEntry name _ -> NewType name
182− DeclEntry name _ -> NewWork (toJavaScript info (Just name))
183− ExprEntry _ -> NewWork (toJavaScript info Nothing)
184−
185−
186−toJavaScript :: (Src.Module, Compile.Artifacts, Opt.GlobalGraph) -> Maybe N.Name -> B.Builder
187−toJavaScript (modul, Compile.Artifacts canModule types locals, objects) maybeName =
188− let
189− localizer = L.fromModule modul
190− graph = Opt.addLocalGraph locals objects
191− home = Can._name canModule
192− tipe = types ! maybe N.replValueToPrint id maybeName
193− in
194− JS.generateForReplEndpoint localizer graph home maybeName tipe
195−
196−
197−mapLeft :: (x -> y) -> Either x a -> Either y a
198−mapLeft func result =
199− either (Left . func) Right result
200−
201−
202−checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
203−checkImports interfaces imports =
204− let
205− importDict = Map.fromValues Src.getImportName imports
206− missing = Map.difference importDict interfaces
207− in
208− case Map.elems missing of
209− [] ->
210− Right (Map.intersection interfaces importDict)
211−
212− i:is ->
213− let
214− unimported =
215− Map.keysSet (Map.difference interfaces importDict)
216−
217− toError (Src.Import (A.At region name) _ _) =
218− Import.Error region name unimported Import.NotFound
219− in
220− Left (fmap toError (NE.List i is))
221−
222−
223−
224−-- DECODE BODY
225−
226−
227−decodeBody :: LBS.ByteString -> Maybe ( Repl.State, String )
228−decodeBody body =
229− Aeson.parseMaybe decodeBodyHelp =<< Aeson.decode' body
230−
231−
232−decodeBodyHelp :: Aeson.Object -> Aeson.Parser ( Repl.State, String )
233−decodeBodyHelp obj =
234− let
235− get key =
236− do dict <- obj .: key
237− let f (k,v) = (N.fromChars k, B.stringUtf8 v)
238− return $ Map.fromList $ map f $ Map.toList dict
239− in
240− do imports <- get "imports"
241− types <- get "types"
242− decls <- get "decls"
243− entry <- obj .: "entry"
244− return ( Repl.State imports types decls, entry )
worker/src/Errors.elmdeleted−217
@@ -1,217 +0,0 @@
1−port module Errors exposing (main)
2−
3−
4−import Browser
5−import Char
6−import Html exposing (..)
7−import Html.Attributes exposing (..)
8−import Html.Events exposing (onClick)
9−import String
10−import Json.Decode as D
11−import Elm.Error as Error
12−
13−
14−
15−-- PORTS
16−
17−
18−port jumpTo : Error.Region -> Cmd msg
19−
20−
21−
22−-- MAIN
23−
24−
25−main =
26− Browser.document
27− { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none)
28− , update = \region result -> (result, jumpTo region)
29− , view = view
30− , subscriptions = \_ -> Sub.none
31− }
32−
33−
34−type alias Msg = Error.Region
35−
36−
37−
38−-- VIEW
39−
40−
41−view : Result D.Error Error.Error -> Browser.Document Msg
42−view result =
43− { title = "Problem!"
44− , body =
45− case result of
46− Err err ->
47− [ text (D.errorToString err) ]
48−
49− Ok error ->
50− [ viewError error ]
51− }
52−
53−
54−viewError : Error.Error -> Html Msg
55−viewError error =
56− div
57− [ style "width" "calc(100% - 4em)"
58− , style "min-height" "calc(100% - 4em)"
59− , style "font-family" "monospace"
60− , style "white-space" "pre-wrap"
61− , style "background-color" "black"
62− , style "color" "rgb(233,235,235)"
63− , style "padding" "2em"
64− ]
65− (viewErrorHelp error)
66−
67−
68−viewErrorHelp : Error.Error -> List (Html Msg)
69−viewErrorHelp error =
70− case error of
71− Error.GeneralProblem { title, message } ->
72− viewHeader title Nothing :: viewMessage message
73−
74− Error.ModuleProblems badModules ->
75− viewBadModules badModules
76−
77−
78−
79−-- VIEW HEADER
80−
81−
82−viewHeader : String -> Maybe Error.Region -> Html Msg
83−viewHeader title maybeRegion =
84− case maybeRegion of
85− Nothing ->
86− span [ style "color" "rgb(51,187,200)" ]
87− [ text <| "-- " ++ title ++ " "
88− , text <| String.repeat (76 - String.length title) "-"
89− , text <| "\n\n"
90− ]
91−
92− Just region ->
93− span [ style "color" "rgb(51,187,200)" ]
94− [ text <| "-- " ++ title ++ " "
95− , text <| String.repeat (60 - String.length title) "-"
96− , text " "
97− , span
98− [ style "cursor" "pointer"
99− , style "text-decoration" "underline"
100− , onClick region
101− ]
102− [ text "Jump To Problem"
103− ]
104− , text <| "\n\n"
105− ]
106−
107−
108−
109−-- VIEW BAD MODULES
110−
111−
112−viewBadModules : List Error.BadModule -> List (Html Msg)
113−viewBadModules badModules =
114− case badModules of
115− [] ->
116− []
117−
118− [badModule] ->
119− [viewBadModule badModule]
120−
121− a :: b :: cs ->
122− viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs)
123−
124−
125−viewBadModule : Error.BadModule -> Html Msg
126−viewBadModule { problems } =
127− span [] (List.map viewProblem problems)
128−
129−
130−viewProblem : Error.Problem -> Html Msg
131−viewProblem problem =
132− span [] (viewHeader problem.title (Just problem.region) :: viewMessage problem.message)
133−
134−
135−viewSeparator : String -> String -> Html msg
136−viewSeparator before after =
137− span [ style "color" "rgb(211,56,211)" ]
138− [ text <|
139− String.padLeft 80 ' ' (before ++ " ↑ ") ++ "\n" ++
140− "====o======================================================================o====\n" ++
141− " ↓ " ++ after ++ "\n\n\n"
142− ]
143−
144−
145−
146−-- VIEW MESSAGE
147−
148−
149−viewMessage : List Error.Chunk -> List (Html msg)
150−viewMessage chunks =
151− case chunks of
152− [] ->
153− [ text "\n\n\n" ]
154−
155− chunk :: others ->
156− let
157− htmlChunk =
158− case chunk of
159− Error.Unstyled string ->
160− text string
161−
162− Error.Styled style string ->
163− span (styleToAttrs style) [ text string ]
164− in
165− htmlChunk :: viewMessage others
166−
167−
168−styleToAttrs : Error.Style -> List (Attribute msg)
169−styleToAttrs { bold, underline, color } =
170− addBold bold <| addUnderline underline <| addColor color []
171−
172−
173−addBold : Bool -> List (Attribute msg) -> List (Attribute msg)
174−addBold bool attrs =
175− if bool then
176− style "font-weight" "bold" :: attrs
177− else
178− attrs
179−
180−
181−addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg)
182−addUnderline bool attrs =
183− if bool then
184− style "text-decoration" "underline" :: attrs
185− else
186− attrs
187−
188−
189−addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg)
190−addColor maybeColor attrs =
191− case maybeColor of
192− Nothing ->
193− attrs
194−
195− Just color ->
196− style "color" (colorToCss color) :: attrs
197−
198−
199−colorToCss : Error.Color -> String
200−colorToCss color =
201− case color of
202− Error.Red -> "rgb(194,54,33)"
203− Error.RED -> "rgb(252,57,31)"
204− Error.Magenta -> "rgb(211,56,211)"
205− Error.MAGENTA -> "rgb(249,53,248)"
206− Error.Yellow -> "rgb(173,173,39)"
207− Error.YELLOW -> "rgb(234,236,35)"
208− Error.Green -> "rgb(37,188,36)"
209− Error.GREEN -> "rgb(49,231,34)"
210− Error.Cyan -> "rgb(51,187,200)"
211− Error.CYAN -> "rgb(20,240,240)"
212− Error.Blue -> "rgb(73,46,225)"
213− Error.BLUE -> "rgb(88,51,255)"
214− Error.White -> "rgb(203,204,205)"
215− Error.WHITE -> "rgb(233,235,235)"
216− Error.Black -> "rgb(0,0,0)"
217− Error.BLACK -> "rgb(129,131,131)"
worker/src/Main.hs+241−36
@@ -1,21 +1,49 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
3module Main
2module Main
4 ( main
3 ( main
5 )
4 )
6 where
5 where
7
6
8
7
9−import Control.Monad (msum)
8+import Control.Applicative ((<|>))
9+import Control.Concurrent (readMVar)
10+import Control.Monad (liftM2, msum)
10−import qualified Data.ByteString as BS
11+import qualified Data.ByteString as B
12+import qualified Data.ByteString.Builder as B
13+import qualified Data.ByteString.Lazy as LBS
14+import qualified Data.HashSet as HashSet
15+import qualified Data.Map as Map
16+import qualified Data.Map.Utils as Map
17+import qualified Data.NonEmptyList as NE
18+import qualified Data.OneOrMore as OneOrMore
19+import Network.URI (parseURI)
11import Snap.Core
20import Snap.Core
12import Snap.Http.Server
21import Snap.Http.Server
22+import Snap.Util.CORS
23+import Snap.Util.FileServe (serveFile)
24+import Snap.Util.FileUploads
25+import qualified System.Directory as Dir
26+import qualified System.IO.Streams as Stream
27+import Text.RawString.QQ (r)
13
28
14−import qualified Artifacts
29+import qualified AST.Source as Src
15−import qualified Cors
30+import qualified AST.Canonical as Can
16−import qualified Endpoint.Compile as Compile
31+import qualified AST.Optimized as Opt
32+import qualified Compile
33+import qualified Elm.Details as Details
34+import qualified Elm.Interface as I
35+import qualified Elm.ModuleName as ModuleName
36+import qualified Elm.Package as Pkg
37+import qualified Generate.Html as Html
38+import qualified Generate.JavaScript as Generate
39+import qualified Generate.Mode as Mode
40+import qualified Json.Encode as Encode
41+import qualified Parse.Module as Parse
42+import qualified Reporting
43+import qualified Reporting.Annotation as A
17−import qualified Endpoint.Quotes as Quotes
44+import qualified Reporting.Error as Error
18−import qualified Endpoint.Repl as Repl
45+import qualified Reporting.Error.Import as Import
46+import qualified Reporting.Render.Code as Code
19
47
20
48
21
49
@@ -24,50 +52,227 @@ import qualified Endpoint.Repl as Repl
24
52
25main :: IO ()
53main :: IO ()
26main =
54main =
27− do rArtifacts <- Artifacts.loadRepl
55+ do artifacts <- loadArtifacts
28− cArtifacts <- Artifacts.loadCompile
56+ errorHtml <- compileErrorViewer artifacts
29− errorJS <- Compile.loadErrorJS
30− let depsInfo = Artifacts.toDepsInfo cArtifacts
31−
32 httpServe config $ msum $
57 httpServe config $ msum $
33− [ ifTop $ status
58+ [ path "compile" $ compile artifacts
34− , path "repl" $ Repl.endpoint rArtifacts
59+ , path "compile/error.js" $ writeBS errorHtml
35− , path "compile" $ Compile.endpoint_V1 cArtifacts
36− , path "compile/v2" $ Compile.endpoint_V2 cArtifacts
37− , path "compile/errors.js" $ serveJavaScript errorJS
38− , path "compile/deps-info.json" $ serveDepsInfo depsInfo
39− , path "quotes" $ Quotes.endpoint
40 , notFound
60 , notFound
41 ]
61 ]
42
62
43
63
44config :: Config Snap a
64config :: Config Snap a
45config =
65config =
66+ defaultConfig
67+ |> setVerbose False
68+ |> setPort 8000
46− setPort 8000 $ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
69+ |> setAccessLog ConfigNoLog
70+ |> setErrorLog ConfigNoLog
71+
72+
73+(|>) :: a -> (a -> b) -> b
74+(|>) value func =
75+ func value
47
76
48
77
49−status :: Snap ()
78+
50−status =
79+-- NOT FOUND
51− do modifyResponse $ setContentType "text/plain"
52− writeBuilder "Status: OK"
53
80
54
81
55notFound :: Snap ()
82notFound :: Snap ()
56notFound =
83notFound =
57 do modifyResponse $ setResponseStatus 404 "Not Found"
84 do modifyResponse $ setResponseStatus 404 "Not Found"
58 modifyResponse $ setContentType "text/html; charset=utf-8"
85 modifyResponse $ setContentType "text/html; charset=utf-8"
59− writeBuilder "Not Found"
86+ writeBS "Not Found"
87+
88+
89+
90+-- COMPILE
91+
92+
93+compile :: Artifacts -> Snap ()
94+compile artifacts =
95+ applyCORS corsOptions $ method POST $
96+ do parts <- handleMultipart defaultUploadPolicy handlePart
97+ case parts of
98+ [Just source] ->
99+ case compileToBuilder artifacts source of
100+ Left err ->
101+ writeBuilder $ errorToHtmlBuilder source err
102+
103+ Right builder ->
104+ writeBuilder builder
105+
106+ _ ->
107+ pass
108+
109+
110+handlePart :: PartInfo -> Stream.InputStream B.ByteString -> IO (Maybe B.ByteString)
111+handlePart info stream =
112+ if partFieldName info == "code" && partDisposition info == DispositionFormData
113+ then Just . LBS.toStrict <$> storeAsLazyByteString stream
114+ else return Nothing
115+
116+
117+errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
118+errorToHtmlBuilder source err =
119+ let
120+ json = Encode.encodeUgly (Error.errorToJson (Code.toSource source) err)
121+ in
122+ [r|<!DOCTYPE HTML>
123+<html>
124+<head>
125+ <meta charset="UTF-8">
126+ <style>body { padding: 0; margin: 0; }</style>
127+ <script src="https://worker.elm-lang.org/compile/error.js"></script>
128+ <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
129+</head>
130+<body></body>
131+</html>|]
132+
133+
134+
135+compileToBuilder :: Artifacts -> B.ByteString -> Either Error.Error B.Builder
136+compileToBuilder (Artifacts interfaces objects) source =
137+ case Parse.fromByteString Pkg.dummyName source of
138+ Left err ->
139+ Left (Error.BadSyntax err)
140+
141+ Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
142+ case checkImports interfaces imports of
143+ Left err ->
144+ Left err
145+
146+ Right ifaces ->
147+ case Compile.compile Pkg.dummyName ifaces modul of
148+ Left err ->
149+ Left err
150+
151+ Right artifacts@(Compile.Artifacts modul _ locals@(Opt.LocalGraph maybeMain _ _)) ->
152+ case maybeMain of
153+ Nothing ->
154+ Left (error "TODO no main")
155+
156+ Just main ->
157+ let
158+ mode = Mode.Dev Nothing
159+ home = Can._name modul
160+ name = ModuleName._module home
161+ mains = Map.singleton home main
162+ graph = Opt.addLocalGraph locals objects
163+ in
164+ Right $ Html.sandwich name $ Generate.generate mode graph mains
165+
166+
167+checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either Error.Error (Map.Map ModuleName.Raw I.Interface)
168+checkImports interfaces imports =
169+ let
170+ importDict = Map.fromValues Src.getImportName imports
171+ missing = Map.difference importDict interfaces
172+ in
173+ case Map.elems missing of
174+ [] ->
175+ Right (Map.intersection interfaces importDict)
176+
177+ i:is ->
178+ let
179+ unimported = Map.keysSet (Map.difference interfaces importDict)
180+ toError (Src.Import (A.At region name) _ _) =
181+ Import.Error region name unimported Import.NotFound
182+ in
183+ Left (Error.BadImports (fmap toError (NE.List i is)))
184+
185+
186+
187+-- COMPILE ERROR VIEWER
188+
189+
190+compileErrorViewer :: Artifacts -> B.ByteString
191+compileErrorViewer artifacts =
192+ do source <- File.readUtf8 "src/Error.elm"
193+ case compileToBuilder artifacts source of
194+ Left err ->
195+ error "problem compiling src/Error.elm"
196+
197+ Right builder ->
198+ return (LBS.toStrict (B.toLazyByteString builder))
199+
200+
201+
202+-- CORS OPTIONS
203+
204+
205+corsOptions :: (Monad m) => CORSOptions m
206+corsOptions =
207+ let
208+ allowedOrigins = toOriginList [ "https://elm-lang.org", "https://package.elm-lang.org" ]
209+ allowedMethods = HashSet.singleton (HashableMethod POST)
210+ in
211+ CORSOptions
212+ { corsAllowOrigin = return allowedOrigins
213+ , corsAllowCredentials = return True
214+ , corsExposeHeaders = return HashSet.empty
215+ , corsAllowedMethods = return allowedMethods
216+ , corsAllowedHeaders = return
217+ }
218+
219+
220+toOriginList :: [String] -> OriginList
221+toOriginList origins =
222+ Origins $ mkOriginSet $
223+ case traverse parseURI origins of
224+ Just uris -> uris
225+ Nothing -> error "invalid entry given to toOriginList list"
226+
227+
228+
229+-- ARTIFACTS
230+
231+
232+data Artifacts =
233+ Artifacts
234+ { _ifaces :: Map.Map ModuleName.Raw I.Interface
235+ , _graph :: Opt.GlobalGraph
236+ }
237+
238+
239+loadArtifacts :: IO Artifacts
240+loadArtifacts =
241+ do style <- Reporting.terminal
242+ root <- Dir.getCurrentDirectory
243+ result <- Details.load style root
244+ case result of
245+ Left _ ->
246+ error "Ran into some problem loading elm.json details"
247+
248+ Right details ->
249+ do omvar <- Details.loadObjects root details
250+ imvar <- Details.loadInterfaces root details
251+ mdeps <- readMVar imvar
252+ mobjs <- readMVar omvar
253+ case liftM2 (,) mdeps mobjs of
254+ Nothing ->
255+ error "Ran into some weird problem loading elm.json details"
256+
257+ Just (deps, objs) ->
258+ return $ Artifacts (toInterfaces deps) objs
259+
60
260
261+toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
262+toInterfaces deps =
263+ Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
264+ Map.elems (Map.mapMaybeWithKey getPublic deps)
61
265
62−serveJavaScript :: BS.ByteString -> Snap ()
63−serveJavaScript javascript =
64− do modifyResponse $ setContentType "application/javascript"
65− writeBS javascript
66
266
267+getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
268+getPublic (ModuleName.Canonical _ name) dep =
269+ case dep of
270+ I.Public iface -> Just (name, OneOrMore.one iface)
271+ I.Private _ _ _ -> Nothing
67
272
68−serveDepsInfo :: BS.ByteString -> Snap ()
69−serveDepsInfo json =
70− Cors.allow GET ["https://elm-lang.org"] $
71− do modifyResponse $ setContentType "application/json"
72− writeBS json
73
273
274+toUnique :: OneOrMore.OneOrMore a -> Maybe a
275+toUnique oneOrMore =
276+ case oneOrMore of
277+ OneOrMore.One value -> Just value
278+ OneOrMore.More _ _ -> Nothing