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

Binary file not shown.

LICENSE+6−25
@@ -1,30 +1,11 @@
1−Copyright (c) 2012-present, Evan Czaplicki
1+Copyright 2012-present Evan Czaplicki
2
2
3−All rights reserved.
3+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
4
4
5−Redistribution and use in source and binary forms, with or without
5+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
6−modification, are permitted provided that the following conditions are met:
7
6
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
7+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
10
8
11− * Redistributions in binary form must reproduce the above
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.
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15
10
16− * Neither the name of Evan Czaplicki nor the names of other
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.
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+10−5
@@ -1,17 +1,22 @@
1−# The Elm Compiler
1+# Elm
2
2
3−Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
3+A delightful language for reliable webapps.
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>
5
9
6## Install
10## Install
7
11
8−Follow [these instructions][installer]!
12+✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
9
13
10− [installer]: https://guide.elm-lang.org/install.html
14+For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
11
15
16+<br>
12
17
13## Help
18## Help
14
19
15If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
20If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
16
21
17−[slack]: http://elmlang.herokuapp.com/
22+[slack]: http://elmlang.herokuapp.com/
builder/src/BackgroundWriter.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE BangPatterns #-}
2+module BackgroundWriter
3+ ( Scope
4+ , withScope
5+ , writeBinary
6+ )
7+ where
8+
9+
10+import Control.Concurrent (forkIO)
11+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
12+import qualified Data.Binary as Binary
13+import Data.Foldable (traverse_)
14+
15+import qualified File
16+
17+
18+
19+-- BACKGROUND WRITER
20+
21+
22+newtype Scope =
23+ Scope (MVar [MVar ()])
24+
25+
26+withScope :: (Scope -> IO a) -> IO a
27+withScope callback =
28+ do workList <- newMVar []
29+ result <- callback (Scope workList)
30+ mvars <- takeMVar workList
31+ traverse_ takeMVar mvars
32+ return result
33+
34+
35+writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
36+writeBinary (Scope workList) path value =
37+ do mvar <- newEmptyMVar
38+ _ <- forkIO (File.writeBinary path value >> putMVar mvar ())
39+ oldWork <- takeMVar workList
40+ let !newWork = mvar:oldWork
41+ putMVar workList newWork
42+
builder/src/Build.hs+530−293
@@ -1,12 +1,16 @@
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3module Build
3module Build
4 ( fromExposed
4 ( fromExposed
5− , fromMains
5+ , fromPaths
6+ , fromRepl
6 , Artifacts(..)
7 , Artifacts(..)
7− , Main(..)
8+ , Root(..)
8 , Module(..)
9 , Module(..)
9 , CachedInterface(..)
10 , CachedInterface(..)
11+ , ReplArtifacts(..)
12+ , DocsGoal(..)
13+ , getRootNames
10 )
14 )
11 where
15 where
12
16
@@ -16,7 +20,6 @@ import Control.Concurrent.MVar
16import Control.Monad (filterM, mapM_, sequence_)
20import Control.Monad (filterM, mapM_, sequence_)
17import qualified Data.ByteString as B
21import qualified Data.ByteString as B
18import qualified Data.Char as Char
22import qualified Data.Char as Char
19−import qualified Data.Either as Either
20import qualified Data.Graph as Graph
23import qualified Data.Graph as Graph
21import qualified Data.List as List
24import qualified Data.List as List
22import qualified Data.Map.Utils as Map
25import qualified Data.Map.Utils as Map
@@ -31,22 +34,27 @@ import qualified System.Directory as Dir
31import qualified System.FilePath as FP
34import qualified System.FilePath as FP
32import System.FilePath ((</>), (<.>))
35import System.FilePath ((</>), (<.>))
33
36
37+import qualified AST.Canonical as Can
34import qualified AST.Source as Src
38import qualified AST.Source as Src
35import qualified AST.Optimized as Opt
39import qualified AST.Optimized as Opt
36import qualified Compile
40import qualified Compile
37import qualified Elm.Details as Details
41import qualified Elm.Details as Details
42+import qualified Elm.Docs as Docs
38import qualified Elm.Interface as I
43import qualified Elm.Interface as I
39import qualified Elm.ModuleName as ModuleName
44import qualified Elm.ModuleName as ModuleName
40import qualified Elm.Outline as Outline
45import qualified Elm.Outline as Outline
41import qualified Elm.Package as Pkg
46import qualified Elm.Package as Pkg
42import qualified File
47import qualified File
48+import qualified Json.Encode as E
43import qualified Parse.Module as Parse
49import qualified Parse.Module as Parse
44import qualified Reporting
50import qualified Reporting
45import qualified Reporting.Annotation as A
51import qualified Reporting.Annotation as A
46import qualified Reporting.Error as Error
52import qualified Reporting.Error as Error
53+import qualified Reporting.Error.Docs as EDocs
47import qualified Reporting.Error.Syntax as Syntax
54import qualified Reporting.Error.Syntax as Syntax
48import qualified Reporting.Error.Import as Import
55import qualified Reporting.Error.Import as Import
49import qualified Reporting.Exit as Exit
56import qualified Reporting.Exit as Exit
57+import qualified Reporting.Render.Type.Localizer as L
50import qualified Stuff
58import qualified Stuff
51
59
52
60
@@ -58,27 +66,57 @@ data Env =
58 Env
66 Env
59 { _key :: Reporting.BKey
67 { _key :: Reporting.BKey
60 , _root :: FilePath
68 , _root :: FilePath
61− , _pkg :: Pkg.Name
69+ , _project :: Parse.ProjectType
62− , _srcDirs :: [FilePath]
70+ , _srcDirs :: [AbsoluteSrcDir]
71+ , _buildID :: Details.BuildID
63 , _locals :: Map.Map ModuleName.Raw Details.Local
72 , _locals :: Map.Map ModuleName.Raw Details.Local
64 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
73 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
65 }
74 }
66
75
67
76
68−makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
77+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
69−makeEnv key root (Details.Details _ validOutline locals foreigns _) =
78+makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
70 case validOutline of
79 case validOutline of
71− Details.ValidApp srcDirs ->
80+ Details.ValidApp givenSrcDirs ->
72− Env key root Pkg.dummyName (NE.toList srcDirs) locals foreigns
81+ do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82+ return $ Env key root Parse.Application srcDirs buildID locals foreigns
73
83
74− Details.ValidPkg pkg _ ->
84+ Details.ValidPkg pkg _ _ ->
85+ do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
75− Env key root pkg ["src"] locals foreigns
86+ return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
87+
88+
89+
90+-- SOURCE DIRECTORY
91+
92+
93+newtype AbsoluteSrcDir =
94+ AbsoluteSrcDir FilePath
95+
96+
97+toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
98+toAbsoluteSrcDir root srcDir =
99+ AbsoluteSrcDir <$> Dir.canonicalizePath
100+ (
101+ case srcDir of
102+ Outline.AbsoluteSrcDir dir -> dir
103+ Outline.RelativeSrcDir dir -> root </> dir
104+ )
105+
106+
107+addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
108+addRelative (AbsoluteSrcDir srcDir) path =
109+ srcDir </> path
76
110
77
111
78
112
79-- FORK
113-- FORK
80
114
81
115
116+-- PERF try using IORef semephore on file crawl phase?
117+-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
118+-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
119+--
82fork :: IO a -> IO (MVar a)
120fork :: IO a -> IO (MVar a)
83fork work =
121fork work =
84 do mvar <- newEmptyMVar
122 do mvar <- newEmptyMVar
@@ -96,21 +134,22 @@ forkWithKey func dict =
96-- FROM EXPOSED
134-- FROM EXPOSED
97
135
98
136
99−fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
137+fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
100−fromExposed style root details exposed@(NE.List e es) =
138+fromExposed style root details docsGoal exposed@(NE.List e es) =
101 Reporting.trackBuild style $ \key ->
139 Reporting.trackBuild style $ \key ->
102− do let env = makeEnv key root details
140+ do env <- makeEnv key root details
103 dmvar <- Details.loadInterfaces root details
141 dmvar <- Details.loadInterfaces root details
104
142
105 -- crawl
143 -- crawl
106 mvar <- newEmptyMVar
144 mvar <- newEmptyMVar
145+ let docsNeed = toDocsNeed docsGoal
107− roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
146+ roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
108 putMVar mvar roots
147 putMVar mvar roots
109 mapM_ readMVar roots
148 mapM_ readMVar roots
110 statuses <- traverse readMVar =<< readMVar mvar
149 statuses <- traverse readMVar =<< readMVar mvar
111
150
112 -- compile
151 -- compile
113− midpoint <- checkExposedMidpoint dmvar statuses
152+ midpoint <- checkMidpoint dmvar statuses
114 case midpoint of
153 case midpoint of
115 Left problem ->
154 Left problem ->
116 return (Left (Exit.BuildProjectProblem problem))
155 return (Left (Exit.BuildProjectProblem problem))
@@ -121,18 +160,18 @@ fromExposed style root details exposed@(NE.List e es) =
121 putMVar rmvar resultMVars
160 putMVar rmvar resultMVars
122 results <- traverse readMVar resultMVars
161 results <- traverse readMVar resultMVars
123 writeDetails root details results
162 writeDetails root details results
124− return (detectExposedProblems exposed results)
163+ finalizeExposed root docsGoal exposed results
125
164
126
165
127
166
128−-- FROM MAINS
167+-- FROM PATHS
129
168
130
169
131data Artifacts =
170data Artifacts =
132 Artifacts
171 Artifacts
133 { _name :: Pkg.Name
172 { _name :: Pkg.Name
134 , _deps :: Dependencies
173 , _deps :: Dependencies
135− , _mains :: NE.List Main
174+ , _roots :: NE.List Root
136 , _modules :: [Module]
175 , _modules :: [Module]
137 }
176 }
138
177
@@ -146,25 +185,25 @@ type Dependencies =
146 Map.Map ModuleName.Canonical I.DependencyInterface
185 Map.Map ModuleName.Canonical I.DependencyInterface
147
186
148
187
149−fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
188+fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
150−fromMains style root details paths =
189+fromPaths style root details paths =
151 Reporting.trackBuild style $ \key ->
190 Reporting.trackBuild style $ \key ->
152− do let env = makeEnv key root details
191+ do env <- makeEnv key root details
153
192
154− elmains <- findMains env paths
193+ elroots <- findRoots env paths
155− case elmains of
194+ case elroots of
156 Left problem ->
195 Left problem ->
157 return (Left (Exit.BuildProjectProblem problem))
196 return (Left (Exit.BuildProjectProblem problem))
158
197
159− Right lmains ->
198+ Right lroots ->
160 do -- crawl
199 do -- crawl
161 dmvar <- Details.loadInterfaces root details
200 dmvar <- Details.loadInterfaces root details
162 smvar <- newMVar Map.empty
201 smvar <- newMVar Map.empty
163− smainMVars <- traverse (fork . crawlMain env smvar) lmains
202+ srootMVars <- traverse (fork . crawlRoot env smvar) lroots
164− smains <- traverse readMVar smainMVars
203+ sroots <- traverse readMVar srootMVars
165 statuses <- traverse readMVar =<< readMVar smvar
204 statuses <- traverse readMVar =<< readMVar smvar
166
205
167− midpoint <- checkMainsMidpoint dmvar statuses smains
206+ midpoint <- checkMidpointAndRoots dmvar statuses sroots
168 case midpoint of
207 case midpoint of
169 Left problem ->
208 Left problem ->
170 return (Left (Exit.BuildProjectProblem problem))
209 return (Left (Exit.BuildProjectProblem problem))
@@ -174,10 +213,26 @@ fromMains style root details paths =
174 rmvar <- newEmptyMVar
213 rmvar <- newEmptyMVar
175 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
214 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
176 putMVar rmvar resultsMVars
215 putMVar rmvar resultsMVars
177− rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
216+ rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
178 results <- traverse readMVar resultsMVars
217 results <- traverse readMVar resultsMVars
179 writeDetails root details results
218 writeDetails root details results
180− toArtifacts env foreigns results <$> traverse readMVar rmainMVars
219+ toArtifacts env foreigns results <$> traverse readMVar rrootMVars
220+
221+
222+
223+-- GET ROOT NAMES
224+
225+
226+getRootNames :: Artifacts -> NE.List ModuleName.Raw
227+getRootNames (Artifacts _ _ roots _) =
228+ fmap getRootName roots
229+
230+
231+getRootName :: Root -> ModuleName.Raw
232+getRootName root =
233+ case root of
234+ Inside name -> name
235+ Outside name _ _ -> name
181
236
182
237
183
238
@@ -190,7 +245,7 @@ type StatusDict =
190
245
191data Status
246data Status
192 = SCached Details.Local
247 = SCached Details.Local
193− | SChanged Details.Local B.ByteString Src.Module
248+ | SChanged Details.Local B.ByteString Src.Module DocsNeed
194 | SBadImport Import.Problem
249 | SBadImport Import.Problem
195 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
250 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
196 | SForeign Pkg.Name
251 | SForeign Pkg.Name
@@ -207,15 +262,14 @@ crawlDeps env mvar deps blockedValue =
207 mapM_ readMVar statuses
262 mapM_ readMVar statuses
208 return blockedValue
263 return blockedValue
209 where
264 where
210− crawlNew name () = fork (crawlModule env mvar name)
265+ crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
211
266
212
267
213−crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
268+crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
214−crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
269+crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
215 do let fileName = ModuleName.toFilePath name <.> "elm"
270 do let fileName = ModuleName.toFilePath name <.> "elm"
216− let inRoot path = File.exists (root </> path)
217
271
218− paths <- filterM inRoot (map (</> fileName) srcDirs)
272+ paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
219
273
220 case paths of
274 case paths of
221 [path] ->
275 [path] ->
@@ -224,21 +278,18 @@ crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
224 return $ SBadImport $ Import.Ambiguous path [] dep deps
278 return $ SBadImport $ Import.Ambiguous path [] dep deps
225
279
226 Nothing ->
280 Nothing ->
281+ do newTime <- File.getTime path
227− case Map.lookup name locals of
282+ case Map.lookup name locals of
228− Nothing ->
283+ Nothing ->
229− crawlFile env mvar name path
284+ crawlFile env mvar docsNeed name path newTime buildID
230
285
231− Just local@(Details.Local oldPath oldTime deps _) ->
286+ Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
232− if path /= oldPath
287+ if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
233− then crawlFile env mvar name path
234− else
235− do newTime <- File.getTime path
236− if oldTime < newTime
237− then crawlFile env mvar name path
288+ then crawlFile env mvar docsNeed name path newTime lastChange
238− else crawlDeps env mvar deps (SCached local)
289+ else crawlDeps env mvar deps (SCached local)
239
290
240 p1:p2:ps ->
291 p1:p2:ps ->
241− return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
292+ return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
242
293
243 [] ->
294 [] ->
244 case Map.lookup name foreigns of
295 case Map.lookup name foreigns of
@@ -251,19 +302,18 @@ crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
251 return $ SBadImport $ Import.AmbiguousForeign dep d ds
302 return $ SBadImport $ Import.AmbiguousForeign dep d ds
252
303
253 Nothing ->
304 Nothing ->
254− if Name.isKernel name && Pkg.isKernel pkg then
305+ if Name.isKernel name && Parse.isKernel projectType then
255 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
306 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
256 return $ if exists then SKernel else SBadImport Import.NotFound
307 return $ if exists then SKernel else SBadImport Import.NotFound
257 else
308 else
258 return $ SBadImport Import.NotFound
309 return $ SBadImport Import.NotFound
259
310
260
311
261−crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
312+crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
262−crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
313+crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
263− do time <- File.getTime path
264− source <- File.readUtf8 (root </> path)
314+ do source <- File.readUtf8 (root </> path)
265
315
266− case Parse.fromByteString pkg source of
316+ case Parse.fromByteString projectType source of
267 Left err ->
317 Left err ->
268 return $ SBadSyntax path time source err
318 return $ SBadSyntax path time source err
269
319
@@ -276,9 +326,9 @@ crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
276 if expectedName == actualName then
326 if expectedName == actualName then
277 let
327 let
278 deps = map Src.getImportName imports
328 deps = map Src.getImportName imports
279− local = Details.Local path time deps (any isMain values)
329+ local = Details.Local path time deps (any isMain values) lastChange buildID
280 in
330 in
281− crawlDeps env mvar deps (SChanged local source modul)
331+ crawlDeps env mvar deps (SChanged local source modul docsNeed)
282 else
332 else
283 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
333 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
284
334
@@ -297,9 +347,9 @@ type ResultDict =
297
347
298
348
299data Result
349data Result
300− = RNew Details.Local I.Interface Opt.LocalGraph
350+ = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
301− | RSame Details.Local I.Interface Opt.LocalGraph
351+ | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
302− | RCached Bool (MVar CachedInterface)
352+ | RCached Bool Details.BuildID (MVar CachedInterface)
303 | RNotFound Import.Problem
353 | RNotFound Import.Problem
304 | RProblem Error.Module
354 | RProblem Error.Module
305 | RBlocked
355 | RBlocked
@@ -314,23 +364,23 @@ data CachedInterface
314
364
315
365
316checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
366checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
317−checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
367+checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
318 case status of
368 case status of
319− SCached local@(Details.Local path time deps hasMain) ->
369+ SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
320 do results <- readMVar resultsMVar
370 do results <- readMVar resultsMVar
321− depsStatus <- checkDeps root results deps
371+ depsStatus <- checkDeps root results deps lastCompile
322 case depsStatus of
372 case depsStatus of
323 DepsChange ifaces ->
373 DepsChange ifaces ->
324 do source <- File.readUtf8 path
374 do source <- File.readUtf8 path
325− case Parse.fromByteString pkg source of
375+ case Parse.fromByteString projectType source of
326− Right modul -> compile env local source ifaces modul
376+ Right modul -> compile env (DocsNeed False) local source ifaces modul
327 Left err ->
377 Left err ->
328 return $ RProblem $
378 return $ RProblem $
329 Error.Module name path time source (Error.BadSyntax err)
379 Error.Module name path time source (Error.BadSyntax err)
330
380
331 DepsSame _ _ ->
381 DepsSame _ _ ->
332 do mvar <- newMVar Unneeded
382 do mvar <- newMVar Unneeded
333− return (RCached hasMain mvar)
383+ return (RCached hasMain lastChange mvar)
334
384
335 DepsBlock ->
385 DepsBlock ->
336 return RBlocked
386 return RBlocked
@@ -338,29 +388,25 @@ checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
338 DepsNotFound problems ->
388 DepsNotFound problems ->
339 do source <- File.readUtf8 path
389 do source <- File.readUtf8 path
340 return $ RProblem $ Error.Module name path time source $
390 return $ RProblem $ Error.Module name path time source $
341− case Parse.fromByteString pkg source of
391+ case Parse.fromByteString projectType source of
342 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
392 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
343 Error.BadImports (toImportErrors env results imports problems)
393 Error.BadImports (toImportErrors env results imports problems)
344
394
345 Left err ->
395 Left err ->
346 Error.BadSyntax err
396 Error.BadSyntax err
347
397
348− SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
398+ SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
349 do results <- readMVar resultsMVar
399 do results <- readMVar resultsMVar
350− depsStatus <- checkDeps root results deps
400+ depsStatus <- checkDeps root results deps lastCompile
351 case depsStatus of
401 case depsStatus of
352 DepsChange ifaces ->
402 DepsChange ifaces ->
353− compile env local source ifaces modul
403+ compile env docsNeed local source ifaces modul
354
404
355 DepsSame same cached ->
405 DepsSame same cached ->
356− do maybeLoaded <- checkCachedInterfaces root cached
406+ do maybeLoaded <- loadInterfaces root same cached
357 case maybeLoaded of
407 case maybeLoaded of
358− Nothing ->
359− return RBlocked
408+ Nothing -> return RBlocked
360−
361− Just loaded ->
362− do let ifaces = Map.union loaded (Map.fromList same)
363− compile env local source ifaces modul
409+ Just ifaces -> compile env docsNeed local source ifaces modul
364
410
365 DepsBlock ->
411 DepsBlock ->
366 return RBlocked
412 return RBlocked
@@ -379,7 +425,7 @@ checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
379 SForeign home ->
425 SForeign home ->
380 case foreigns ! ModuleName.Canonical home name of
426 case foreigns ! ModuleName.Canonical home name of
381 I.Public iface -> return (RForeign iface)
427 I.Public iface -> return (RForeign iface)
382− I.Private _ _ _ -> error "loading private interface in Build"
428+ I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
383
429
384 SKernel ->
430 SKernel ->
385 return RKernel
431 return RKernel
@@ -396,32 +442,48 @@ data DepsStatus
396 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
442 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
397
443
398
444
399−checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
445+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
400−checkDeps root results deps =
446+checkDeps root results deps lastCompile =
401− checkDepsHelp root results deps [] [] [] [] False
447+ checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
402
448
403
449
404type Dep = (ModuleName.Raw, I.Interface)
450type Dep = (ModuleName.Raw, I.Interface)
405type CDep = (ModuleName.Raw, MVar CachedInterface)
451type CDep = (ModuleName.Raw, MVar CachedInterface)
406
452
407
453
408−checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
454+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
409−checkDepsHelp root results deps new same cached importProblems isBlocked =
455+checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
410 case deps of
456 case deps of
411 dep:otherDeps ->
457 dep:otherDeps ->
412 do result <- readMVar (results ! dep)
458 do result <- readMVar (results ! dep)
413 case result of
459 case result of
460+ RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
414− RNew _ iface _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
461+ checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
462+
463+ RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
415− RSame _ iface _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
464+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
465+
466+ RCached _ lastChange mvar ->
416− RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
467+ checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
468+
469+ RNotFound prob ->
417− RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
470+ checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
471+
472+ RProblem _ ->
418− RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
473+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
474+
475+ RBlocked ->
419− RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
476+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
477+
478+ RForeign iface ->
420− RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
479+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
480+
481+ RKernel ->
421− RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
482+ checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
483+
422
484
423 [] ->
485 [] ->
424− case importProblems of
486+ case reverse importProblems of
425 p:ps ->
487 p:ps ->
426 return $ DepsNotFound (NE.List p ps)
488 return $ DepsNotFound (NE.List p ps)
427
489
@@ -429,18 +491,14 @@ checkDepsHelp root results deps new same cached importProblems isBlocked =
429 if isBlocked then
491 if isBlocked then
430 return $ DepsBlock
492 return $ DepsBlock
431
493
432− else if null new then
494+ else if null new && lastDepChange <= lastCompile then
433 return $ DepsSame same cached
495 return $ DepsSame same cached
434
496
435 else
497 else
436− do maybeLoaded <- checkCachedInterfaces root cached
498+ do maybeLoaded <- loadInterfaces root same cached
437 case maybeLoaded of
499 case maybeLoaded of
438− Nothing ->
439− return DepsBlock
500+ Nothing -> return DepsBlock
440−
441− Just loaded ->
442− return $ DepsChange $
501+ Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
443− Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
444
502
445
503
446
504
@@ -448,7 +506,7 @@ checkDepsHelp root results deps new same cached importProblems isBlocked =
448
506
449
507
450toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
508toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
451−toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
509+toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
452 let
510 let
453 knownModules =
511 knownModules =
454 Set.unions
512 Set.unions
@@ -470,18 +528,23 @@ toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
470
528
471
529
472
530
473−-- CACHED INTERFACE
531+-- LOAD CACHED INTERFACES
474
532
475
533
476−checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
534+loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
477−checkCachedInterfaces root deps =
535+loadInterfaces root same cached =
478− do loading <- traverse (fork . checkCache root) deps
536+ do loading <- traverse (fork . loadInterface root) cached
479− loaded <- traverse readMVar loading
537+ maybeLoaded <- traverse readMVar loading
480− return $ Map.fromList <$> sequence loaded
538+ case sequence maybeLoaded of
539+ Nothing ->
540+ return Nothing
541+
542+ Just loaded ->
543+ return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
481
544
482
545
483−checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
546+loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
484−checkCache root (name, ciMvar) =
547+loadInterface root (name, ciMvar) =
485 do cachedInterface <- takeMVar ciMvar
548 do cachedInterface <- takeMVar ciMvar
486 case cachedInterface of
549 case cachedInterface of
487 Corrupted ->
550 Corrupted ->
@@ -508,8 +571,8 @@ checkCache root (name, ciMvar) =
508-- CHECK PROJECT
571-- CHECK PROJECT
509
572
510
573
511−checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
574+checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
512−checkExposedMidpoint dmvar statuses =
575+checkMidpoint dmvar statuses =
513 case checkForCycles statuses of
576 case checkForCycles statuses of
514 Nothing ->
577 Nothing ->
515 do maybeForeigns <- readMVar dmvar
578 do maybeForeigns <- readMVar dmvar
@@ -522,11 +585,11 @@ checkExposedMidpoint dmvar statuses =
522 return (Left (Exit.BP_Cycle name names))
585 return (Left (Exit.BP_Cycle name names))
523
586
524
587
525−checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
588+checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
526−checkMainsMidpoint dmvar statuses smains =
589+checkMidpointAndRoots dmvar statuses sroots =
527 case checkForCycles statuses of
590 case checkForCycles statuses of
528 Nothing ->
591 Nothing ->
529− case checkUniqueMains statuses smains of
592+ case checkUniqueRoots statuses sroots of
530 Nothing ->
593 Nothing ->
531 do maybeForeigns <- readMVar dmvar
594 do maybeForeigns <- readMVar dmvar
532 case maybeForeigns of
595 case maybeForeigns of
@@ -577,25 +640,25 @@ addToGraph name status graph =
577 let
640 let
578 dependencies =
641 dependencies =
579 case status of
642 case status of
580− SCached (Details.Local _ _ deps _) -> deps
643+ SCached (Details.Local _ _ deps _ _ _) -> deps
581− SChanged (Details.Local _ _ deps _) _ _ -> deps
644+ SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
582− SBadImport _ -> []
645+ SBadImport _ -> []
583− SBadSyntax _ _ _ _ -> []
646+ SBadSyntax _ _ _ _ -> []
584− SForeign _ -> []
647+ SForeign _ -> []
585− SKernel -> []
648+ SKernel -> []
586 in
649 in
587 (name, name, dependencies) : graph
650 (name, name, dependencies) : graph
588
651
589
652
590
653
591−-- CHECK UNIQUE MAINS
654+-- CHECK UNIQUE ROOTS
592
655
593
656
594−checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
657+checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
595−checkUniqueMains insides smains =
658+checkUniqueRoots insides sroots =
596 let
659 let
597 outsidesDict =
660 outsidesDict =
598− Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
661+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
599 in
662 in
600 case Map.traverseWithKey checkOutside outsidesDict of
663 case Map.traverseWithKey checkOutside outsidesDict of
601 Left problem ->
664 Left problem ->
@@ -607,61 +670,78 @@ checkUniqueMains insides smains =
607 Left problem -> Just problem
670 Left problem -> Just problem
608
671
609
672
610−mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
673+rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
611−mainStatusToNamePathPair smain =
674+rootStatusToNamePathPair sroot =
612− case smain of
675+ case sroot of
613− SInside _ -> Nothing
676+ SInside _ -> Nothing
614− SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
677+ SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
615− SOutsideErr _ -> Nothing
678+ SOutsideErr _ -> Nothing
616
679
617
680
618checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
619checkOutside name paths =
682checkOutside name paths =
620 case OneOrMore.destruct NE.List paths of
683 case OneOrMore.destruct NE.List paths of
621 NE.List p [] -> Right p
684 NE.List p [] -> Right p
622− NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
685+ NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
623
686
624
687
625checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
626checkInside name p1 status =
689checkInside name p1 status =
627 case status of
690 case status of
628− SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
691+ SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
629− SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
692+ SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
630− SBadImport _ -> Right ()
693+ SBadImport _ -> Right ()
631− SBadSyntax _ _ _ _ -> Right ()
694+ SBadSyntax _ _ _ _ -> Right ()
632− SForeign _ -> Right ()
695+ SForeign _ -> Right ()
633− SKernel -> Right ()
696+ SKernel -> Right ()
634
697
635
698
636
699
637-- COMPILE MODULE
700-- COMPILE MODULE
638
701
639
702
640−compile :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
703+compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
641−compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifaces modul =
704+compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
705+ let
706+ pkg = projectTypeToPkg projectType
707+ in
642 case Compile.compile pkg ifaces modul of
708 case Compile.compile pkg ifaces modul of
643 Right (Compile.Artifacts canonical annotations objects) ->
709 Right (Compile.Artifacts canonical annotations objects) ->
710+ case makeDocs docsNeed canonical of
711+ Left err ->
712+ return $ RProblem $
713+ Error.Module (Src.getName modul) path time source (Error.BadDocs err)
714+
715+ Right docs ->
644− do let name = Src.getName modul
716+ do let name = Src.getName modul
645− let iface = I.fromModule pkg canonical annotations
717+ let iface = I.fromModule pkg canonical annotations
718+ let elmi = Stuff.elmi root name
646− File.writeBinary (Stuff.elmo root name) objects
719+ File.writeBinary (Stuff.elmo root name) objects
647− maybeOldi <- File.readBinary (Stuff.elmi root name)
720+ maybeOldi <- File.readBinary elmi
648− case maybeOldi of
721+ case maybeOldi of
649− Just oldi | oldi == iface ->
722+ Just oldi | oldi == iface ->
650− do -- iface should be fully forced by equality check
723+ do -- iface should be fully forced by equality check
651− Reporting.report key Reporting.BDone
724+ Reporting.report key Reporting.BDone
725+ let local = Details.Local path time deps main lastChange buildID
652− return (RSame local iface objects)
726+ return (RSame local iface objects docs)
653−
727+
654− _ ->
728+ _ ->
655− do -- iface may be lazy still
729+ do -- iface may be lazy still
656− -- TODO try adding forkIO here
657− File.writeBinary (Stuff.elmi root name) iface
730+ File.writeBinary elmi iface
658− Reporting.report key Reporting.BDone
731+ Reporting.report key Reporting.BDone
732+ let local = Details.Local path time deps main buildID buildID
659− return (RNew local iface objects)
733+ return (RNew local iface objects docs)
660
734
661 Left err ->
735 Left err ->
662− do Reporting.report key Reporting.BDone
663− return $ RProblem $
736+ return $ RProblem $
664− Error.Module (Src.getName modul) path time source err
737+ Error.Module (Src.getName modul) path time source err
738+
739+
740+projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
741+projectTypeToPkg projectType =
742+ case projectType of
743+ Parse.Package pkg -> pkg
744+ Parse.Application -> Pkg.dummyName
665
745
666
746
667
747
@@ -669,64 +749,210 @@ compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifac
669
749
670
750
671writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
672−writeDetails root (Details.Details time outline locals foreigns extras) results =
752+writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
673 File.writeBinary (Stuff.details root) $
753 File.writeBinary (Stuff.details root) $
674− Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
754+ Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
675
755
676
756
677addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
757addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
678addNewLocal name result locals =
758addNewLocal name result locals =
679 case result of
759 case result of
680− RNew local _ _ -> Map.insert name local locals
760+ RNew local _ _ _ -> Map.insert name local locals
681− RSame local _ _ -> Map.insert name local locals
761+ RSame local _ _ _ -> Map.insert name local locals
682− RCached _ _ -> locals
762+ RCached _ _ _ -> locals
683− RNotFound _ -> locals
763+ RNotFound _ -> locals
684− RProblem _ -> locals
764+ RProblem _ -> locals
685− RBlocked -> locals
765+ RBlocked -> locals
686− RForeign _ -> locals
766+ RForeign _ -> locals
687− RKernel -> locals
767+ RKernel -> locals
688
768
689
769
690
770
691−-- DETECT EXPOSED PROBLEMS
771+-- FINALIZE EXPOSED
692
772
693
773
694−detectExposedProblems :: NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
774+finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
695−detectExposedProblems exposed results =
775+finalizeExposed root docsGoal exposed results =
696 case foldr (addImportProblems results) [] (NE.toList exposed) of
776 case foldr (addImportProblems results) [] (NE.toList exposed) of
697 p:ps ->
777 p:ps ->
698− Left (Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps)))
778+ return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
699
779
700 [] ->
780 [] ->
701 case Map.foldr addErrors [] results of
781 case Map.foldr addErrors [] results of
702− [] -> Right ()
782+ [] -> Right <$> finalizeDocs docsGoal results
703− e:es -> Left (Exit.BuildModuleProblems e es)
783+ e:es -> return $ Left $ Exit.BuildBadModules root e es
704
784
705
785
706addErrors :: Result -> [Error.Module] -> [Error.Module]
786addErrors :: Result -> [Error.Module] -> [Error.Module]
707addErrors result errors =
787addErrors result errors =
708 case result of
788 case result of
709− RNew _ _ _ -> errors
789+ RNew _ _ _ _ -> errors
710− RSame _ _ _ -> errors
790+ RSame _ _ _ _ -> errors
711− RCached _ _ -> errors
791+ RCached _ _ _ -> errors
712− RNotFound _ -> errors
792+ RNotFound _ -> errors
713− RProblem e -> e:errors
793+ RProblem e -> e:errors
714− RBlocked -> errors
794+ RBlocked -> errors
715− RForeign _ -> errors
795+ RForeign _ -> errors
716− RKernel -> errors
796+ RKernel -> errors
717
797
718
798
719addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
799addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
720addImportProblems results name problems =
800addImportProblems results name problems =
721 case results ! name of
801 case results ! name of
722− RNew _ _ _ -> problems
802+ RNew _ _ _ _ -> problems
723− RSame _ _ _ -> problems
803+ RSame _ _ _ _ -> problems
724− RCached _ _ -> problems
804+ RCached _ _ _ -> problems
725− RNotFound p -> (name, p) : problems
805+ RNotFound p -> (name, p) : problems
726− RProblem _ -> problems
806+ RProblem _ -> problems
727− RBlocked -> problems
807+ RBlocked -> problems
728− RForeign _ -> problems
808+ RForeign _ -> problems
729− RKernel -> problems
809+ RKernel -> problems
810+
811+
812+
813+-- DOCS
814+
815+
816+data DocsGoal a where
817+ KeepDocs :: DocsGoal Docs.Documentation
818+ WriteDocs :: FilePath -> DocsGoal ()
819+ IgnoreDocs :: DocsGoal ()
820+
821+
822+newtype DocsNeed =
823+ DocsNeed { needsDocs :: Bool }
824+
825+
826+toDocsNeed :: DocsGoal a -> DocsNeed
827+toDocsNeed goal =
828+ case goal of
829+ IgnoreDocs -> DocsNeed False
830+ WriteDocs _ -> DocsNeed True
831+ KeepDocs -> DocsNeed True
832+
833+
834+makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
835+makeDocs (DocsNeed isNeeded) modul =
836+ if isNeeded then
837+ case Docs.fromModule modul of
838+ Right docs -> Right (Just docs)
839+ Left err -> Left err
840+ else
841+ Right Nothing
842+
843+
844+finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
845+finalizeDocs goal results =
846+ case goal of
847+ KeepDocs ->
848+ return $ Map.mapMaybe toDocs results
849+
850+ WriteDocs path ->
851+ E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
852+
853+ IgnoreDocs ->
854+ return ()
855+
856+
857+toDocs :: Result -> Maybe Docs.Module
858+toDocs result =
859+ case result of
860+ RNew _ _ _ d -> d
861+ RSame _ _ _ d -> d
862+ RCached _ _ _ -> Nothing
863+ RNotFound _ -> Nothing
864+ RProblem _ -> Nothing
865+ RBlocked -> Nothing
866+ RForeign _ -> Nothing
867+ RKernel -> Nothing
868+
869+
870+
871+--------------------------------------------------------------------------------
872+------ NOW FOR SOME REPL STUFF -------------------------------------------------
873+--------------------------------------------------------------------------------
874+
875+
876+-- FROM REPL
877+
878+
879+data ReplArtifacts =
880+ ReplArtifacts
881+ { _repl_home :: ModuleName.Canonical
882+ , _repl_modules :: [Module]
883+ , _repl_localizer :: L.Localizer
884+ , _repl_annotations :: Map.Map Name.Name Can.Annotation
885+ }
886+
887+
888+fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
889+fromRepl root details source =
890+ do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
891+ case Parse.fromByteString projectType source of
892+ Left syntaxError ->
893+ return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
894+
895+ Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
896+ do dmvar <- Details.loadInterfaces root details
897+
898+ let deps = map Src.getImportName imports
899+ mvar <- newMVar Map.empty
900+ crawlDeps env mvar deps ()
901+
902+ statuses <- traverse readMVar =<< readMVar mvar
903+ midpoint <- checkMidpoint dmvar statuses
904+
905+ case midpoint of
906+ Left problem ->
907+ return $ Left $ Exit.ReplProjectProblem problem
908+
909+ Right foreigns ->
910+ do rmvar <- newEmptyMVar
911+ resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
912+ putMVar rmvar resultMVars
913+ results <- traverse readMVar resultMVars
914+ writeDetails root details results
915+ depsStatus <- checkDeps root resultMVars deps 0
916+ finalizeReplArtifacts env source modul depsStatus resultMVars results
917+
918+
919+finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
920+finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
921+ let
922+ pkg =
923+ projectTypeToPkg projectType
924+
925+ compileInput ifaces =
926+ case Compile.compile pkg ifaces modul of
927+ Right (Compile.Artifacts canonical annotations objects) ->
928+ let
929+ h = Can._name canonical
930+ m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
931+ ms = Map.foldrWithKey addInside [] results
932+ in
933+ return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
934+
935+ Left errors ->
936+ return $ Left $ Exit.ReplBadInput source errors
937+ in
938+ case depsStatus of
939+ DepsChange ifaces ->
940+ compileInput ifaces
941+
942+ DepsSame same cached ->
943+ do maybeLoaded <- loadInterfaces root same cached
944+ case maybeLoaded of
945+ Just ifaces -> compileInput ifaces
946+ Nothing -> return $ Left $ Exit.ReplBadCache
947+
948+ DepsBlock ->
949+ case Map.foldr addErrors [] results of
950+ [] -> return $ Left $ Exit.ReplBlocked
951+ e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
952+
953+ DepsNotFound problems ->
954+ return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
955+ toImportErrors env resultMVars imports problems
730
956
731
957
732
958
@@ -738,25 +964,25 @@ addImportProblems results name problems =
738
964
739
965
740
966
741−-- FIND MAIN
967+-- FIND ROOT
742
968
743
969
744−data MainLocation
970+data RootLocation
745 = LInside ModuleName.Raw
971 = LInside ModuleName.Raw
746 | LOutside FilePath
972 | LOutside FilePath
747
973
748
974
749−findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
975+findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
750−findMains env paths =
976+findRoots env paths =
751− do mvars <- traverse (fork . findLocation env) paths
977+ do mvars <- traverse (fork . getRootInfo env) paths
752− elocs <- traverse readMVar mvars
978+ einfos <- traverse readMVar mvars
753− return $ checkLocations =<< sequence elocs
979+ return $ checkRoots =<< sequence einfos
754
980
755
981
756−checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
982+checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
757−checkLocations locations =
983+checkRoots infos =
758 let
984 let
759− toOneOrMore loc@(Location absolute _ _) =
985+ toOneOrMore loc@(RootInfo absolute _ _) =
760 (absolute, OneOrMore.one loc)
986 (absolute, OneOrMore.one loc)
761
987
762 fromOneOrMore loc locs =
988 fromOneOrMore loc locs =
@@ -764,71 +990,83 @@ checkLocations locations =
764 [] -> Right ()
990 [] -> Right ()
765 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
766 in
992 in
767− fmap (\_ -> fmap _location locations) $
993+ fmap (\_ -> fmap _location infos) $
768 traverse (OneOrMore.destruct fromOneOrMore) $
994 traverse (OneOrMore.destruct fromOneOrMore) $
769− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
995+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
770
996
771
997
772
998
773−-- LOCATIONS
999+-- ROOT INFO
774
1000
775
1001
776−data Location =
1002+data RootInfo =
777− Location
1003+ RootInfo
778 { _absolute :: FilePath
1004 { _absolute :: FilePath
779 , _relative :: FilePath
1005 , _relative :: FilePath
780− , _location :: MainLocation
1006+ , _location :: RootLocation
781 }
1007 }
782
1008
783
1009
784−findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
1010+getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
785−findLocation env path =
1011+getRootInfo env path =
786 do exists <- File.exists path
1012 do exists <- File.exists path
787 if exists
1013 if exists
788− then isInsideSrcDirs env path <$> Dir.canonicalizePath path
1014+ then getRootInfoHelp env path =<< Dir.canonicalizePath path
789 else return (Left (Exit.BP_PathUnknown path))
1015 else return (Left (Exit.BP_PathUnknown path))
790
1016
791
1017
792−isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
1018+getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
793−isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
1019+getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
794 let
1020 let
795 (dirs, file) = FP.splitFileName absolutePath
1021 (dirs, file) = FP.splitFileName absolutePath
796− (final, ext) = break (=='.') file
1022+ (final, ext) = FP.splitExtension file
797 in
1023 in
798 if ext /= ".elm"
1024 if ext /= ".elm"
1025+ then
799− then Left (Exit.BP_WithBadExtension path)
1026+ return $ Left $ Exit.BP_WithBadExtension path
800 else
1027 else
801 let
1028 let
802− roots = FP.splitDirectories root
803− segments = FP.splitDirectories dirs ++ [final]
1029+ absoluteSegments = FP.splitDirectories dirs ++ [final]
804 in
1030 in
805− case dropPrefix roots segments of
1031+ case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
806− Nothing ->
1032+ [] ->
807− Right (Location absolutePath path (LOutside path))
1033+ return $ Right $ RootInfo absolutePath path (LOutside path)
808−
1034+
809− Just relativeSegments ->
1035+ [(_, Right names)] ->
810− let
1036+ do let name = Name.fromChars (List.intercalate "." names)
811− (exits, maybes) =
1037+ matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
812− Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
1038+ case matchingDirs of
813− in
1039+ d1:d2:_ ->
814− -- TODO make sure this is all correct
1040+ do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
815− case (exits, Maybe.catMaybes maybes) of
1041+ let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1042+ return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1043+
1044+ _ ->
816− (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
1045+ return $ Right $ RootInfo absolutePath path (LInside name)
817− ([], []) -> Right (Location absolutePath path (LOutside path))
1046+
1047+ [(s, Left names)] ->
1048+ return $ Left $ Exit.BP_RootNameInvalid path s names
1049+
1050+ (s1,_):(s2,_):_ ->
818− (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
1051+ return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
819− (exit:_, _) -> Left exit
1052+
820−
1053+
821−
1054+
822−isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
1055+isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
823−isInsideSrcDirsHelp segments srcDir =
1056+isInsideSrcDirByName names srcDir =
1057+ File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1058+
1059+
1060+isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1061+isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
824 case dropPrefix (FP.splitDirectories srcDir) segments of
1062 case dropPrefix (FP.splitDirectories srcDir) segments of
825 Nothing ->
1063 Nothing ->
826− Right Nothing
1064+ Nothing
827
1065
828 Just names ->
1066 Just names ->
829 if all isGoodName names
1067 if all isGoodName names
830− then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
1068+ then Just (srcDir, Right names)
831− else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
1069+ else Just (srcDir, Left names)
832
1070
833
1071
834isGoodName :: [Char] -> Bool
1072isGoodName :: [Char] -> Bool
@@ -841,6 +1079,8 @@ isGoodName name =
841 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
842
1080
843
1081
1082+-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083+--
844dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
845dropPrefix roots paths =
1085dropPrefix roots paths =
846 case roots of
1086 case roots of
@@ -849,37 +1089,37 @@ dropPrefix roots paths =
849
1089
850 r:rs ->
1090 r:rs ->
851 case paths of
1091 case paths of
852− [] -> Nothing
1092+ [] -> Nothing
853 p:ps -> if r == p then dropPrefix rs ps else Nothing
1093 p:ps -> if r == p then dropPrefix rs ps else Nothing
854
1094
855
1095
856
1096
857−-- CRAWL MAINS
1097+-- CRAWL ROOTS
858
1098
859
1099
860−data MainStatus
1100+data RootStatus
861 = SInside ModuleName.Raw
1101 = SInside ModuleName.Raw
862 | SOutsideOk Details.Local B.ByteString Src.Module
1102 | SOutsideOk Details.Local B.ByteString Src.Module
863 | SOutsideErr Error.Module
1103 | SOutsideErr Error.Module
864
1104
865
1105
866−crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1106+crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
867−crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1107+crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
868− case given of
1108+ case root of
869 LInside name ->
1109 LInside name ->
870 do statusMVar <- newEmptyMVar
1110 do statusMVar <- newEmptyMVar
871 statusDict <- takeMVar mvar
1111 statusDict <- takeMVar mvar
872 putMVar mvar (Map.insert name statusMVar statusDict)
1112 putMVar mvar (Map.insert name statusMVar statusDict)
873− putMVar statusMVar =<< crawlModule env mvar name
1113+ putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
874 return (SInside name)
1114 return (SInside name)
875
1115
876 LOutside path ->
1116 LOutside path ->
877 do time <- File.getTime path
1117 do time <- File.getTime path
878 source <- File.readUtf8 path
1118 source <- File.readUtf8 path
879− case Parse.fromByteString pkg source of
1119+ case Parse.fromByteString projectType source of
880 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1120 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
881 do let deps = map Src.getImportName imports
1121 do let deps = map Src.getImportName imports
882− let local = Details.Local path time deps (any isMain values)
1122+ let local = Details.Local path time deps (any isMain values) buildID buildID
883 crawlDeps env mvar deps (SOutsideOk local source modul)
1123 crawlDeps env mvar deps (SOutsideOk local source modul)
884
1124
885 Left syntaxError ->
1125 Left syntaxError ->
@@ -888,40 +1128,36 @@ crawlMain env@(Env _ _ pkg _ _ _) mvar given =
888
1128
889
1129
890
1130
891−-- CHECK MAINS
1131+-- CHECK ROOTS
892
1132
893
1133
894−data MainResult
1134+data RootResult
895 = RInside ModuleName.Raw
1135 = RInside ModuleName.Raw
896 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
897 | ROutsideErr Error.Module
1137 | ROutsideErr Error.Module
898 | ROutsideBlocked
1138 | ROutsideBlocked
899
1139
900
1140
901−checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1141+checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
902−checkMain env@(Env _ root _ _ _ _) results pendingMain =
1142+checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
903− case pendingMain of
1143+ case rootStatus of
904 SInside name ->
1144 SInside name ->
905 return (RInside name)
1145 return (RInside name)
906
1146
907 SOutsideErr err ->
1147 SOutsideErr err ->
908 return (ROutsideErr err)
1148 return (ROutsideErr err)
909
1149
910− SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1150+ SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
911− do depsStatus <- checkDeps root results deps
1151+ do depsStatus <- checkDeps root results deps lastCompile
912 case depsStatus of
1152 case depsStatus of
913 DepsChange ifaces ->
1153 DepsChange ifaces ->
914− return $ compileOutside env local source ifaces modul
1154+ compileOutside env local source ifaces modul
915
1155
916 DepsSame same cached ->
1156 DepsSame same cached ->
917− do maybeLoaded <- checkCachedInterfaces root cached
1157+ do maybeLoaded <- loadInterfaces root same cached
918 case maybeLoaded of
1158 case maybeLoaded of
919− Nothing ->
920− return ROutsideBlocked
1159+ Nothing -> return ROutsideBlocked
921−
922− Just loaded ->
923− do let ifaces = Map.union loaded (Map.fromList same)
924− return $ compileOutside env local source ifaces modul
1160+ Just ifaces -> compileOutside env local source ifaces modul
925
1161
926 DepsBlock ->
1162 DepsBlock ->
927 return ROutsideBlocked
1163 return ROutsideBlocked
@@ -931,53 +1167,54 @@ checkMain env@(Env _ root _ _ _ _) results pendingMain =
931 Error.BadImports (toImportErrors env results imports problems)
1167 Error.BadImports (toImportErrors env results imports problems)
932
1168
933
1169
934−compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
1170+compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
935−compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1171+compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
936 let
1172 let
1173+ pkg = projectTypeToPkg projectType
937 name = Src.getName modul
1174 name = Src.getName modul
938 in
1175 in
939 case Compile.compile pkg ifaces modul of
1176 case Compile.compile pkg ifaces modul of
940 Right (Compile.Artifacts canonical annotations objects) ->
1177 Right (Compile.Artifacts canonical annotations objects) ->
1178+ do Reporting.report key Reporting.BDone
941− ROutsideOk name (I.fromModule pkg canonical annotations) objects
1179+ return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
942
1180
943 Left errors ->
1181 Left errors ->
944− ROutsideErr $
945− Error.Module name path time source errors
1182+ return $ ROutsideErr $ Error.Module name path time source errors
946
1183
947
1184
948
1185
949-- TO ARTIFACTS
1186-- TO ARTIFACTS
950
1187
951
1188
952−data Main
1189+data Root
953 = Inside ModuleName.Raw
1190 = Inside ModuleName.Raw
954 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
955
1192
956
1193
957−toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1194+toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
958−toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1195+toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
959− case gatherProblemsOrMains results mainResults of
1196+ case gatherProblemsOrMains results rootResults of
960 Left (NE.List e es) ->
1197 Left (NE.List e es) ->
961− Left (Exit.BuildModuleProblems e es)
1198+ Left (Exit.BuildBadModules root e es)
962
1199
963− Right mains ->
1200+ Right roots ->
964− Right $ Artifacts pkg foreigns mains $
1201+ Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
965− Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1202+ Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
966
1203
967
1204
968−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1205+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
969−gatherProblemsOrMains results (NE.List mainResult mainResults) =
1206+gatherProblemsOrMains results (NE.List rootResult rootResults) =
970 let
1207 let
971− sortMain result (es, mains) =
1208+ addResult result (es, roots) =
972 case result of
1209 case result of
973− RInside n -> ( es, Inside n : mains)
1210+ RInside n -> ( es, Inside n : roots)
974− ROutsideOk n i o -> ( es, Outside n i o : mains)
1211+ ROutsideOk n i o -> ( es, Outside n i o : roots)
975− ROutsideErr e -> (e:es, mains)
1212+ ROutsideErr e -> (e:es, roots)
976− ROutsideBlocked -> ( es, mains)
1213+ ROutsideBlocked -> ( es, roots)
977
1214
978 errors = Map.foldr addErrors [] results
1215 errors = Map.foldr addErrors [] results
979 in
1216 in
980− case (mainResult, foldr sortMain (errors, []) mainResults) of
1217+ case (rootResult, foldr addResult (errors, []) rootResults) of
981 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
982 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1219 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
983 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1220 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
@@ -990,14 +1227,14 @@ gatherProblemsOrMains results (NE.List mainResult mainResults) =
990addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1227addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
991addInside name result modules =
1228addInside name result modules =
992 case result of
1229 case result of
993− RNew _ iface objs -> Fresh name iface objs : modules
1230+ RNew _ iface objs _ -> Fresh name iface objs : modules
994− RSame _ iface objs -> Fresh name iface objs : modules
1231+ RSame _ iface objs _ -> Fresh name iface objs : modules
995− RCached main mvar -> Cached name main mvar : modules
1232+ RCached main _ mvar -> Cached name main mvar : modules
996− RNotFound _ -> error (badInside name)
1233+ RNotFound _ -> error (badInside name)
997− RProblem _ -> error (badInside name)
1234+ RProblem _ -> error (badInside name)
998− RBlocked -> error (badInside name)
1235+ RBlocked -> error (badInside name)
999− RForeign _ -> modules
1236+ RForeign _ -> modules
1000− RKernel -> modules
1237+ RKernel -> modules
1001
1238
1002
1239
1003badInside :: ModuleName.Raw -> [Char]
1240badInside :: ModuleName.Raw -> [Char]
@@ -1005,9 +1242,9 @@ badInside name =
1005 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1242 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1006
1243
1007
1244
1008−addOutside :: MainResult -> [Module] -> [Module]
1245+addOutside :: RootResult -> [Module] -> [Module]
1009−addOutside main modules =
1246+addOutside root modules =
1010− case main of
1247+ case root of
1011 RInside _ -> modules
1248 RInside _ -> modules
1012 ROutsideOk name iface objs -> Fresh name iface objs : modules
1249 ROutsideOk name iface objs -> Fresh name iface objs : modules
1013 ROutsideErr _ -> modules
1250 ROutsideErr _ -> modules
builder/src/Deps/Bump.hsnew file+37
@@ -0,0 +1,37 @@
1+module Deps.Bump
2+ ( getPossibilities
3+ )
4+ where
5+
6+
7+import qualified Data.List as List
8+
9+import qualified Deps.Registry as Registry
10+import qualified Elm.Magnitude as M
11+import qualified Elm.Version as V
12+
13+
14+
15+-- GET POSSIBILITIES
16+
17+
18+getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)]
19+getPossibilities (Registry.KnownVersions latest previous) =
20+ let
21+ allVersions = reverse (latest:previous)
22+ minorPoints = map last (List.groupBy sameMajor allVersions)
23+ patchPoints = map last (List.groupBy sameMinor allVersions)
24+ in
25+ (latest, V.bumpMajor latest, M.MAJOR)
26+ : map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
27+ ++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
28+
29+
30+sameMajor :: V.Version -> V.Version -> Bool
31+sameMajor (V.Version major1 _ _) (V.Version major2 _ _) =
32+ major1 == major2
33+
34+
35+sameMinor :: V.Version -> V.Version -> Bool
36+sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) =
37+ major1 == major2 && minor1 == minor2
builder/src/Deps/Diff.hs+7−5
@@ -18,7 +18,7 @@ import qualified Data.List as List
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 Data.Utf8 as Utf8
21+import qualified System.Directory as Dir
22import System.FilePath ((</>))
22import System.FilePath ((</>))
23
23
24import qualified Deps.Website as Website
24import qualified Deps.Website as Website
@@ -204,7 +204,7 @@ isSameName :: Name.Name -> Name.Name -> Bool
204isSameName oldFullName newFullName =
204isSameName oldFullName newFullName =
205 let
205 let
206 dedot name =
206 dedot name =
207− reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))
207+ reverse (Name.splitDots name)
208 in
208 in
209 case ( dedot oldFullName, dedot newFullName ) of
209 case ( dedot oldFullName, dedot newFullName ) of
210 (oldName:[], newName:_) ->
210 (oldName:[], newName:_) ->
@@ -357,7 +357,8 @@ 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 path = Stuff.package cache name version </> "docs.json"
360+ do let home = Stuff.package cache name version
361+ let path = home </> "docs.json"
361 exists <- File.exists path
362 exists <- File.exists path
362 if exists
363 if exists
363 then
364 then
@@ -374,8 +375,9 @@ getDocs cache manager name version =
374 Http.get manager url [] Exit.DP_Http $ \body ->
375 Http.get manager url [] Exit.DP_Http $ \body ->
375 case D.fromByteString Docs.decoder body of
376 case D.fromByteString Docs.decoder body of
376 Right docs ->
377 Right docs ->
378+ do Dir.createDirectoryIfMissing True home
377− do File.writeUtf8 path body
379+ File.writeUtf8 path body
378 return $ Right docs
380 return $ Right docs
379
381
380 Left _ ->
382 Left _ ->
381− return $ Left Exit.DP_Data
383+ return $ Left $ Exit.DP_Data url body
builder/src/Deps/Registry.hs+6−7
@@ -54,11 +54,7 @@ data KnownVersions =
54
54
55read :: Stuff.PackageCache -> IO (Maybe Registry)
55read :: Stuff.PackageCache -> IO (Maybe Registry)
56read cache =
56read cache =
57− do let path = Stuff.registry cache
57+ File.readBinary (Stuff.registry cache)
58− exists <- File.exists path
59− if exists
60− then File.readBinary path
61− else return Nothing
62
58
63
59
64
60
@@ -193,11 +189,14 @@ getVersions' name (Registry _ versions) =
193
189
194post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
190post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
195post manager path decoder callback =
191post manager path decoder callback =
192+ let
196− Http.post manager (Website.route path []) [] Exit.RP_Http $
193+ url = Website.route path []
194+ in
195+ Http.post manager url [] Exit.RP_Http $
197 \body ->
196 \body ->
198 case D.fromByteString decoder body of
197 case D.fromByteString decoder body of
199 Right a -> Right <$> callback a
198 Right a -> Right <$> callback a
200− Left _ -> return $ Left Exit.RP_Data
199+ Left _ -> return $ Left $ Exit.RP_Data url body
201
200
202
201
203
202
builder/src/Deps/Solver.hs+31−29
@@ -94,6 +94,7 @@ 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 $
97 case try constraints of
98 case try constraints of
98 Solver solver ->
99 Solver solver ->
99 solver (State cache connection registry Map.empty)
100 solver (State cache connection registry Map.empty)
@@ -130,6 +131,7 @@ data AppSolution =
130
131
131addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
132addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
132addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
133addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134+ Stuff.withRegistryLock cache $
133 let
135 let
134 allIndirects = Map.union indirect testIndirect
136 allIndirects = Map.union indirect testIndirect
135 allDirects = Map.union direct testDirect
137 allDirects = Map.union direct testDirect
@@ -311,10 +313,11 @@ getConstraints pkg vsn =
311 back state
313 back state
312
314
313 Online manager ->
315 Online manager ->
314− do result <- Http.get manager (Website.metadata pkg vsn "elm.json") [] id (return . Right)
316+ do let url = Website.metadata pkg vsn "elm.json"
317+ result <- Http.get manager url [] id (return . Right)
315 case result of
318 case result of
316 Left httpProblem ->
319 Left httpProblem ->
317− err (Exit.SolverBadHttp httpProblem)
320+ err (Exit.SolverBadHttp pkg vsn httpProblem)
318
321
319 Right body ->
322 Right body ->
320 case D.fromByteString constraintsDecoder body of
323 case D.fromByteString constraintsDecoder body of
@@ -324,11 +327,9 @@ getConstraints pkg vsn =
324 ok (toNewState cs) cs back
327 ok (toNewState cs) cs back
325
328
326 Left _ ->
329 Left _ ->
327− err (Exit.SolverBadHttpData pkg vsn)
330+ err (Exit.SolverBadHttpData pkg vsn url)
328
331
329
332
330−-- TODO write constraintsDecoder to be a bit faster
331−--
332constraintsDecoder :: D.Decoder () Constraints
333constraintsDecoder :: D.Decoder () Constraints
333constraintsDecoder =
334constraintsDecoder =
334 do outline <- D.mapError (const ()) Outline.decoder
335 do outline <- D.mapError (const ()) Outline.decoder
@@ -350,30 +351,31 @@ data Env =
350
351
351initEnv :: IO (Either Exit.RegistryProblem Env)
352initEnv :: IO (Either Exit.RegistryProblem Env)
352initEnv =
353initEnv =
353− do mvar <- newEmptyMVar
354+ do mvar <- newEmptyMVar
354− _ <- forkIO $ putMVar mvar =<< Http.getManager
355+ _ <- forkIO $ putMVar mvar =<< Http.getManager
355− cache <- Stuff.getPackageCache
356+ cache <- Stuff.getPackageCache
357+ Stuff.withRegistryLock cache $
356− maybeRegistry <- Registry.read cache
358+ do maybeRegistry <- Registry.read cache
357− manager <- readMVar mvar
359+ manager <- readMVar mvar
358−
360+
359− case maybeRegistry of
361+ case maybeRegistry of
360− Nothing ->
362+ Nothing ->
361− do eitherRegistry <- Registry.fetch manager cache
363+ do eitherRegistry <- Registry.fetch manager cache
362− case eitherRegistry of
364+ case eitherRegistry of
363− Right latestRegistry ->
365+ Right latestRegistry ->
364− return $ Right $ Env cache manager (Online manager) latestRegistry
366+ return $ Right $ Env cache manager (Online manager) latestRegistry
365−
367+
366− Left problem ->
368+ Left problem ->
367− return $ Left $ problem
369+ return $ Left $ problem
368−
370+
369− Just cachedRegistry ->
371+ Just cachedRegistry ->
370− do eitherRegistry <- Registry.update manager cache cachedRegistry
372+ do eitherRegistry <- Registry.update manager cache cachedRegistry
371− case eitherRegistry of
373+ case eitherRegistry of
372− Right latestRegistry ->
374+ Right latestRegistry ->
373− return $ Right $ Env cache manager (Online manager) latestRegistry
375+ return $ Right $ Env cache manager (Online manager) latestRegistry
374−
376+
375− Left _ ->
377+ Left _ ->
376− return $ Right $ Env cache manager Offline cachedRegistry
378+ return $ Right $ Env cache manager Offline cachedRegistry
377
379
378
380
379
381
builder/src/Elm/Bump.hsdeleted−137
@@ -1,137 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Bump
3− ( bump
4− , toPossibleBumps
5− )
6− where
7−
8−
9−import Control.Monad.Trans (liftIO)
10−import qualified Data.List as List
11−
12−import qualified Deps.Cache as Cache
13−import qualified Deps.Diff as Diff
14−import qualified Elm.Project.Json as Project
15−import qualified Elm.Project.Summary as Summary
16−import qualified Elm.Version as V
17−import Reporting.Doc ((<>), (<+>))
18−import qualified Reporting.Doc as D
19−import qualified Reporting.Exit as Exit
20−import qualified Reporting.Exit.Bump as E
21−import qualified Reporting.Exit.Help as Help
22−import qualified Reporting.Progress.Terminal as Terminal
23−import qualified Reporting.Task as Task
24−
25−
26−
27−-- BUMP
28−
29−
30−bump :: Summary.Summary -> Task.Task ()
31−bump summary@(Summary.Summary root project _ _ _) =
32− case project of
33− Project.App _ ->
34− Task.throw (Exit.Bump E.Application)
35−
36− Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->
37− do registry <- Cache.mandatoryUpdate
38− case Cache.getVersions name registry of
39− Left _suggestions ->
40− checkNewPackage root info
41−
42− Right publishedVersions ->
43− let
44− bumpableVersions =
45− map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)
46− in
47− if elem version bumpableVersions then
48− suggestVersion summary info
49− else
50− Task.throw $ Exit.Bump $ E.Unbumpable version $
51− map head (List.group (List.sort bumpableVersions))
52−
53−
54−
55−-- VALID BUMPS
56−
57−
58−toPossibleBumps :: [V.Version] -> [(V.Version, V.Version, Diff.Magnitude)]
59−toPossibleBumps publishedVersions =
60− case publishedVersions of
61− [] ->
62− []
63−
64− _ ->
65− let
66− patchPoints =
67− V.filterLatest V.majorAndMinor publishedVersions
68−
69− minorPoints =
70− V.filterLatest V._major publishedVersions
71−
72− majorPoint =
73− maximum publishedVersions
74− in
75− (majorPoint, V.bumpMajor majorPoint, Diff.MAJOR)
76− : map (\v -> (v, V.bumpMinor v, Diff.MINOR)) minorPoints
77− ++ map (\v -> (v, V.bumpPatch v, Diff.PATCH)) patchPoints
78−
79−
80−
81−-- CHECK NEW PACKAGE
82−
83−
84−checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()
85−checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =
86− do liftIO $ putStrLn Terminal.newPackageOverview
87− if version == V.one
88− then
89− liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"
90− else
91− changeVersion root info V.one $
92− "It looks like the version in elm.json has been changed though!\n\
93− \Would you like me to change it back to "
94− <> D.fromUtf8 (V.toString V.one) <> "? [Y/n] "
95−
96−
97−
98−-- SUGGEST VERSION
99−
100−
101−suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()
102−suggestVersion (Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =
103− do oldDocs <- Cache.getDocs name version
104− newDocs <- Task.silently (error "TODO Project.generateDocs summary")
105− let changes = Diff.diff oldDocs newDocs
106− let newVersion = Diff.bump changes version
107− changeVersion root info newVersion $
108− let
109− old = D.fromUtf8 $ V.toString version
110− new = D.fromUtf8 $ V.toString newVersion
111− mag = D.fromChars $ Diff.magnitudeToString (Diff.toMagnitude changes)
112− in
113− "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
114− <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
115− <> "\n"
116− <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
117−
118−
119−
120−-- CHANGE VERSION
121−
122−
123−changeVersion :: FilePath -> Project.PkgInfo -> V.Version -> D.Doc -> Task.Task ()
124−changeVersion root info targetVersion explanation =
125− do approved <- Task.getApproval explanation
126− if not approved
127− then
128− liftIO $ putStrLn "Okay, I did not change anything!"
129−
130− else
131− do liftIO $ Project.write root $ Project.Pkg $
132− info { Project._pkg_version = targetVersion }
133−
134− liftIO $ Help.toStdout $
135− "Version changed to "
136− <> D.green (D.fromUtf8 (V.toString targetVersion))
137− <> "!\n"
builder/src/Elm/Details.hs+108−70
@@ -2,6 +2,7 @@
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3module Elm.Details
3module Elm.Details
4 ( Details(..)
4 ( Details(..)
5+ , BuildID
5 , ValidOutline(..)
6 , ValidOutline(..)
6 , Local(..)
7 , Local(..)
7 , Foreign(..)
8 , Foreign(..)
@@ -15,22 +16,26 @@ module Elm.Details
15
16
16import Control.Concurrent (forkIO)
17import Control.Concurrent (forkIO)
17import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
18import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
18−import Control.Monad (liftM, liftM2, liftM4)
19+import Control.Monad (liftM, liftM2, liftM3)
19import Data.Binary (Binary, get, put, getWord8, putWord8)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
21+import qualified Data.Either as Either
20import qualified Data.Map as Map
22import qualified Data.Map as Map
21import qualified Data.Map.Utils as Map
23import qualified Data.Map.Utils as Map
22import qualified Data.Map.Merge.Strict as Map
24import qualified Data.Map.Merge.Strict as Map
25+import qualified Data.Maybe as Maybe
23import qualified Data.Name as Name
26import qualified Data.Name as Name
24import qualified Data.NonEmptyList as NE
27import qualified Data.NonEmptyList as NE
25import qualified Data.OneOrMore as OneOrMore
28import qualified Data.OneOrMore as OneOrMore
26import qualified Data.Set as Set
29import qualified Data.Set as Set
27import qualified Data.Utf8 as Utf8
30import qualified Data.Utf8 as Utf8
31+import Data.Word (Word64)
28import qualified System.Directory as Dir
32import qualified System.Directory as Dir
29import System.FilePath ((</>), (<.>))
33import System.FilePath ((</>), (<.>))
30
34
31import qualified AST.Canonical as Can
35import qualified AST.Canonical as Can
32import qualified AST.Source as Src
36import qualified AST.Source as Src
33import qualified AST.Optimized as Opt
37import qualified AST.Optimized as Opt
38+import qualified BackgroundWriter as BW
34import qualified Compile
39import qualified Compile
35import qualified Deps.Registry as Registry
40import qualified Deps.Registry as Registry
36import qualified Deps.Solver as Solver
41import qualified Deps.Solver as Solver
@@ -63,23 +68,42 @@ data Details =
63 Details
68 Details
64 { _outlineTime :: File.Time
69 { _outlineTime :: File.Time
65 , _outline :: ValidOutline
70 , _outline :: ValidOutline
71+ , _buildID :: BuildID
66 , _locals :: Map.Map ModuleName.Raw Local
72 , _locals :: Map.Map ModuleName.Raw Local
67 , _foreigns :: Map.Map ModuleName.Raw Foreign
73 , _foreigns :: Map.Map ModuleName.Raw Foreign
68 , _extras :: Extras
74 , _extras :: Extras
69 }
75 }
70
76
71
77
72−data ValidOutline
78+type BuildID = Word64
73− = ValidApp (NE.List FilePath)
74− | ValidPkg Pkg.Name [ModuleName.Raw]
75
79
76
80
81+data ValidOutline
82+ = ValidApp (NE.List Outline.SrcDir)
83+ | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
84+
85+
86+-- NOTE: we need two ways to detect if a file must be recompiled:
87+--
88+-- (1) _time is the modification time from the last time we compiled the file.
89+-- By checking EQUALITY with the current modification time, we can detect file
90+-- saves and `git checkout` of previous versions. Both need a recompile.
91+--
92+-- (2) _lastChange is the BuildID from the last time a new interface file was
93+-- generated, and _lastCompile is the BuildID from the last time the file was
94+-- compiled. These may be different if a file is recompiled but the interface
95+-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
96+-- imports, we need to recompile. This can happen when a project has multiple
97+-- entrypoints and some modules are compiled less often than their imports.
98+--
77data Local =
99data Local =
78 Local
100 Local
79 { _path :: FilePath
101 { _path :: FilePath
80 , _time :: File.Time
102 , _time :: File.Time
81 , _deps :: [ModuleName.Raw]
103 , _deps :: [ModuleName.Raw]
82 , _main :: Bool
104 , _main :: Bool
105+ , _lastChange :: BuildID
106+ , _lastCompile :: BuildID
83 }
107 }
84
108
85
109
@@ -101,14 +125,14 @@ type Interfaces =
101
125
102
126
103loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
127loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
104−loadObjects root (Details _ _ _ _ extras) =
128+loadObjects root (Details _ _ _ _ _ extras) =
105 case extras of
129 case extras of
106 ArtifactsFresh _ o -> newMVar (Just o)
130 ArtifactsFresh _ o -> newMVar (Just o)
107 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
131 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
108
132
109
133
110loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
134loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
111−loadInterfaces root (Details _ _ _ _ extras) =
135+loadInterfaces root (Details _ _ _ _ _ extras) =
112 case extras of
136 case extras of
113 ArtifactsFresh i _ -> newMVar (Just i)
137 ArtifactsFresh i _ -> newMVar (Just i)
114 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
138 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
@@ -118,11 +142,11 @@ loadInterfaces root (Details _ _ _ _ extras) =
118-- VERIFY INSTALL -- used by Install
142-- VERIFY INSTALL -- used by Install
119
143
120
144
121−verifyInstall :: FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
145+verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
122−verifyInstall root (Solver.Env cache manager connection registry) outline =
146+verifyInstall scope root (Solver.Env cache manager connection registry) outline =
123 do time <- File.getTime (root </> "elm.json")
147 do time <- File.getTime (root </> "elm.json")
124 let key = Reporting.ignorer
148 let key = Reporting.ignorer
125− let env = Env key root cache manager connection registry
149+ let env = Env key scope root cache manager connection registry
126 case outline of
150 case outline of
127 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
151 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
128 Outline.App app -> Task.run (verifyApp env time app >> return ())
152 Outline.App app -> Task.run (verifyApp env time app >> return ())
@@ -132,28 +156,28 @@ verifyInstall root (Solver.Env cache manager connection registry) outline =
132-- LOAD -- used by Make, Repl, Reactor
156-- LOAD -- used by Make, Repl, Reactor
133
157
134
158
135−load :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)
159+load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
136−load style root =
160+load style scope root =
137 do newTime <- File.getTime (root </> "elm.json")
161 do newTime <- File.getTime (root </> "elm.json")
138 maybeDetails <- File.readBinary (Stuff.details root)
162 maybeDetails <- File.readBinary (Stuff.details root)
139 case maybeDetails of
163 case maybeDetails of
140 Nothing ->
164 Nothing ->
141− generate style root newTime
165+ generate style scope root newTime
142
166
143− Just details@(Details oldTime _ _ _ _) ->
167+ Just details@(Details oldTime _ buildID _ _ _) ->
144 if oldTime == newTime
168 if oldTime == newTime
145− then return (Right details)
169+ then return (Right details { _buildID = buildID + 1 })
146− else generate style root newTime
170+ else generate style scope root newTime
147
171
148
172
149
173
150-- GENERATE
174-- GENERATE
151
175
152
176
153−generate :: Reporting.Style -> FilePath -> File.Time -> IO (Either Exit.Details Details)
177+generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
154−generate style root time =
178+generate style scope root time =
155 Reporting.trackDetails style $ \key ->
179 Reporting.trackDetails style $ \key ->
156− do result <- initEnv key root
180+ do result <- initEnv key scope root
157 case result of
181 case result of
158 Left exit ->
182 Left exit ->
159 return (Left exit)
183 return (Left exit)
@@ -171,6 +195,7 @@ generate style root time =
171data Env =
195data Env =
172 Env
196 Env
173 { _key :: Reporting.DKey
197 { _key :: Reporting.DKey
198+ , _scope :: BW.Scope
174 , _root :: FilePath
199 , _root :: FilePath
175 , _cache :: Stuff.PackageCache
200 , _cache :: Stuff.PackageCache
176 , _manager :: Http.Manager
201 , _manager :: Http.Manager
@@ -179,8 +204,8 @@ data Env =
179 }
204 }
180
205
181
206
182−initEnv :: Reporting.DKey -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
207+initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
183−initEnv key root =
208+initEnv key scope root =
184 do mvar <- fork Solver.initEnv
209 do mvar <- fork Solver.initEnv
185 eitherOutline <- Outline.read root
210 eitherOutline <- Outline.read root
186 case eitherOutline of
211 case eitherOutline of
@@ -194,7 +219,7 @@ initEnv key root =
194 return $ Left $ Exit.DetailsCannotGetRegistry problem
219 return $ Left $ Exit.DetailsCannotGetRegistry problem
195
220
196 Right (Solver.Env cache manager connection registry) ->
221 Right (Solver.Env cache manager connection registry) ->
197− return $ Right (Env key root cache manager connection registry, outline)
222+ return $ Right (Env key scope root cache manager connection registry, outline)
198
223
199
224
200
225
@@ -210,7 +235,8 @@ verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm)
210 then
235 then
211 do solution <- verifyConstraints env =<< union noDups direct testDirect
236 do solution <- verifyConstraints env =<< union noDups direct testDirect
212 let exposedList = Outline.flattenExposed exposed
237 let exposedList = Outline.flattenExposed exposed
238+ let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
213− verifyDependencies env time (ValidPkg pkg exposedList) solution direct
239+ verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
214 else
240 else
215 Task.throw $ Exit.DetailsBadElmInPkg elm
241 Task.throw $ Exit.DetailsBadElmInPkg elm
216
242
@@ -240,7 +266,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
240
266
241
267
242verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
268verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
243−verifyConstraints (Env _ _ cache _ connection registry) constraints =
269+verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
244 do result <- Task.io $ Solver.verify cache connection registry constraints
270 do result <- Task.io $ Solver.verify cache connection registry constraints
245 case result of
271 case result of
246 Solver.Ok details -> return details
272 Solver.Ok details -> return details
@@ -286,27 +312,30 @@ fork work =
286
312
287
313
288verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
314verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
289−verifyDependencies env@(Env key root _ _ _ _) time outline solution directDeps =
315+verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
290 Task.eio id $
316 Task.eio id $
291 do Reporting.report key (Reporting.DStart (Map.size solution))
317 do Reporting.report key (Reporting.DStart (Map.size solution))
292 mvar <- newEmptyMVar
318 mvar <- newEmptyMVar
319+ mvars <- Stuff.withRegistryLock cache $
293− mvars <- Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
320+ Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
294 putMVar mvar mvars
321 putMVar mvar mvars
295 deps <- traverse readMVar mvars
322 deps <- traverse readMVar mvars
296 case sequence deps of
323 case sequence deps of
297− Left problem ->
324+ Left _ ->
298− error "TODO verifyDependencies" problem
325+ do home <- Stuff.getElmHome
326+ return $ Left $ Exit.DetailsBadDeps home $
327+ Maybe.catMaybes $ Either.lefts $ Map.elems deps
299
328
300 Right artifacts ->
329 Right artifacts ->
301 let
330 let
302 objs = Map.foldr addObjects Opt.empty artifacts
331 objs = Map.foldr addObjects Opt.empty artifacts
303 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
332 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
304− foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
333+ foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps
305− details = Details time outline Map.empty foreigns (ArtifactsFresh ifaces objs)
334+ details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
306 in
335 in
307− do File.writeBinary (Stuff.objects root) objs
336+ do BW.writeBinary scope (Stuff.objects root) objs
308− File.writeBinary (Stuff.interfaces root) ifaces
337+ BW.writeBinary scope (Stuff.interfaces root) ifaces
309− File.writeBinary (Stuff.details root) details
338+ BW.writeBinary scope (Stuff.details root) details
310 return (Right details)
339 return (Right details)
311
340
312
341
@@ -346,44 +375,36 @@ data Artifacts =
346
375
347
376
348type Dep =
377type Dep =
349− Either Problem Artifacts
378+ Either (Maybe Exit.DetailsBadDep) Artifacts
350−
351−
352−data Problem
353− = BadDownload Exit.PackageProblem
354− | BadBuild
355− | BadDependency
356
379
357
380
358verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
381verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
359−verifyDep (Env key _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
382+verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
360− let
361− fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
383+ do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
362− in
363− do exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
384+ exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
364 if exists
385 if exists
365 then
386 then
366 do Reporting.report key Reporting.DCached
387 do Reporting.report key Reporting.DCached
367 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
388 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
368 case maybeCache of
389 case maybeCache of
369 Nothing ->
390 Nothing ->
370− build key cache depsMVar pkg details (Set.singleton fingerprint)
391+ build key cache depsMVar pkg details fingerprint Set.empty
371
392
372 Just (ArtifactCache fingerprints artifacts) ->
393 Just (ArtifactCache fingerprints artifacts) ->
373 if Set.member fingerprint fingerprints
394 if Set.member fingerprint fingerprints
374 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
395 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
375− else build key cache depsMVar pkg details (Set.insert fingerprint fingerprints)
396+ else build key cache depsMVar pkg details fingerprint fingerprints
376 else
397 else
377 do Reporting.report key Reporting.DRequested
398 do Reporting.report key Reporting.DRequested
378 result <- downloadPackage cache manager pkg vsn
399 result <- downloadPackage cache manager pkg vsn
379 case result of
400 case result of
380− Left p ->
401+ Left problem ->
381 do Reporting.report key (Reporting.DFailed pkg vsn)
402 do Reporting.report key (Reporting.DFailed pkg vsn)
382− return (Left (BadDownload p))
403+ return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
383
404
384 Right () ->
405 Right () ->
385 do Reporting.report key (Reporting.DReceived pkg vsn)
406 do Reporting.report key (Reporting.DReceived pkg vsn)
386− build key cache depsMVar pkg details (Set.singleton fingerprint)
407+ build key cache depsMVar pkg details fingerprint Set.empty
387
408
388
409
389
410
@@ -405,17 +426,17 @@ type Fingerprint =
405-- BUILD
426-- BUILD
406
427
407
428
408−build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Dep
429+build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
409−build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
430+build key cache depsMVar pkg (Solver.Details vsn _) f fs =
410 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
431 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
411 case eitherOutline of
432 case eitherOutline of
412 Left _ ->
433 Left _ ->
413 do Reporting.report key Reporting.DBroken
434 do Reporting.report key Reporting.DBroken
414− return (Left BadBuild)
435+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
415
436
416 Right (Outline.App _) ->
437 Right (Outline.App _) ->
417 do Reporting.report key Reporting.DBroken
438 do Reporting.report key Reporting.DBroken
418− return (Left BadBuild)
439+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
419
440
420 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
441 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
421 do allDeps <- readMVar depsMVar
442 do allDeps <- readMVar depsMVar
@@ -423,7 +444,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
423 case sequence directDeps of
444 case sequence directDeps of
424 Left _ ->
445 Left _ ->
425 do Reporting.report key Reporting.DBroken
446 do Reporting.report key Reporting.DBroken
426− return (Left BadDependency)
447+ return $ Left $ Nothing
427
448
428 Right directArtifacts ->
449 Right directArtifacts ->
429 do let src = Stuff.package cache pkg vsn </> "src"
450 do let src = Stuff.package cache pkg vsn </> "src"
@@ -438,7 +459,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
438 case sequence maybeStatuses of
459 case sequence maybeStatuses of
439 Nothing ->
460 Nothing ->
440 do Reporting.report key Reporting.DBroken
461 do Reporting.report key Reporting.DBroken
441− return (Left BadBuild)
462+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
442
463
443 Just statuses ->
464 Just statuses ->
444 do rmvar <- newEmptyMVar
465 do rmvar <- newEmptyMVar
@@ -448,7 +469,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
448 case sequence maybeResults of
469 case sequence maybeResults of
449 Nothing ->
470 Nothing ->
450 do Reporting.report key Reporting.DBroken
471 do Reporting.report key Reporting.DBroken
451− return (Left BadBuild)
472+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
452
473
453 Just results ->
474 Just results ->
454 let
475 let
@@ -456,6 +477,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
456 ifaces = gatherInterfaces exposedDict results
477 ifaces = gatherInterfaces exposedDict results
457 objects = gatherObjects results
478 objects = gatherObjects results
458 artifacts = Artifacts ifaces objects
479 artifacts = Artifacts ifaces objects
480+ fingerprints = Set.insert f fs
459 in
481 in
460 do writeDocs cache pkg vsn docsStatus results
482 do writeDocs cache pkg vsn docsStatus results
461 File.writeBinary path (ArtifactCache fingerprints artifacts)
483 File.writeBinary path (ArtifactCache fingerprints artifacts)
@@ -573,7 +595,7 @@ crawlModule foreignDeps mvar pkg src docsStatus name =
573crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
595crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
574crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
596crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
575 do bytes <- File.readUtf8 path
597 do bytes <- File.readUtf8 path
576− case Parse.fromByteString pkg bytes of
598+ case Parse.fromByteString (Parse.Package pkg) bytes of
577 Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
599 Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
578 do deps <- crawlImports foreignDeps mvar pkg src imports
600 do deps <- crawlImports foreignDeps mvar pkg src imports
579 return (Just (SLocal docsStatus deps modul))
601 return (Just (SLocal docsStatus deps modul))
@@ -725,24 +747,27 @@ toDocs result =
725
747
726downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
748downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
727downloadPackage cache manager pkg vsn =
749downloadPackage cache manager pkg vsn =
750+ let
751+ url = Website.metadata pkg vsn "endpoint.json"
752+ in
728 do eitherByteString <-
753 do eitherByteString <-
729− Http.get manager (Website.metadata pkg vsn "endpoint.json") [] id (return . Right)
754+ Http.get manager url [] id (return . Right)
730
755
731 case eitherByteString of
756 case eitherByteString of
732 Left err ->
757 Left err ->
733− return (Left (Exit.PP_BadEndpointRequest err))
758+ return $ Left $ Exit.PP_BadEndpointRequest err
734
759
735 Right byteString ->
760 Right byteString ->
736 case D.fromByteString endpointDecoder byteString of
761 case D.fromByteString endpointDecoder byteString of
737 Left _ ->
762 Left _ ->
738− return (Left Exit.PP_BadEndpointContent)
763+ return $ Left $ Exit.PP_BadEndpointContent url
739
764
740 Right (endpoint, expectedHash) ->
765 Right (endpoint, expectedHash) ->
741− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
766+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
742 \(sha, archive) ->
767 \(sha, archive) ->
743 if expectedHash == Http.shaToChars sha
768 if expectedHash == Http.shaToChars sha
744 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
769 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
745− else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
770+ else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
746
771
747
772
748endpointDecoder :: D.Decoder e (String, String)
773endpointDecoder :: D.Decoder e (String, String)
@@ -757,27 +782,40 @@ endpointDecoder =
757
782
758
783
759instance Binary Details where
784instance 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
760− get = do { a <- get; b <- get; c <- get; d <- get; return (Details a b c d ArtifactsCached) }
792+ return (Details a b c d e ArtifactsCached)
761− put (Details a b c d _) = put a >> put b >> put c >> put d
762
793
763
794
764instance Binary ValidOutline where
795instance Binary ValidOutline where
765 put outline =
796 put outline =
766 case outline of
797 case outline of
767− ValidApp a -> putWord8 0 >> put a
798+ ValidApp a -> putWord8 0 >> put a
768− ValidPkg a b -> putWord8 1 >> put a >> put b
799+ ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
769
800
770 get =
801 get =
771 do n <- getWord8
802 do n <- getWord8
772 case n of
803 case n of
773 0 -> liftM ValidApp get
804 0 -> liftM ValidApp get
774− 1 -> liftM2 ValidPkg get get
805+ 1 -> liftM3 ValidPkg get get get
775− _ -> error "binary encoding of ValidOutline was corrupted"
806+ _ -> fail "binary encoding of ValidOutline was corrupted"
776
807
777
808
778instance Binary Local where
809instance Binary Local where
779− get = liftM4 Local get get get get
780− put (Local a b c d) = put a >> put b >> put c >> put d
810+ put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
811+ get =
812+ do a <- get
813+ b <- get
814+ c <- get
815+ d <- get
816+ e <- get
817+ f <- get
818+ return (Local a b c d e f)
781
819
782
820
783instance Binary Foreign where
821instance Binary Foreign where
builder/src/Elm/Diff.hsdeleted−284
@@ -1,284 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Diff
4− ( Args(..)
5− , diff
6− )
7− where
8−
9−
10−import Control.Monad.Except (liftIO)
11−import qualified Data.List as List
12−import qualified Data.Map as Map
13−import qualified Data.Maybe as Maybe
14−import qualified Data.Name as Name
15−
16−import qualified Deps.Cache as Cache
17−import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
18−import qualified Deps.Diff as Diff
19−import qualified Elm.Compiler.Type as Type
20−import qualified Elm.Docs as Docs
21−import qualified Elm.ModuleName as ModuleName
22−import qualified Elm.Package as Pkg
23−import qualified Elm.Project as Project
24−import qualified Elm.Project.Json as Project
25−import qualified Elm.Project.Summary as Summary
26−import qualified Elm.Version as V
27−import Reporting.Doc ((<>), (<+>))
28−import qualified Reporting.Doc as D
29−import qualified Reporting.Exit as Exit
30−import qualified Reporting.Exit.Diff as E
31−import qualified Reporting.Exit.Help as Help
32−import qualified Reporting.Render.Type.Localizer as L
33−import qualified Reporting.Task as Task
34−
35−
36−
37−-- DIFF
38−
39−
40−data Args
41− = CodeVsLatest
42− | CodeVsExactly V.Version
43− | LocalInquiry V.Version V.Version
44− | GlobalInquiry Pkg.Name V.Version V.Version
45−
46−
47−diff :: Args -> Task.Task ()
48−diff args =
49− case args of
50− GlobalInquiry name v1 v2 ->
51− do registry <- Cache.mandatoryUpdate
52− case Cache.getVersions name registry of
53− Left suggestions ->
54− throw $ E.UnknownPackage name suggestions
55−
56− Right vsns ->
57− do oldDocs <- getDocs name vsns (min v1 v2)
58− newDocs <- getDocs name vsns (max v1 v2)
59− writeDiff oldDocs newDocs
60−
61− LocalInquiry v1 v2 ->
62− do (_, name, vsns) <- getPackageInfo
63− oldDocs <- getDocs name vsns (min v1 v2)
64− newDocs <- getDocs name vsns (max v1 v2)
65− writeDiff oldDocs newDocs
66−
67− CodeVsLatest ->
68− do (summary, name, vsns) <- getPackageInfo
69− oldDocs <- getDocs name vsns (maximum vsns)
70− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
71− writeDiff oldDocs newDocs
72−
73− CodeVsExactly version ->
74− do (summary, name, vsns) <- getPackageInfo
75− oldDocs <- getDocs name vsns version
76− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
77− writeDiff oldDocs newDocs
78−
79−
80−throw :: E.Exit -> Task.Task a
81−throw exit =
82− Task.throw $ Exit.Diff exit
83−
84−
85−
86−-- DIFF HELPERS
87−
88−
89−getDocs :: Pkg.Name -> [V.Version] -> V.Version -> Task.Task Docs.Documentation
90−getDocs name allVersions version =
91− if elem version allVersions then
92− Cache.getDocs name version
93− else
94− throw $ E.UnknownVersion name version allVersions
95−
96−
97−getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [V.Version])
98−getPackageInfo =
99− do summary <- Project.getRoot
100− case Summary._project summary of
101− Project.App _ ->
102− throw $ E.Application
103−
104− Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
105− do registry <- Cache.mandatoryUpdate
106− case Cache.getVersions name registry of
107− Right vsns ->
108− return ( summary, name, vsns )
109−
110− Left _ ->
111− throw E.Unpublished
112−
113−
114−
115−-- WRITE DOC
116−
117−
118−writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()
119−writeDiff oldDocs newDocs =
120− let
121− changes = Diff.diff oldDocs newDocs
122− localizer = L.fromNames (Map.union oldDocs newDocs)
123− in
124− liftIO $ Help.toStdout (toDoc localizer changes <> "\n")
125−
126−
127−
128−-- TO DOC
129−
130−
131−toDoc :: L.Localizer -> PackageChanges -> D.Doc
132−toDoc localizer changes@(PackageChanges added changed removed) =
133− if null added && Map.null changed && null removed then
134− "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
135− else
136− let
137− magDoc =
138− D.fromChars (Diff.magnitudeToString (Diff.toMagnitude changes))
139−
140− header =
141− "This is a" <+> D.green magDoc <+> "change."
142−
143− addedChunk =
144− if null added then [] else
145− [ Chunk "ADDED MODULES" MINOR $
146− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) added
147− ]
148−
149− removedChunk =
150− if null removed then [] else
151− [ Chunk "REMOVED MODULES" MAJOR $
152− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) removed
153− ]
154−
155− chunks =
156− addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
157− in
158− D.vcat (header : "" : map chunkToDoc chunks)
159−
160−
161−data Chunk =
162− Chunk
163− { _title :: String
164− , _magnitude :: Magnitude
165− , _details :: D.Doc
166− }
167−
168−
169−chunkToDoc :: Chunk -> D.Doc
170−chunkToDoc (Chunk title magnitude details) =
171− let
172− magDoc =
173− Diff.magnitudeToString magnitude
174−
175− header =
176− "----" <+> D.fromChars title <+> "-" <+> D.fromChars magDoc <+> "----"
177− in
178− D.vcat
179− [ D.dullcyan header
180− , ""
181− , D.indent 4 details
182− , ""
183− , ""
184− ]
185−
186−
187−changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
188−changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
189− let
190− magnitude =
191− Diff.moduleChangeMagnitude changes
192−
193− (unionAdd, unionChange, unionRemove) =
194− changesToDocTriple (unionToDoc localizer) unions
195−
196− (aliasAdd, aliasChange, aliasRemove) =
197− changesToDocTriple (aliasToDoc localizer) aliases
198−
199− (valueAdd, valueChange, valueRemove) =
200− changesToDocTriple (valueToDoc localizer) values
201−
202− (binopAdd, binopChange, binopRemove) =
203− changesToDocTriple (binopToDoc localizer) binops
204− in
205− Chunk (Name.toChars name) magnitude $
206− D.vcat $ List.intersperse "" $ Maybe.catMaybes $
207− [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
208− , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
209− , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
210− ]
211−
212−
213−changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
214−changesToDocTriple entryToDoc (Changes added changed removed) =
215− let
216− indented (name, value) =
217− D.indent 4 (entryToDoc name value)
218−
219− diffed (name, (oldValue, newValue)) =
220− D.vcat
221− [ " - " <> entryToDoc name oldValue
222− , " + " <> entryToDoc name newValue
223− , ""
224− ]
225− in
226− ( map indented (Map.toList added)
227− , map diffed (Map.toList changed)
228− , map indented (Map.toList removed)
229− )
230−
231−
232−changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
233−changesToDoc categoryName unions aliases values binops =
234− if null unions && null aliases && null values && null binops then
235− Nothing
236−
237− else
238− Just $ D.vcat $
239− D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
240−
241−
242−unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
243−unionToDoc localizer name (Docs.Union _ tvars ctors) =
244− let
245− setup =
246− "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
247−
248− ctorDoc (ctor, tipes) =
249− typeDoc localizer (Type.Type ctor tipes)
250− in
251− D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
252−
253−
254−aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
255−aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
256− let
257− declaration =
258− "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
259− in
260− D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
261−
262−
263−valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
264−valueToDoc localizer name (Docs.Value _ tipe) =
265− D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
266−
267−
268−binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
269−binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
270− "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
271− where
272− details =
273− " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
274−
275− assoc =
276− case associativity of
277− Docs.Left -> "left"
278− Docs.Non -> "non"
279− Docs.Right -> "right"
280−
281−
282−typeDoc :: L.Localizer -> Type.Type -> D.Doc
283−typeDoc localizer tipe =
284− Type.toDoc localizer Type.None tipe
builder/src/Elm/Outline.hs+109−15
@@ -5,6 +5,7 @@ module Elm.Outline
5 , AppOutline(..)
5 , AppOutline(..)
6 , PkgOutline(..)
6 , PkgOutline(..)
7 , Exposed(..)
7 , Exposed(..)
8+ , SrcDir(..)
8 , read
9 , read
9 , write
10 , write
10 , encode
11 , encode
@@ -16,11 +17,14 @@ module Elm.Outline
16
17
17
18
18import Prelude hiding (read)
19import Prelude hiding (read)
19−import Control.Monad (filterM)
20+import Control.Monad (filterM, liftM)
21+import Data.Binary (Binary, get, put, getWord8, putWord8)
20import qualified Data.Map as Map
22import qualified Data.Map as Map
21import qualified Data.NonEmptyList as NE
23import qualified Data.NonEmptyList as NE
24+import qualified Data.OneOrMore as OneOrMore
22import Foreign.Ptr (minusPtr)
25import Foreign.Ptr (minusPtr)
23import qualified System.Directory as Dir
26import qualified System.Directory as Dir
27+import qualified System.FilePath as FP
24import System.FilePath ((</>))
28import System.FilePath ((</>))
25
29
26import qualified Elm.Constraint as Con
30import qualified Elm.Constraint as Con
@@ -49,7 +53,7 @@ data Outline
49data AppOutline =
53data AppOutline =
50 AppOutline
54 AppOutline
51 { _app_elm_version :: V.Version
55 { _app_elm_version :: V.Version
52− , _app_source_dirs :: NE.List FilePath
56+ , _app_source_dirs :: NE.List SrcDir
53 , _app_deps_direct :: Map.Map Pkg.Name V.Version
57 , _app_deps_direct :: Map.Map Pkg.Name V.Version
54 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
58 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
55 , _app_test_direct :: Map.Map Pkg.Name V.Version
59 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -75,6 +79,11 @@ data Exposed
75 | ExposedDict [(Json.String, [ModuleName.Raw])]
79 | ExposedDict [(Json.String, [ModuleName.Raw])]
76
80
77
81
82+data SrcDir
83+ = AbsoluteSrcDir FilePath
84+ | RelativeSrcDir FilePath
85+
86+
78
87
79-- DEFAULTS
88-- DEFAULTS
80
89
@@ -117,7 +126,7 @@ encode outline =
117 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
118 E.object
127 E.object
119 [ "type" ==> E.chars "application"
128 [ "type" ==> E.chars "application"
120− , "source-directories" ==> E.list E.chars (NE.toList srcDirs)
129+ , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
121 , "elm-version" ==> V.encode elm
130 , "elm-version" ==> V.encode elm
122 , "dependencies" ==>
131 , "dependencies" ==>
123 E.object
132 E.object
@@ -165,6 +174,13 @@ encodeDeps encodeValue deps =
165 E.dict Pkg.toJsonString encodeValue deps
174 E.dict Pkg.toJsonString encodeValue deps
166
175
167
176
177+encodeSrcDir :: SrcDir -> E.Value
178+encodeSrcDir srcDir =
179+ case srcDir of
180+ AbsoluteSrcDir dir -> E.chars dir
181+ RelativeSrcDir dir -> E.chars dir
182+
183+
168
184
169-- PARSE AND VERIFY
185-- PARSE AND VERIFY
170
186
@@ -178,19 +194,72 @@ read root =
178
194
179 Right outline ->
195 Right outline ->
180 case outline of
196 case outline of
181− Pkg _ ->
197+ Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
198+ return $
199+ if Map.notMember Pkg.core deps && pkg /= Pkg.core
200+ then Left Exit.OutlineNoPkgCore
182− return $ Right outline
201+ else Right outline
202+
203+ App (AppOutline _ srcDirs direct indirect _ _)
204+ | Map.notMember Pkg.core direct ->
205+ return $ Left Exit.OutlineNoAppCore
206+
207+ | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
208+ return $ Left Exit.OutlineNoAppJson
209+
210+ | otherwise ->
211+ do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
212+ case map toGiven badDirs of
213+ d:ds ->
214+ return $ Left (Exit.OutlineHasMissingSrcDirs d ds)
215+
216+ [] ->
217+ do maybeDups <- detectDuplicates root (NE.toList srcDirs)
218+ case maybeDups of
219+ Nothing ->
220+ return $ Right outline
221+
222+ Just (canonicalDir, (dir1,dir2)) ->
223+ return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)
224+
225+
226+isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
227+isSrcDirMissing root srcDir =
228+ not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
229+
230+
231+toGiven :: SrcDir -> FilePath
232+toGiven srcDir =
233+ case srcDir of
234+ AbsoluteSrcDir dir -> dir
235+ RelativeSrcDir dir -> dir
183
236
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)
189
237
238+toAbsolute :: FilePath -> SrcDir -> FilePath
239+toAbsolute root srcDir =
240+ case srcDir of
241+ AbsoluteSrcDir dir -> dir
242+ RelativeSrcDir dir -> root </> dir
190
243
191−isBadSrcDir :: FilePath -> FilePath -> IO Bool
244+
192−isBadSrcDir root dir =
245+detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
193− not <$> Dir.doesDirectoryExist (root </> dir)
246+detectDuplicates root srcDirs =
247+ do pairs <- traverse (toPair root) srcDirs
248+ return $ Map.lookupMin $ Map.mapMaybe isDup $
249+ Map.fromListWith OneOrMore.more pairs
250+
251+
252+toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
253+toPair root srcDir =
254+ do key <- Dir.canonicalizePath (toAbsolute root srcDir)
255+ return (key, OneOrMore.one (toGiven srcDir))
256+
257+
258+isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
259+isDup paths =
260+ case paths of
261+ OneOrMore.One _ -> Nothing
262+ OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
194
263
195
264
196
265
@@ -268,9 +337,16 @@ depsDecoder valueDecoder =
268 D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
337 D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
269
338
270
339
271−dirsDecoder :: Decoder (NE.List FilePath)
340+dirsDecoder :: Decoder (NE.List SrcDir)
272dirsDecoder =
341dirsDecoder =
273− fmap Json.toChars <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
342+ fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
343+
344+
345+toSrcDir :: FilePath -> SrcDir
346+toSrcDir path =
347+ if FP.isRelative path
348+ then RelativeSrcDir path
349+ else AbsoluteSrcDir path
274
350
275
351
276
352
@@ -311,3 +387,21 @@ boundParser bound tooLong =
311 if len < bound
387 if len < bound
312 then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
388 then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
313 else cerr row newCol (\_ _ -> tooLong)
389 else cerr row newCol (\_ _ -> tooLong)
390+
391+
392+
393+-- BINARY
394+
395+
396+instance Binary SrcDir where
397+ put outline =
398+ case outline of
399+ AbsoluteSrcDir a -> putWord8 0 >> put a
400+ RelativeSrcDir a -> putWord8 1 >> put a
401+
402+ get =
403+ do n <- getWord8
404+ case n of
405+ 0 -> liftM AbsoluteSrcDir get
406+ 1 -> liftM RelativeSrcDir get
407+ _ -> fail "binary encoding of SrcDir was corrupted"
builder/src/Elm/Publish.hsdeleted−255
@@ -1,255 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Elm.Publish (publish) where
3−
4−
5−import Control.Monad (when)
6−import Control.Monad.Except (catchError, runExceptT)
7−import Control.Monad.Trans (liftIO, lift)
8−import qualified Data.List as List
9−import qualified Data.Utf8 as Utf8
10−import qualified System.Directory as Dir
11−import qualified System.Exit as Exit
12−import System.FilePath ((</>))
13−import qualified System.IO as IO
14−import qualified System.Process as Process
15−
16−import qualified Deps.Cache as Cache
17−import qualified Deps.Diff as Diff
18−import qualified Deps.Website as Website
19−import qualified Elm.Bump as Bump
20−import qualified Elm.Docs as Docs
21−import qualified Elm.Package as Pkg
22−import qualified Elm.Project.Json as Project
23−import qualified Elm.Project.Summary as Summary
24−import qualified Elm.Version as V
25−import qualified Reporting.Exit as Exit
26−import qualified Reporting.Exit.Publish as E
27−import qualified Reporting.Progress as Progress
28−import qualified Reporting.Task as Task
29−import qualified Stuff.Paths as Path
30−
31−
32−
33−-- PUBLISH
34−
35−
36−publish :: Summary.Summary -> Task.Task ()
37−publish summary@(Summary.Summary root project _ _ _) =
38− case project of
39− Project.App _ ->
40− throw E.Application
41−
42− Project.Pkg (Project.PkgInfo name smry _ version exposed _ _ _) ->
43− do
44− registry <- Cache.mandatoryUpdate
45− let maybePublishedVersions = either (const Nothing) Just (Cache.getVersions name registry)
46−
47− Task.report (Progress.PublishStart name version maybePublishedVersions)
48−
49− when (noExposed exposed) $ throw E.NoExposed
50− when (badSummary smry) $ throw E.NoSummary
51−
52− verifyReadme root
53− verifyLicense root
54− docs <- Task.silently (error "TODO Project.generateDocs summary" summary)
55− verifyVersion name version docs maybePublishedVersions
56− commitHash <- verifyTag name version
57− verifyNoChanges commitHash version
58− zipHash <- verifyZip name version
59−
60− Website.register name version commitHash zipHash
61−
62− Task.report Progress.PublishEnd
63−
64−
65−throw :: E.Exit -> Task.Task a
66−throw exit =
67− Task.throw (Exit.Publish exit)
68−
69−
70−
71−-- VERIFY SUMMARY
72−
73−
74−badSummary :: Utf8.String -> Bool
75−badSummary summary =
76− Utf8.isEmpty summary || Project.defaultSummary == summary
77−
78−
79−noExposed :: Project.Exposed -> Bool
80−noExposed exposed =
81− case exposed of
82− Project.ExposedList modules ->
83− null modules
84−
85− Project.ExposedDict chunks ->
86− all (null . snd) chunks
87−
88−
89−
90−-- VERIFY README
91−
92−
93−verifyReadme :: FilePath -> Task.Task ()
94−verifyReadme root =
95− phase Progress.CheckReadme $
96− do let readmePath = root </> "README.md"
97− exists <- liftIO $ Dir.doesFileExist readmePath
98− case exists of
99− False ->
100− throw E.NoReadme
101−
102− True ->
103− do size <- liftIO $ IO.withFile readmePath IO.ReadMode IO.hFileSize
104− if size < 300
105− then throw E.ShortReadme
106− else return ()
107−
108−
109−
110−-- VERIFY LICENSE
111−
112−
113−verifyLicense :: FilePath -> Task.Task ()
114−verifyLicense root =
115− phase Progress.CheckLicense $
116− do let licensePath = root </> "LICENSE"
117− exists <- liftIO $ Dir.doesFileExist licensePath
118− if exists
119− then return ()
120− else throw E.NoLicense
121−
122−
123−
124−-- VERIFY GITHUB TAG
125−
126−
127−verifyTag :: Pkg.Name -> V.Version -> Task.Task String
128−verifyTag name version =
129− phase (Progress.CheckTag version) $
130− Website.githubCommit name version `catchError` \_ ->
131− throw (E.MissingTag version)
132−
133−
134−
135−-- VERIFY NO LOCAL CHANGES SINCE TAG
136−
137−
138−verifyNoChanges :: String -> V.Version -> Task.Task ()
139−verifyNoChanges commitHash version =
140− phase Progress.CheckChanges $
141− do maybeGit <- liftIO $ Dir.findExecutable "git"
142− case maybeGit of
143− Nothing ->
144− throw E.NoGit
145−
146− Just git ->
147− do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
148− exitCode <- liftIO $
149− Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]
150−
151− case exitCode of
152− Exit.ExitSuccess ->
153− return ()
154−
155− Exit.ExitFailure _ ->
156− throw (E.LocalChanges version)
157−
158−
159−
160−-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
161−
162−
163−verifyZip :: Pkg.Name -> V.Version -> Task.Task Website.Sha
164−verifyZip name version =
165− withTempDir $ \dir ->
166− do hash <- phase Progress.CheckDownload $
167− Website.githubDownload name version dir
168−
169− phase Progress.CheckBuild $
170− do runner <- Task.getSilentRunner
171− result <- liftIO $ Dir.withCurrentDirectory dir $ runner $
172− Task.silently $ error "TODO Project.generateDocs =<< Project.getRoot"
173− either Task.throw (\_ -> return ()) result
174−
175− return hash
176−
177−
178−withTempDir :: (FilePath -> Task.Task a) -> Task.Task a
179−withTempDir callback =
180− do liftIO $ Dir.createDirectoryIfMissing True Path.prepublishDir
181− result <- lift $ runExceptT $ callback Path.prepublishDir
182− liftIO $ Dir.removeDirectoryRecursive Path.prepublishDir
183− either Task.throw return result
184−
185−
186−
187−-- PHASE REPORTING
188−
189−
190−phase :: Progress.PublishPhase -> Task.Task a -> Task.Task a
191−phase publishPhase task =
192− do Task.report $ Progress.PublishProgress publishPhase Nothing
193−
194− result <- task `catchError` \exit ->
195− do Task.report $ Progress.PublishProgress publishPhase (Just Progress.Bad)
196− Task.throw exit
197−
198− Task.report $ Progress.PublishProgress publishPhase (Just Progress.Good)
199−
200− return result
201−
202−
203−
204−-- VERIFY VERSION
205−
206−
207−verifyVersion :: Pkg.Name -> V.Version -> Docs.Documentation -> Maybe [V.Version] -> Task.Task ()
208−verifyVersion name version docs maybePublishedVersions =
209− let
210− reportBumpPhase bumpPhase =
211− Task.report $ Progress.PublishCheckBump version bumpPhase
212− in
213− do reportBumpPhase Progress.StatedVersion
214− case maybePublishedVersions of
215− Nothing ->
216− if version == V.one then
217− reportBumpPhase Progress.GoodStart
218− else
219− throw (E.NotInitialVersion version)
220−
221− Just publishedVersions ->
222− if elem version publishedVersions then
223− throw $ E.AlreadyPublished version
224− else
225− do (old, magnitude) <- verifyBump name version docs publishedVersions
226− reportBumpPhase (Progress.GoodBump old magnitude)
227−
228− `catchError` \exit ->
229− do reportBumpPhase Progress.BadBump
230− Task.throw exit
231−
232−
233−verifyBump :: Pkg.Name -> V.Version -> Docs.Documentation -> [V.Version] -> Task.Task (V.Version, Diff.Magnitude)
234−verifyBump name statedVersion newDocs publishedVersions =
235− let
236− possibleBumps =
237− Bump.toPossibleBumps publishedVersions
238−
239− isTheBump (_ ,new, _) =
240− statedVersion == new
241− in
242− case List.find isTheBump possibleBumps of
243− Nothing ->
244− throw $ E.InvalidBump statedVersion (last publishedVersions)
245−
246− Just (old, new, magnitude) ->
247− do oldDocs <- Cache.getDocs name old
248− let changes = Diff.diff oldDocs newDocs
249− let realNew = Diff.bump changes old
250− if new == realNew
251− then
252− return (old, magnitude)
253− else
254− throw $ E.BadBump old new magnitude realNew $
255− Diff.toMagnitude changes
builder/src/File.hs+28−5
@@ -1,6 +1,7 @@
1module File
1module File
2 ( Time
2 ( Time
3 , getTime
3 , getTime
4+ , zeroTime
4 , writeBinary
5 , writeBinary
5 , readBinary
6 , readBinary
6 , writeUtf8
7 , writeUtf8
@@ -23,6 +24,7 @@ import qualified Data.ByteString.Builder as B
23import qualified Data.ByteString.Lazy as LBS
24import qualified Data.ByteString.Lazy as LBS
24import qualified Data.Fixed as Fixed
25import qualified Data.Fixed as Fixed
25import qualified Data.List as List
26import qualified Data.List as List
27+import qualified Data.Time.Clock as Time
26import qualified Data.Time.Clock.POSIX as Time
28import qualified Data.Time.Clock.POSIX as Time
27import qualified Foreign.ForeignPtr as FPtr
29import qualified Foreign.ForeignPtr as FPtr
28import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
30import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
@@ -44,11 +46,15 @@ newtype Time = Time Fixed.Pico
44getTime :: FilePath -> IO Time
46getTime :: FilePath -> IO Time
45getTime path =
47getTime path =
46 fmap
48 fmap
47− (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
48−-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
49+ (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
49 (Dir.getModificationTime path)
50 (Dir.getModificationTime path)
50
51
51
52
53+zeroTime :: Time
54+zeroTime =
55+ Time 0
56+
57+
52instance Binary.Binary Time where
58instance Binary.Binary Time where
53 put (Time time) = Binary.put time
59 put (Time time) = Binary.put time
54 get = Time <$> Binary.get
60 get = Time <$> Binary.get
@@ -72,8 +78,21 @@ readBinary path =
72 then
78 then
73 do result <- Binary.decodeFileOrFail path
79 do result <- Binary.decodeFileOrFail path
74 case result of
80 case result of
81+ Right a ->
75− Right a -> return (Just a)
82+ return (Just a)
83+
84+ Left (offset, message) ->
85+ do IO.hPutStrLn IO.stderr $ unlines $
86+ [ "+-------------------------------------------------------------------------------"
87+ , "| Corrupt File: " ++ path
88+ , "| Byte Offset: " ++ show offset
89+ , "| Message: " ++ message
90+ , "|"
91+ , "| Please report this to https://github.com/elm/compiler/issues"
92+ , "| Trying to continue anyway."
93+ , "+-------------------------------------------------------------------------------"
94+ ]
76− Left e -> return Nothing
95+ return Nothing
77 else
96 else
78 return Nothing
97 return Nothing
79
98
@@ -171,7 +190,11 @@ writeEntry destination root entry =
171 let
190 let
172 path = drop root (Zip.eRelativePath entry)
191 path = drop root (Zip.eRelativePath entry)
173 in
192 in
174− if List.isPrefixOf "src/" path then
193+ if List.isPrefixOf "src/" path
194+ || path == "LICENSE"
195+ || path == "README.md"
196+ || path == "elm.json"
197+ then
175 if not (null path) && last path == '/'
198 if not (null path) && last path == '/'
176 then Dir.createDirectoryIfMissing True (destination </> path)
199 then Dir.createDirectoryIfMissing True (destination </> path)
177 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
200 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
builder/src/Generate.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# LANGUAGE BangPatterns #-}
2+module Generate
3+ ( debug
4+ , dev
5+ , prod
6+ , repl
7+ )
8+ where
9+
10+
11+import Prelude hiding (cycle, print)
12+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13+import Control.Monad (liftM2)
14+import qualified Data.ByteString.Builder as B
15+import Data.Map ((!))
16+import qualified Data.Map as Map
17+import qualified Data.Maybe as Maybe
18+import qualified Data.Name as N
19+import qualified Data.NonEmptyList as NE
20+
21+import qualified AST.Optimized as Opt
22+import qualified Build
23+import qualified Elm.Compiler.Type.Extract as Extract
24+import qualified Elm.Details as Details
25+import qualified Elm.Interface as I
26+import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Package as Pkg
28+import qualified File
29+import qualified Generate.JavaScript as JS
30+import qualified Generate.Mode as Mode
31+import qualified Nitpick.Debug as Nitpick
32+import qualified Reporting.Exit as Exit
33+import qualified Reporting.Task as Task
34+import qualified Stuff
35+
36+
37+-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38+-- desireable to have Repl and Reactor to keep foreign objects in memory
39+-- to make things a bit faster?
40+
41+
42+
43+-- GENERATORS
44+
45+
46+type Task a =
47+ Task.Task Exit.Generate a
48+
49+
50+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51+debug root details (Build.Artifacts pkg ifaces roots modules) =
52+ do loading <- loadObjects root details modules
53+ types <- loadTypes root ifaces modules
54+ objects <- finalizeObjects loading
55+ let mode = Mode.Dev (Just types)
56+ let graph = objectsToGlobalGraph objects
57+ let mains = gatherMains pkg objects roots
58+ return $ JS.generate mode graph mains
59+
60+
61+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62+dev root details (Build.Artifacts pkg _ roots modules) =
63+ do objects <- finalizeObjects =<< loadObjects root details modules
64+ let mode = Mode.Dev Nothing
65+ let graph = objectsToGlobalGraph objects
66+ let mains = gatherMains pkg objects roots
67+ return $ JS.generate mode graph mains
68+
69+
70+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71+prod root details (Build.Artifacts pkg _ roots modules) =
72+ do objects <- finalizeObjects =<< loadObjects root details modules
73+ checkForDebugUses objects
74+ let graph = objectsToGlobalGraph objects
75+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
76+ let mains = gatherMains pkg objects roots
77+ return $ JS.generate mode graph mains
78+
79+
80+repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81+repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82+ do objects <- finalizeObjects =<< loadObjects root details modules
83+ let graph = objectsToGlobalGraph objects
84+ return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85+
86+
87+
88+-- CHECK FOR DEBUG
89+
90+
91+checkForDebugUses :: Objects -> Task ()
92+checkForDebugUses (Objects _ locals) =
93+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94+ [] -> return ()
95+ m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96+
97+
98+
99+-- GATHER MAINS
100+
101+
102+gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103+gatherMains pkg (Objects _ locals) roots =
104+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105+
106+
107+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108+lookupMain pkg locals root =
109+ let
110+ toPair name (Opt.LocalGraph maybeMain _ _) =
111+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
112+ in
113+ case root of
114+ Build.Inside name -> toPair name =<< Map.lookup name locals
115+ Build.Outside name _ g -> toPair name g
116+
117+
118+
119+-- LOADING OBJECTS
120+
121+
122+data LoadingObjects =
123+ LoadingObjects
124+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126+ }
127+
128+
129+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130+loadObjects root details modules =
131+ Task.io $
132+ do mvar <- Details.loadObjects root details
133+ mvars <- traverse (loadObject root) modules
134+ return $ LoadingObjects mvar (Map.fromList mvars)
135+
136+
137+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138+loadObject root modul =
139+ case modul of
140+ Build.Fresh name _ graph ->
141+ do mvar <- newMVar (Just graph)
142+ return (name, mvar)
143+
144+ Build.Cached name _ _ ->
145+ do mvar <- newEmptyMVar
146+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147+ return (name, mvar)
148+
149+
150+
151+-- FINALIZE OBJECTS
152+
153+
154+data Objects =
155+ Objects
156+ { _foreign :: Opt.GlobalGraph
157+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158+ }
159+
160+
161+finalizeObjects :: LoadingObjects -> Task Objects
162+finalizeObjects (LoadingObjects mvar mvars) =
163+ Task.eio id $
164+ do result <- readMVar mvar
165+ results <- traverse readMVar mvars
166+ case liftM2 Objects result (sequence results) of
167+ Just loaded -> return (Right loaded)
168+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169+
170+
171+objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172+objectsToGlobalGraph (Objects globals locals) =
173+ foldr Opt.addLocalGraph globals locals
174+
175+
176+
177+-- LOAD TYPES
178+
179+
180+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181+loadTypes root ifaces modules =
182+ Task.eio id $
183+ do mvars <- traverse (loadTypesHelp root) modules
184+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185+ results <- traverse readMVar mvars
186+ case sequence results of
187+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189+
190+
191+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192+loadTypesHelp root modul =
193+ case modul of
194+ Build.Fresh name iface _ ->
195+ newMVar (Just (Extract.fromInterface name iface))
196+
197+ Build.Cached name _ ciMVar ->
198+ do cachedInterface <- readMVar ciMVar
199+ case cachedInterface of
200+ Build.Unneeded ->
201+ do mvar <- newEmptyMVar
202+ _ <- forkIO $
203+ do maybeIface <- File.readBinary (Stuff.elmi root name)
204+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
205+ return mvar
206+
207+ Build.Loaded iface ->
208+ newMVar (Just (Extract.fromInterface name iface))
209+
210+ Build.Corrupted ->
211+ newMVar Nothing
builder/src/Http.hs+14−1
@@ -16,6 +16,7 @@ module Http
16 -- upload
16 -- upload
17 , upload
17 , upload
18 , filePart
18 , filePart
19+ , jsonPart
19 , stringPart
20 , stringPart
20 )
21 )
21 where
22 where
@@ -26,6 +27,7 @@ import qualified Codec.Archive.Zip as Zip
26import Control.Exception (SomeException, handle)
27import Control.Exception (SomeException, handle)
27import qualified Data.Binary as Binary
28import qualified Data.Binary as Binary
28import qualified Data.Binary.Get as Binary
29import qualified Data.Binary.Get as Binary
30+import qualified Data.ByteString.Builder as B
29import qualified Data.ByteString.Char8 as BS
31import qualified Data.ByteString.Char8 as BS
30import qualified Data.Digest.Pure.SHA as SHA
32import qualified Data.Digest.Pure.SHA as SHA
31import qualified Data.String as String
33import qualified Data.String as String
@@ -34,8 +36,10 @@ import Network.HTTP.Client
34import Network.HTTP.Client.TLS (tlsManagerSettings)
36import Network.HTTP.Client.TLS (tlsManagerSettings)
35import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
36import Network.HTTP.Types.Method (Method, methodGet, methodPost)
38import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39+import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
37import qualified Network.HTTP.Client.MultipartFormData as Multi
40import qualified Network.HTTP.Client.MultipartFormData as Multi
38
41
42+import qualified Json.Encode as Encode
39import qualified Elm.Version as V
43import qualified Elm.Version as V
40
44
41
45
@@ -226,6 +230,15 @@ filePart name filePath =
226 Multi.partFileSource (String.fromString name) filePath
230 Multi.partFileSource (String.fromString name) filePath
227
231
228
232
233+jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
234+jsonPart name filePath value =
235+ let
236+ body =
237+ Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
238+ in
239+ Multi.partFileRequestBody (String.fromString name) filePath body
240+
241+
229stringPart :: String -> String -> Multi.Part
242stringPart :: String -> String -> Multi.Part
230stringPart name string =
243stringPart name string =
231− Multi.partBS (String.fromString name) (BS.pack string)
244+ Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hs+43−22
@@ -1,6 +1,7 @@
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2module Reporting
2module Reporting
3 ( Style
3 ( Style
4+ , silent
4 , json
5 , json
5 , terminal
6 , terminal
6 --
7 --
@@ -32,7 +33,7 @@ import qualified Data.ByteString.Builder as B
32import qualified Data.NonEmptyList as NE
33import qualified Data.NonEmptyList as NE
33import qualified System.Exit as Exit
34import qualified System.Exit as Exit
34import qualified System.Info as Info
35import qualified System.Info as Info
35−import System.IO (hFlush, hPutStr, stderr, stdout)
36+import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
36
37
37import qualified Elm.ModuleName as ModuleName
38import qualified Elm.ModuleName as ModuleName
38import qualified Elm.Package as Pkg
39import qualified Elm.Package as Pkg
@@ -49,10 +50,16 @@ import qualified Reporting.Exit.Help as Help
49
50
50
51
51data Style
52data Style
53+ = Silent
52− = Json
54+ | Json
53 | Terminal (MVar ())
55 | Terminal (MVar ())
54
56
55
57
58+silent :: Style
59+silent =
60+ Silent
61+
62+
56json :: Style
63json :: Style
57json =
64json =
58 Json
65 Json
@@ -71,7 +78,9 @@ attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
71attempt toReport work =
78attempt toReport work =
72 do result <- work `catch` reportExceptionsNicely
79 do result <- work `catch` reportExceptionsNicely
73 case result of
80 case result of
81+ Right a ->
74− Right a -> return a
82+ return a
83+
75 Left x ->
84 Left x ->
76 do Exit.toStderr (toReport x)
85 do Exit.toStderr (toReport x)
77 Exit.exitFailure
86 Exit.exitFailure
@@ -81,9 +90,14 @@ attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
81attemptWithStyle style toReport work =
90attemptWithStyle style toReport work =
82 do result <- work `catch` reportExceptionsNicely
91 do result <- work `catch` reportExceptionsNicely
83 case result of
92 case result of
93+ Right a ->
84− Right a -> return a
94+ return a
95+
85 Left x ->
96 Left x ->
86 case style of
97 case style of
98+ Silent ->
99+ do Exit.exitFailure
100+
87 Json ->
101 Json ->
88 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
102 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
89 Exit.exitFailure
103 Exit.exitFailure
@@ -108,11 +122,6 @@ badMark =
108 D.red $ if isWindows then "X" else "✗"
122 D.red $ if isWindows then "X" else "✗"
109
123
110
124
111−_waitingMark :: D.Doc
112−_waitingMark =
113− D.dullyellow $ if isWindows then "-" else "→"
114−
115−
116isWindows :: Bool
125isWindows :: Bool
117isWindows =
126isWindows =
118 Info.os == "mingw32"
127 Info.os == "mingw32"
@@ -168,6 +177,9 @@ type DKey = Key DMsg
168trackDetails :: Style -> (DKey -> IO a) -> IO a
177trackDetails :: Style -> (DKey -> IO a) -> IO a
169trackDetails style callback =
178trackDetails style callback =
170 case style of
179 case style of
180+ Silent ->
181+ callback (Key (\_ -> return ()))
182+
171 Json ->
183 Json ->
172 callback (Key (\_ -> return ()))
184 callback (Key (\_ -> return ()))
173
185
@@ -252,8 +264,8 @@ putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
252putDownload mark pkg vsn =
264putDownload mark pkg vsn =
253 Help.toStdout $ D.indent 2 $
265 Help.toStdout $ D.indent 2 $
254 mark
266 mark
255− <+> D.fromUtf8 (Pkg.toString pkg)
267+ <+> D.fromPackage pkg
256− <+> D.fromUtf8 (V.toString vsn)
268+ <+> D.fromVersion vsn
257 <> "\n"
269 <> "\n"
258
270
259
271
@@ -297,6 +309,9 @@ type BResult a = Either Exit.BuildProblem a
297trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
309trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
298trackBuild style callback =
310trackBuild style callback =
299 case style of
311 case style of
312+ Silent ->
313+ callback (Key (\_ -> return ()))
314+
300 Json ->
315 Json ->
301 callback (Key (\_ -> return ()))
316 callback (Key (\_ -> return ()))
302
317
@@ -349,10 +364,10 @@ toFinalMessage done result =
349
364
350 Left problem ->
365 Left problem ->
351 case problem of
366 case problem of
352− Exit.BuildModuleProblems _ [] ->
367+ Exit.BuildBadModules _ _ [] ->
353 "Detected problems in 1 module."
368 "Detected problems in 1 module."
354
369
355− Exit.BuildModuleProblems _ (_:ps) ->
370+ Exit.BuildBadModules _ _ (_:ps) ->
356 "Detected problems in " ++ show (2 + length ps) ++ " modules."
371 "Detected problems in " ++ show (2 + length ps) ++ " modules."
357
372
358 Exit.BuildProjectProblem _ ->
373 Exit.BuildProjectProblem _ ->
@@ -366,6 +381,9 @@ toFinalMessage done result =
366reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
381reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
367reportGenerate style names output =
382reportGenerate style names output =
368 case style of
383 case style of
384+ Silent ->
385+ return ()
386+
369 Json ->
387 Json ->
370 return ()
388 return ()
371
389
@@ -428,20 +446,23 @@ reportExceptionsNicely e =
428
446
429
447
430putException :: SomeException -> IO ()
448putException :: SomeException -> IO ()
431−putException e =
449+putException e = do
450+ hPutStrLn stderr ""
432 Help.toStderr $ D.stack $
451 Help.toStderr $ D.stack $
452+ [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
433− [ D.reflow $
453+ , D.reflow $
434− "Oh no! I ran into something that bypassed the normal error reporting process!\
454+ "I ran into something that bypassed the normal error reporting process!\
435 \ I extracted whatever information I could from the internal error:"
455 \ I extracted whatever information I could from the internal error:"
436 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
456 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
437 , D.reflow $
457 , D.reflow $
438− "These errors are usually pretty confusing, so start by asking around on Slack\
458+ "These errors are usually pretty confusing, so start by asking around on one of\
459+ \ forums listed at https://elm-lang.org/community to see if anyone can get you\
439− \ or Discourse to see if anyone can get you unstuck quickly."
460+ \ unstuck quickly."
440− , "------------------------------------------------------------"
461+ , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"
441 , D.reflow $
462 , D.reflow $
442− "From there, if you are feeling up to it, please try to get your code down to the\
463+ "If you are feeling up to it, please try to get your code down to the smallest\
443− \ smallest version that still triggers this message. Ideally in a single Main.elm\
464+ \ version that still triggers this message. Ideally in a single Main.elm and\
444− \ and elm.json file."
465+ \ elm.json file."
445 , D.reflow $
466 , D.reflow $
446 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
467 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
447 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
468 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
builder/src/Reporting/Exit.hs+1628−387
@@ -1,31 +1,27 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Exit
2module Reporting.Exit
3− ( Exit(..)
4− --
5− , Init(..)
6− , initToReport
3+ ( Init(..), initToReport
7− --
8− , Diff(..)
9− , diffToReport
4+ , Diff(..), diffToReport
10− --
5+ , Make(..), makeToReport
11− , Install(..)
6+ , Bump(..), bumpToReport
7+ , Repl(..), replToReport
8+ , Publish(..), publishToReport
12− , installToReport
9+ , Install(..), installToReport
10+ , Reactor(..), reactorToReport
11+ , newPackageOverview
13 --
12 --
14 , Solver(..)
13 , Solver(..)
15− --
16 , Outline(..)
14 , Outline(..)
17 , OutlineProblem(..)
15 , OutlineProblem(..)
18− --
19 , Details(..)
16 , Details(..)
20− , RegistryProblem(..)
17+ , DetailsBadDep(..)
21 , PackageProblem(..)
18 , PackageProblem(..)
22− --
19+ , RegistryProblem(..)
23− , Make(..)
24 , BuildProblem(..)
20 , BuildProblem(..)
25 , BuildProjectProblem(..)
21 , BuildProjectProblem(..)
26− , makeToReport
27− --
28 , DocsProblem(..)
22 , DocsProblem(..)
23+ , Generate(..)
24+ --
29 , toString
25 , toString
30 , toStderr
26 , toStderr
31 , toJson
27 , toJson
@@ -33,61 +29,56 @@ module Reporting.Exit
33 where
29 where
34
30
35
31
32+import qualified Data.ByteString as BS
33+import qualified Data.ByteString.UTF8 as BS_UTF8
36import qualified Data.List as List
34import 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
37import qualified Data.NonEmptyList as NE
38−import qualified Data.Utf8 as Utf8
38+import qualified Network.HTTP.Client as HTTP
39+import qualified Network.HTTP.Types.Header as HTTP
40+import qualified Network.HTTP.Types.Status as HTTP
41+import qualified System.FilePath as FP
42+import System.FilePath ((</>), (<.>))
39
43
40import qualified Elm.Constraint as C
44import qualified Elm.Constraint as C
41import qualified Elm.Magnitude as M
45import qualified Elm.Magnitude as M
42import qualified Elm.ModuleName as ModuleName
46import qualified Elm.ModuleName as ModuleName
43import qualified Elm.Package as Pkg
47import qualified Elm.Package as Pkg
44import qualified Elm.Version as V
48import qualified Elm.Version as V
49+import qualified File
45import qualified Http
50import qualified Http
51+import qualified Json.Decode as Decode
46import qualified Json.Encode as Encode
52import qualified Json.Encode as Encode
53+import qualified Json.String as Json
54+import Parse.Primitives (Row, Col)
55+import qualified Reporting.Annotation as A
47import Reporting.Doc ((<>))
56import Reporting.Doc ((<>))
48import qualified Reporting.Doc as D
57import qualified Reporting.Doc as D
49import qualified Reporting.Error.Import as Import
58import qualified Reporting.Error.Import as Import
50import qualified Reporting.Error.Json as Json
59import qualified Reporting.Error.Json as Json
51import qualified Reporting.Exit.Help as Help
60import qualified Reporting.Exit.Help as Help
52import qualified Reporting.Error as Error
61import qualified Reporting.Error as Error
62+import qualified Reporting.Render.Code as Code
53
63
54
64
55
65
56−-- ALL POSSIBLE ERRORS
66+-- RENDERERS
57
67
58
68
59−data Exit
69+toString :: Help.Report -> String
60− -- bump
70+toString report =
61− = BumpApplication
71+ Help.toString (Help.reportToDoc report)
62− | BumpUnexpectedVersion V.Version [V.Version]
63− | BumpMustHaveLatestRegistry RegistryProblem
64− | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
65− -- publish
66− | PublishMustHaveLatestRegistry RegistryProblem
67− | PublishApplication
68− | PublishNotInitialVersion V.Version
69− | PublishAlreadyPublished V.Version
70− | PublishInvalidBump V.Version V.Version
71− | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
72− | PublishNoSummary
73− | PublishNoExposed
74− | PublishNoReadme
75− | PublishShortReadme
76− | PublishNoLicense
77− | PublishCannotGetTag Http.Error
78− | PublishCannotGetZip Http.Error
79− | PublishCannotDecodeZip
80− | PublishCannotGetDocs DocsProblem
81− | PublishCannotRegister Http.Error
82− | PublishMissingTag V.Version
83− | PublishNoGit
84− | PublishLocalChanges V.Version
85
72
86
73
87−data DocsProblem
74+toStderr :: Help.Report -> IO ()
88− = DP_Http Http.Error
75+toStderr report =
89− | DP_Data
76+ Help.toStderr (Help.reportToDoc report)
90− | DP_Cache
77+
78+
79+toJson :: Help.Report -> Encode.Value
80+toJson report =
81+ Help.reportToJson report
91
82
92
83
93
84
@@ -118,13 +109,18 @@ initToReport exit =
118
109
119 InitNoOfflineSolution pkgs ->
110 InitNoOfflineSolution pkgs ->
120 Help.report "NO OFFLINE SOLUTION" Nothing
111 Help.report "NO OFFLINE SOLUTION" Nothing
121− (error "TODO InitNoOfflineSolution" pkgs)
112+ "I tried to create an elm.json with the following direct dependencies:"
122− (error "TODO InitNoOfflineSolution" pkgs)
113+ [ D.indent 4 $ D.vcat $
123− -- note about Russia IP addresses?
114+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
124− -- ask if they are on a plane or train
115+ , D.reflow $
116+ "I could not find compatible versions though, but that may be because I could not\
117+ \ connect to https://package.elm-lang.org to get the latest list of packages. Are\
118+ \ you able to connect to the internet? Please ask around one of the community\
119+ \ forums at https://elm-lang.org/community for help!"
120+ ]
125
121
126 InitSolverProblem solver ->
122 InitSolverProblem solver ->
127− error "TODO InitSolverProblem" solver
123+ toSolverReport solver
128
124
129 InitAlreadyExists ->
125 InitAlreadyExists ->
130 Help.report "EXISTING PROJECT" Nothing
126 Help.report "EXISTING PROJECT" Nothing
@@ -135,8 +131,9 @@ initToReport exit =
135 ]
131 ]
136 ]
132 ]
137
133
138− InitRegistryProblem _ ->
134+ InitRegistryProblem problem ->
139− error "TODO InitRegistryProblem"
135+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
136+ "I need the list of published packages before I can start initializing projects"
140
137
141
138
142
139
@@ -144,22 +141,48 @@ initToReport exit =
144
141
145
142
146data Diff
143data Diff
144+ = DiffNoOutline
145+ | DiffBadOutline Outline
147− = DiffApplication
146+ | DiffApplication
147+ | DiffNoExposed
148 | DiffUnpublished
148 | DiffUnpublished
149 | DiffUnknownPackage Pkg.Name [Pkg.Name]
149 | DiffUnknownPackage Pkg.Name [Pkg.Name]
150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
151− | DiffCannotFindDocs DocsProblem
151+ | DiffDocsProblem V.Version DocsProblem
152 | DiffMustHaveLatestRegistry RegistryProblem
152 | DiffMustHaveLatestRegistry RegistryProblem
153+ | DiffBadDetails Details
154+ | DiffBadBuild BuildProblem
153
155
154
156
155diffToReport :: Diff -> Help.Report
157diffToReport :: Diff -> Help.Report
156diffToReport diff =
158diffToReport diff =
157 case diff of
159 case diff of
160+ DiffNoOutline ->
161+ Help.report "DIFF WHAT?" Nothing
162+ "I cannot find an elm.json so I am not sure what you want me to diff.\
163+ \ Normally you run `elm diff` from within a project!"
164+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"
165+ , D.indent 4 $ D.green $ "elm diff elm/http 1.0.0 2.0.0"
166+ ]
167+
168+ DiffBadOutline outline ->
169+ toOutlineReport outline
170+
158 DiffApplication ->
171 DiffApplication ->
159− Help.report "CANNOT DIFF APPLICATIONS" Nothing
172+ Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
160− "I cannot perform diffs on applications, only packages! If you are\
173+ "Your elm.json says this project is an application, but `elm diff` only works\
174+ \ with packages. That way there are previously published versions of the API to\
175+ \ diff against!"
161− \ just curious to see a diff, try running this command:"
176+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"
162− [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"
177+ , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"
178+ ]
179+
180+ DiffNoExposed ->
181+ Help.report "NO EXPOSED MODULES" (Just "elm.json")
182+ "Your elm.json has no \"exposed-modules\" which means there is no public API at\
183+ \ all right now! What am I supposed to diff?"
184+ [ D.reflow $
185+ "Try adding some modules back to the \"exposed-modules\" field."
163 ]
186 ]
164
187
165 DiffUnpublished ->
188 DiffUnpublished ->
@@ -171,16 +194,16 @@ diffToReport diff =
171 Help.report "UNKNOWN PACKAGE" Nothing
194 Help.report "UNKNOWN PACKAGE" Nothing
172 ( "I cannot find a package called:"
195 ( "I cannot find a package called:"
173 )
196 )
174− [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg
197+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
175 , "Maybe you want one of these instead?"
198 , "Maybe you want one of these instead?"
176− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
199+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
177 , "But check <https://package.elm-lang.org> to see all possibilities!"
200 , "But check <https://package.elm-lang.org> to see all possibilities!"
178 ]
201 ]
179
202
180 DiffUnknownVersion _pkg vsn realVersions ->
203 DiffUnknownVersion _pkg vsn realVersions ->
181 Help.docReport "UNKNOWN VERSION" Nothing
204 Help.docReport "UNKNOWN VERSION" Nothing
182 ( D.fillSep $
205 ( D.fillSep $
183− [ "Version", D.red (D.fromUtf8 (V.toString vsn))
206+ [ "Version", D.red (D.fromVersion vsn)
184 , "has", "never", "been", "published,", "so", "I"
207 , "has", "never", "been", "published,", "so", "I"
185 , "cannot", "diff", "against", "it."
208 , "cannot", "diff", "against", "it."
186 ]
209 ]
@@ -189,232 +212,57 @@ diffToReport diff =
189 , D.indent 4 $ D.dullyellow $ D.vcat $
212 , D.indent 4 $ D.dullyellow $ D.vcat $
190 let
213 let
191 sameMajor v1 v2 = V._major v1 == V._major v2
214 sameMajor v1 v2 = V._major v1 == V._major v2
192− mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns
215+ mkRow vsns = D.hsep $ map D.fromVersion vsns
193 in
216 in
194 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
217 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
195 , "Want one of those instead?"
218 , "Want one of those instead?"
196 ]
219 ]
197
220
198− DiffCannotFindDocs problem ->
221+ DiffDocsProblem version problem ->
199− error "TODO DiffCannotFindDocs" problem
222+ toDocsProblemReport problem $
223+ "I need the docs for " ++ V.toChars version ++ " to compute this diff"
200
224
201 DiffMustHaveLatestRegistry problem ->
225 DiffMustHaveLatestRegistry problem ->
202− error "TODO DiffMustHaveLatestRegistry" problem
226+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
227+ "I need the latest list of published packages before I do this diff"
203
228
229+ DiffBadDetails details ->
230+ toDetailsReport details
204
231
232+ DiffBadBuild buildProblem ->
233+ toBuildProblemReport buildProblem
205
234
206−-- INSTALL
207
235
208
236
209−data Install
237+-- BUMP
210− = InstallNoProject
211− | InstallNoArgs FilePath
212− | InstallNoOnlineSolution
213− | InstallNoOfflineSolution
214− | InstallHadSolverTrouble Solver
215− | InstallUnknownPackageOnline [Pkg.Name]
216− | InstallUnknownPackageOffline [Pkg.Name]
217− | InstallHasBadDetails Details
218
238
219
239
220−installToReport :: Install -> Help.Report
240+data Bump
221−installToReport exit =
241+ = BumpNoOutline
222− case exit of
242+ | BumpBadOutline Outline
223− InstallNoProject ->
243+ | BumpApplication
224− Help.report "NEW PROJECT?" Nothing
244+ | BumpUnexpectedVersion V.Version [V.Version]
225− "Are you trying to start a new project? Try this command instead:"
245+ | BumpMustHaveLatestRegistry RegistryProblem
226− [ D.indent 4 $ D.green "elm init"
246+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
227− , D.reflow "It will help you get started!"
247+ | BumpBadDetails Details
228− ]
248+ | BumpNoExposed
249+ | BumpBadBuild BuildProblem
229
250
230− InstallNoArgs elmHome ->
231− Help.report "INSTALL WHAT?" Nothing
232− "I am expecting commands like:"
233− [ D.green $ D.indent 4 $ D.vcat $
234− [ "elm install elm/http"
235− , "elm install elm/json"
236− , "elm install elm/random"
237− ]
238− , D.toFancyHint
239− ["In","JavaScript","folks","run","`npm install`","to","start","projects."
240− ,"\"Gotta","download","everything!\"","But","why","download","packages"
241− ,"again","and","again?","Instead,","Elm","caches","packages","in"
242− ,D.dullyellow (D.fromChars elmHome)
243− ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
244− ,"Elm","projects","check","that","cache","before","trying","the","internet."
245− ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
246− ,"easier","to","work","offline.","As","a","result"
247− ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
248− ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
249− ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
250− ]
251− ]
252
251
253− InstallNoOnlineSolution ->
252+bumpToReport :: Bump -> Help.Report
254− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO recommend using solver in `elm reactor`
253+bumpToReport bump =
255− "This usually happens if you try to modify dependency constraints by\
254+ case bump of
256− \ hand. I recommend deleting any dependency you added recently (or all\
255+ BumpNoOutline ->
257− \ of them if things are bad) and then adding them again with:"
256+ Help.report "BUMP WHAT?" Nothing
258− [ D.indent 4 $ D.green "elm install"
257+ "I cannot find an elm.json so I am not sure what you want me to bump."
259− , D.reflow $
258+ [ D.reflow $
260− "And do not be afaid to ask for help on Slack if you get stuck!"
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."
261 ]
262 ]
262
263
263− InstallNoOfflineSolution ->
264+ BumpBadOutline outline ->
264− error "TODO InstallNoOfflineSolution"
265+ toOutlineReport outline
265−
266− InstallHadSolverTrouble solver ->
267− error "TODO InstallHadSolverTrouble" solver
268−
269− InstallUnknownPackageOnline suggestions ->
270− error "TODO InstallUnknownPackageOnline" suggestions
271−
272− InstallUnknownPackageOffline suggestions ->
273− error "TODO InstallUnknownPackageOffline" suggestions
274−
275− InstallHasBadDetails _ ->
276− error "TODO InstallHasBadDetails"
277−
278−
279−{- TODO detect if library has no 0.19.0 version. Maybe do this on website though?
280− Help.report "OLD DEPENDENCIES" (Just "elm.json")
281− ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
282− )
283− [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
284− , D.reflow $
285− "This may be because it is not upgraded yet. It may be because a\
286− \ better solution came along, so there was no need to upgrade it.\
287− \ Etc. Try asking around on Slack to learn more about the topic."
288− , D.toSimpleNote
289− "Whatever the case, please be kind to the relevant package authors! Having\
290− \ friendly interactions with users is great motivation, and conversely, getting\
291− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
292− \ authors are humans with families, friends, jobs, vacations, responsibilities,\
293− \ goals, etc. They face obstacles outside of their technical work you will never\
294− \ know about, so please assume the best and try to be patient and supportive!"
295− ]
296−-}
297−
298−
299−
300−-- SOLVER
301−
302−
303−data Solver
304− = SolverBadCacheData Pkg.Name V.Version
305− | SolverBadHttpData Pkg.Name V.Version
306− | SolverBadHttp Http.Error
307−
308−
309−
310−-- OUTLINE
311−
312−
313−data Outline
314− = OutlineHasBadStructure (Json.Error OutlineProblem)
315− | OutlineHasBadSrcDirs FilePath [FilePath]
316−
317−
318−data OutlineProblem
319− = OP_BadType Utf8.String
320− | OP_BadPkgName Pkg.BadName
321− | OP_BadVersion Utf8.String
322− | OP_BadConstraint C.Error
323− | OP_BadModuleName Utf8.String
324− | OP_BadModuleHeaderTooLong Utf8.String
325− | OP_BadDependencyName Utf8.String
326− | OP_BadLicense Utf8.String [Utf8.String]
327− | OP_BadSummaryTooLong
328− | OP_NoSrcDirs
329−
330−
331−
332−-- DETAILS
333−
334−
335−data Details
336− = DetailsCorrupt
337− | DetailsNoSolution
338− | DetailsNoOfflineSolution
339− | DetailsSolverProblem Solver
340− | DetailsBadElmInPkg C.Constraint
341− | DetailsBadElmInAppOutline V.Version
342− | DetailsHandEditedDependencies
343− | DetailsBadOutline Outline
344− | DetailsCannotGetRegistry RegistryProblem
345− | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem
346−
347−
348−data RegistryProblem
349− = RP_Http Http.Error
350− | RP_Data
351−
352−
353−data PackageProblem
354− = PP_BadEndpointRequest Http.Error
355− | PP_BadEndpointContent
356− | PP_BadArchiveRequest Http.Error
357− | PP_BadArchiveContent
358− | PP_BadArchiveHash String String
359−
360−
361−
362−-- MAKE
363−
364−
365−data Make
366− = MakeNeedsOutline
367− | MakeCannotOptimizeAndDebug
368− | MakeBlockedByDetailsProblem Details
369− | MakeAppNeedsFileNames
370− | MakePkgNeedsExposing
371− | MakeMultipleFilesIntoHtml
372− | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
373− | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
374− | MakeCannotBuild BuildProblem
375− | MakeCannotLoadArtifacts
376−
377−
378−data BuildProblem
379− = BuildModuleProblems Error.Module [Error.Module]
380− | BuildProjectProblem BuildProjectProblem
381−
382−
383−data BuildProjectProblem
384− = BP_PathUnknown FilePath
385− | BP_WithBadExtension FilePath
386− | BP_WithAmbiguousSrcDir FilePath FilePath
387− | BP_MainPathDuplicate FilePath FilePath
388− | BP_MainNameDuplicate ModuleName.Raw FilePath FilePath
389− | BP_CannotLoadDependencies
390− | BP_Cycle ModuleName.Raw [ModuleName.Raw]
391− | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
392−
393−
394−
395−-- RENDERERS
396−
397−
398−toString :: Help.Report -> String
399−toString report =
400− Help.toString (Help.reportToDoc report)
401−
402−
403−toStderr :: Help.Report -> IO ()
404−toStderr report =
405− Help.toStderr (Help.reportToDoc report)
406−
407−
408−toJson :: Help.Report -> Encode.Value
409−toJson report =
410− Help.reportToJson report
411−
412−
413−_toReport :: Exit -> Help.Report
414−_toReport exit =
415− case exit of
416−
417− -- bump
418
266
419 BumpApplication ->
267 BumpApplication ->
420 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
268 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
@@ -426,7 +274,7 @@ _toReport exit =
426 Help.docReport "CANNOT BUMP" (Just "elm.json")
274 Help.docReport "CANNOT BUMP" (Just "elm.json")
427 ( D.fillSep
275 ( D.fillSep
428 ["Your","elm.json","says","I","should","bump","relative","to","version"
276 ["Your","elm.json","says","I","should","bump","relative","to","version"
429− ,D.red (D.fromUtf8 (V.toString vsn)) <> ","
277+ ,D.red (D.fromVersion vsn) <> ","
430 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
278 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
431 ,"That","means","there","is","no","API","for","me","to","diff","against","and"
279 ,"That","means","there","is","no","API","for","me","to","diff","against","and"
432 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
280 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
@@ -435,19 +283,116 @@ _toReport exit =
435 [ D.fillSep $
283 [ D.fillSep $
436 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
284 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
437 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
285 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
438− , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions
286+ , D.vcat $ map (D.green . D.fromVersion) versions
439 ]
287 ]
440
288
441 BumpMustHaveLatestRegistry problem ->
289 BumpMustHaveLatestRegistry problem ->
442− error "TODO BumpMustHaveLatestRegistry" problem
290+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
291+ "I need the latest list of published packages before I can bump any versions"
292+
293+ BumpCannotFindDocs _ version problem ->
294+ toDocsProblemReport problem $
295+ "I need the docs for " ++ V.toChars version ++ " to compute the next version number"
296+
297+ BumpBadDetails details ->
298+ toDetailsReport details
299+
300+ BumpNoExposed ->
301+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
302+ ( D.fillSep $
303+ [ "To", "bump", "a", "package,", "the"
304+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
305+ , "elm.json", "must", "list", "at", "least", "one", "module."
306+ ]
307+ )
308+ [ D.reflow $
309+ "Try adding some modules back to the \"exposed-modules\" field."
310+ ]
311+
312+ BumpBadBuild problem ->
313+ toBuildProblemReport problem
314+
315+
316+
317+-- OVERVIEW OF VERSIONING
318+
319+
320+newPackageOverview :: String
321+newPackageOverview =
322+ unlines
323+ [ "This package has never been published before. Here's how things work:"
324+ , ""
325+ , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
326+ , ""
327+ , " - All packages start with initial version " ++ V.toChars V.one
328+ , ""
329+ , " - Versions are incremented based on how the API changes:"
330+ , ""
331+ , " PATCH = the API is the same, no risk of breaking code"
332+ , " MINOR = values have been added, existing values are unchanged"
333+ , " MAJOR = existing values have been changed or removed"
334+ , ""
335+ , " - I will bump versions for you, automatically enforcing these rules"
336+ , ""
337+ ]
338+
339+
340+
341+-- PUBLISH
342+
343+
344+data Publish
345+ = PublishNoOutline
346+ | PublishBadOutline Outline
347+ | PublishBadDetails Details
348+ | PublishMustHaveLatestRegistry RegistryProblem
349+ | PublishApplication
350+ | PublishNotInitialVersion V.Version
351+ | PublishAlreadyPublished V.Version
352+ | PublishInvalidBump V.Version V.Version
353+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
354+ | PublishNoSummary
355+ | PublishNoExposed
356+ | PublishNoReadme
357+ | PublishShortReadme
358+ | PublishNoLicense
359+ | PublishBuildProblem BuildProblem
360+ | PublishMissingTag V.Version
361+ | PublishCannotGetTag V.Version Http.Error
362+ | PublishCannotGetTagData V.Version String BS.ByteString
363+ | PublishCannotGetZip Http.Error
364+ | PublishCannotDecodeZip String
365+ | PublishCannotGetDocs V.Version V.Version DocsProblem
366+ | PublishCannotRegister Http.Error
367+ | PublishNoGit
368+ | PublishLocalChanges V.Version
369+ --
370+ | PublishZipBadDetails Details
371+ | PublishZipApplication
372+ | PublishZipNoExposed
373+ | PublishZipBuildProblem BuildProblem
374+
375+
376+publishToReport :: Publish -> Help.Report
377+publishToReport publish =
378+ case publish of
379+ PublishNoOutline ->
380+ Help.report "PUBLISH WHAT?" Nothing
381+ "I cannot find an elm.json so I am not sure what you want me to publish."
382+ [ D.reflow $
383+ "Elm packages always have an elm.json that states the version number,\
384+ \ dependencies, exposed modules, etc."
385+ ]
443
386
444− BumpCannotFindDocs name version problem ->
387+ PublishBadOutline outline ->
445− error "TODO BumpCannotFindDocs" name version problem
388+ toOutlineReport outline
446
389
447− -- publish
390+ PublishBadDetails problem ->
391+ toDetailsReport problem
448
392
449 PublishMustHaveLatestRegistry problem ->
393 PublishMustHaveLatestRegistry problem ->
450− error "TODO PublishMustHaveLatestRegistry" problem
394+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
395+ "I need the latest list of published packages to make sure this is safe to publish"
451
396
452 PublishApplication ->
397 PublishApplication ->
453 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
398 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
@@ -456,7 +401,7 @@ _toReport exit =
456 Help.docReport "INVALID VERSION" Nothing
401 Help.docReport "INVALID VERSION" Nothing
457 ( D.fillSep
402 ( D.fillSep
458 ["I","cannot","publish"
403 ["I","cannot","publish"
459− ,D.red (D.fromUtf8 (V.toString vsn))
404+ ,D.red (D.fromVersion vsn)
460 ,"as","the","initial","version."
405 ,"as","the","initial","version."
461 ]
406 ]
462 )
407 )
@@ -470,7 +415,7 @@ _toReport exit =
470 Help.docReport "ALREADY PUBLISHED" Nothing
415 Help.docReport "ALREADY PUBLISHED" Nothing
471 ( D.vcat
416 ( D.vcat
472 [ D.fillSep
417 [ D.fillSep
473− [ "Version", D.green (D.fromUtf8 (V.toString vsn))
418+ [ "Version", D.green (D.fromVersion vsn)
474 , "has", "already", "been", "published.", "You", "cannot"
419 , "has", "already", "been", "published.", "You", "cannot"
475 , "publish", "it", "again!"
420 , "publish", "it", "again!"
476 ]
421 ]
@@ -487,14 +432,14 @@ _toReport exit =
487 Help.docReport "INVALID VERSION" (Just "elm.json")
432 Help.docReport "INVALID VERSION" (Just "elm.json")
488 ( D.fillSep $
433 ( D.fillSep $
489 ["Your","elm.json","says","the","next","version","should","be"
434 ["Your","elm.json","says","the","next","version","should","be"
490− ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","
435+ ,D.red (D.fromVersion statedVersion) <> ","
491 ,"but","that","is","not","valid","based","on","the","previously"
436 ,"but","that","is","not","valid","based","on","the","previously"
492 ,"published","versions."
437 ,"published","versions."
493 ]
438 ]
494 )
439 )
495 [ D.fillSep $
440 [ D.fillSep $
496 ["Change","the","version","back","to"
441 ["Change","the","version","back","to"
497− ,D.green (D.fromUtf8 (V.toString latestVersion))
442+ ,D.green (D.fromVersion latestVersion)
498 ,"which","is","the","most","recently","published","version."
443 ,"which","is","the","most","recently","published","version."
499 ,"From","there,","have","Elm","bump","the","version","by","running:"
444 ,"From","there,","have","Elm","bump","the","version","by","running:"
500 ]
445 ]
@@ -509,7 +454,7 @@ _toReport exit =
509 (
454 (
510 D.fillSep $
455 D.fillSep $
511 ["Your","elm.json","says","the","next","version","should","be"
456 ["Your","elm.json","says","the","next","version","should","be"
512− ,D.red (D.fromUtf8 (V.toString new)) <> ","
457+ ,D.red (D.fromVersion new) <> ","
513 ,"indicating","a",D.fromChars (M.toChars magnitude)
458 ,"indicating","a",D.fromChars (M.toChars magnitude)
514 ,"change","to","the","public","API."
459 ,"change","to","the","public","API."
515 ,"This","does","not","match","the","API","diff","given","by:"
460 ,"This","does","not","match","the","API","diff","given","by:"
@@ -522,7 +467,7 @@ _toReport exit =
522 ["This","command","says","this","is","a"
467 ["This","command","says","this","is","a"
523 ,D.fromChars (M.toChars realMagnitude)
468 ,D.fromChars (M.toChars realMagnitude)
524 ,"change,","so","the","next","version","should","be"
469 ,"change,","so","the","next","version","should","be"
525− ,D.green (D.fromUtf8 (V.toString realNew)) <> "."
470+ ,D.green (D.fromVersion realNew) <> "."
526 ,"Double","check","everything","to","make","sure","you"
471 ,"Double","check","everything","to","make","sure","you"
527 ,"are","publishing","what","you","want!"
472 ,"are","publishing","what","you","want!"
528 ]
473 ]
@@ -552,16 +497,17 @@ _toReport exit =
552 ]
497 ]
553 )
498 )
554 [ D.reflow $
499 [ D.reflow $
555− "What is the point of a package that has no modules?!"
500+ "Which modules do you want users of the package to have access to? Add their\
501+ \ names to the \"exposed-modules\" list."
556 ]
502 ]
557
503
558 PublishNoReadme ->
504 PublishNoReadme ->
559− badReadmeReport "NO README" $
505+ toBadReadmeReport "NO README" $
560 "Every published package must have a helpful README.md\
506 "Every published package must have a helpful README.md\
561 \ file, but I do not see one in your project."
507 \ file, but I do not see one in your project."
562
508
563 PublishShortReadme ->
509 PublishShortReadme ->
564− badReadmeReport "SHORT README" $
510+ toBadReadmeReport "SHORT README" $
565 "This README.md is too short. Having more details will help\
511 "This README.md is too short. Having more details will help\
566 \ people assess your package quickly and fairly."
512 \ people assess your package quickly and fairly."
567
513
@@ -578,20 +524,8 @@ _toReport exit =
578 \ named LICENSE. Add that file and you will be all set!"
524 \ named LICENSE. Add that file and you will be all set!"
579 ]
525 ]
580
526
581− PublishCannotGetTag httpError ->
527+ PublishBuildProblem buildProblem ->
582− error "TODO PublishCannotGetTag" httpError
528+ toBuildProblemReport buildProblem
583−
584− PublishCannotGetZip httpError ->
585− error "TODO PublishCannotGetZip" httpError
586−
587− PublishCannotDecodeZip ->
588− error "TODO PublishCannotDecodeZip"
589−
590− PublishCannotGetDocs docsProblem ->
591− error "TODO PublishCannotGetDocs" docsProblem
592−
593− PublishCannotRegister httpError ->
594− error "TODO PublishCannotRegister" httpError
595
529
596 PublishMissingTag version ->
530 PublishMissingTag version ->
597 let vsn = V.toChars version in
531 let vsn = V.toChars version in
@@ -612,18 +546,82 @@ _toReport exit =
612 , "The -m flag is for a helpful message. Try to make it more informative!"
546 , "The -m flag is for a helpful message. Try to make it more informative!"
613 ]
547 ]
614
548
549+ PublishCannotGetTag version httpError ->
550+ case httpError of
551+ Http.BadHttp _ (HTTP.StatusCodeException response _)
552+ | HTTP.statusCode (HTTP.responseStatus response) == 404 ->
553+ let vsn = V.toChars version in
554+ Help.report "NO TAG ON GITHUB" Nothing
555+ ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")
556+ [ D.reflow
557+ "Run the following command to make this tag available on GitHub:"
558+ , D.indent 4 $ D.dullyellow $ D.fromChars $
559+ "git push origin " ++ vsn
560+ , D.reflow
561+ "This will make it possible to find your code online based on the version number."
562+ ]
563+
564+ _ ->
565+ toHttpErrorReport "PROBLEM VERIFYING TAG" httpError
566+ "I need to check that the version tag is registered on GitHub"
567+
568+ PublishCannotGetTagData version url body ->
569+ Help.report "PROBLEM VERIFYING TAG" Nothing
570+ ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")
571+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
572+ , D.reflow $
573+ "I got the data back, but it was not what I was expecting. The response\
574+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
575+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
576+ , D.indent 4 $ D.dullyellow $ D.fromChars $
577+ if BS.length body <= 76
578+ then BS_UTF8.toString body
579+ else take 73 (BS_UTF8.toString body) ++ "..."
580+ , D.reflow $
581+ "Does this error keep showing up? Maybe there is something weird with your\
582+ \ internet connection. We have gotten reports that schools, businesses,\
583+ \ airports, etc. sometimes intercept requests and add things to the body\
584+ \ or change its contents entirely. Could that be the problem?"
585+ ]
586+
587+ PublishCannotGetZip httpError ->
588+ toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $
589+ "I need to check that folks can download and build the source code when they\
590+ \ install this package"
591+
592+ PublishCannotDecodeZip url ->
593+ Help.report "PROBLEM DOWNLOADING CODE" Nothing
594+ "I need to check that folks can download and build the source code when they\
595+ \ install this package, so I downloaded the code from:"
596+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
597+ , D.reflow $
598+ "I was unable to unzip the archive though. Maybe there is something weird with\
599+ \ your internet connection. We have gotten reports that schools, businesses,\
600+ \ airports, etc. sometimes intercept requests and add things to the body or\
601+ \ change its contents entirely. Could that be the problem?"
602+ ]
603+
604+ PublishCannotGetDocs old new docsProblem ->
605+ toDocsProblemReport docsProblem $
606+ "I need the docs for " ++ V.toChars old ++ " to verify that "
607+ ++ V.toChars new ++ " really does come next"
608+
609+ PublishCannotRegister httpError ->
610+ toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $
611+ "I need to send information about your package to the package website"
612+
615− PublishNoGit ->
613+ PublishNoGit ->
616− Help.report "NO GIT" Nothing
614+ Help.report "NO GIT" Nothing
617− "I searched your PATH environment variable for `git` and could not\
615+ "I searched your PATH environment variable for `git` and could not\
618− \ find it. Is it available through your PATH?"
616+ \ find it. Is it available through your PATH?"
619− [ D.reflow $
617+ [ D.reflow $
620− "Who cares about this? Well, I currently use `git` to check if there\
618+ "Who cares about this? Well, I currently use `git` to check if there\
621− \ are any local changes in your code. Local changes are a good sign\
619+ \ are any local changes in your code. Local changes are a good sign\
622− \ that some important improvements have gotten mistagged, so this\
620+ \ that some important improvements have gotten mistagged, so this\
623− \ check can be extremely helpful for package authors!"
621+ \ check can be extremely helpful for package authors!"
624− , D.toSimpleNote $
622+ , D.toSimpleNote $
625− "We plan to do this without the `git` binary in a future release."
623+ "We plan to do this without the `git` binary in a future release."
626− ]
624+ ]
627
625
628 PublishLocalChanges version ->
626 PublishLocalChanges version ->
629 let vsn = V.toChars version in
627 let vsn = V.toChars version in
@@ -641,9 +639,21 @@ _toReport exit =
641 ++ vsn ++ "` and publish your code from there."
639 ++ vsn ++ "` and publish your code from there."
642 ]
640 ]
643
641
642+ PublishZipBadDetails _ ->
643+ badZipReport
644+
645+ PublishZipApplication ->
646+ badZipReport
647+
648+ PublishZipNoExposed ->
649+ badZipReport
650+
651+ PublishZipBuildProblem _ ->
652+ badZipReport
644
653
654+
645−badReadmeReport :: String -> String -> Help.Report
655+toBadReadmeReport :: String -> String -> Help.Report
646−badReadmeReport title summary =
656+toBadReadmeReport title summary =
647 Help.report title (Just "README.md") summary
657 Help.report title (Just "README.md") summary
648 [ D.reflow $
658 [ D.reflow $
649 "When people look at your README, they are wondering:"
659 "When people look at your README, they are wondering:"
@@ -656,32 +666,653 @@ badReadmeReport title summary =
656 \ most common usage scenario. Show people what they can expect if\
666 \ most common usage scenario. Show people what they can expect if\
657 \ they learn more!"
667 \ they learn more!"
658 , D.toSimpleNote $
668 , D.toSimpleNote $
659− "By publishing your package, you are inviting people to invest time\
669+ "By publishing your package, you are inviting people to invest time in\
660− \ in understanding your work. Spending an hour to communicate your\
670+ \ understanding your work. Spending an hour on your README to communicate your\
661− \ knowledge more clearly can save the community days or weeks of time\
671+ \ knowledge more clearly can save the community days or weeks of time in\
662− \ in aggregate, and saving time in aggregate is the whole point of\
672+ \ aggregate, and saving time in aggregate is the whole point of publishing\
663− \ publishing packages! People really appreciate it, and it makes the\
673+ \ packages! People really appreciate it, and it makes the whole ecosystem feel\
664− \ whole ecosystem feel nicer!"
674+ \ nicer!"
665 ]
675 ]
666
676
667
677
678+badZipReport :: Help.Report
679+badZipReport =
680+ Help.report "PROBLEM VERIFYING PACKAGE" Nothing
681+ "Before publishing packages, I download the code from GitHub and try to build it\
682+ \ from scratch. That way I can be more confident that it will work for other\
683+ \ people too. But I am not able to build it!"
684+ [ D.reflow $
685+ "I was just able to build your local copy though. Is there some way the version\
686+ \ on GitHub could be different?"
687+ ]
688+
689+
690+
691+-- DOCS
692+
693+
694+data DocsProblem
695+ = DP_Http Http.Error
696+ | DP_Data String BS.ByteString
697+ | DP_Cache
698+
699+
700+toDocsProblemReport :: DocsProblem -> String -> Help.Report
701+toDocsProblemReport problem context =
702+ case problem of
703+ DP_Http httpError ->
704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705+
706+ DP_Data url body ->
707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
709+ , D.reflow $
710+ "I got the data back, but it was not what I was expecting. The response\
711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713+ , D.indent 4 $ D.dullyellow $ D.fromChars $
714+ if BS.length body <= 76
715+ then BS_UTF8.toString body
716+ else take 73 (BS_UTF8.toString body) ++ "..."
717+ , D.reflow $
718+ "Does this error keep showing up? Maybe there is something weird with your\
719+ \ internet connection. We have gotten reports that schools, businesses,\
720+ \ airports, etc. sometimes intercept requests and add things to the body\
721+ \ or change its contents entirely. Could that be the problem?"
722+ ]
723+
724+ DP_Cache ->
725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726+ [ D.reflow $
727+ "I deleted the cached version, so the next run should download a fresh copy of\
728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730+ \ for some reason."
731+ ]
732+
733+
734+
735+-- INSTALL
736+
737+
738+data Install
739+ = InstallNoOutline
740+ | InstallBadOutline Outline
741+ | InstallBadRegistry RegistryProblem
742+ | InstallNoArgs FilePath
743+ | InstallNoOnlineAppSolution Pkg.Name
744+ | InstallNoOfflineAppSolution Pkg.Name
745+ | InstallNoOnlinePkgSolution Pkg.Name
746+ | InstallNoOfflinePkgSolution Pkg.Name
747+ | InstallHadSolverTrouble Solver
748+ | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
749+ | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
750+ | InstallBadDetails Details
751+
752+
753+installToReport :: Install -> Help.Report
754+installToReport exit =
755+ case exit of
756+ InstallNoOutline ->
757+ Help.report "NEW PROJECT?" Nothing
758+ "Are you trying to start a new project? Try this command instead:"
759+ [ D.indent 4 $ D.green "elm init"
760+ , D.reflow "It will help you get started!"
761+ ]
762+
763+ InstallBadOutline outline ->
764+ toOutlineReport outline
765+
766+ InstallBadRegistry problem ->
767+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
768+ "I need the list of published packages to figure out how to install things"
769+
770+ InstallNoArgs elmHome ->
771+ Help.report "INSTALL WHAT?" Nothing
772+ "I am expecting commands like:"
773+ [ D.green $ D.indent 4 $ D.vcat $
774+ [ "elm install elm/http"
775+ , "elm install elm/json"
776+ , "elm install elm/random"
777+ ]
778+ , D.toFancyHint
779+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."
780+ ,"\"Gotta","download","everything!\"","But","why","download","packages"
781+ ,"again","and","again?","Instead,","Elm","caches","packages","in"
782+ ,D.dullyellow (D.fromChars elmHome)
783+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
784+ ,"Elm","projects","check","that","cache","before","trying","the","internet."
785+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
786+ ,"easier","to","work","offline.","As","a","result"
787+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
788+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
789+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
790+ ]
791+ ]
792+
793+ InstallNoOnlineAppSolution pkg ->
794+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
795+ (
796+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
797+ \ with your existing dependencies."
798+ )
799+ [ D.reflow $
800+ "I checked all the published versions. When that failed, I tried to find any\
801+ \ compatible combination of these packages, even if it meant changing all your\
802+ \ existing dependencies! That did not work either!"
803+ , D.reflow $
804+ "This is most likely to happen when a package is not upgraded yet. Maybe a new\
805+ \ version of Elm came out recently? Maybe a common package was changed recently?\
806+ \ Maybe a better package came along, so there was no need to upgrade this one?\
807+ \ Try asking around https://elm-lang.org/community to learn what might be going on\
808+ \ with this package."
809+ , D.toSimpleNote $
810+ "Whatever the case, please be kind to the relevant package authors! Having\
811+ \ friendly interactions with users is great motivation, and conversely, getting\
812+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
813+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
814+ \ goals, etc. They face obstacles outside of their technical work you will never\
815+ \ know about, so please assume the best and try to be patient and supportive!"
816+ ]
817+
818+ InstallNoOfflineAppSolution pkg ->
819+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
820+ (
821+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
822+ \ with your existing dependencies."
823+ )
824+ [ D.reflow $
825+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
826+ \ able to look through packages that you have downloaded in the past."
827+ , D.reflow $
828+ "Try again later when you have internet!"
829+ ]
830+
831+ InstallNoOnlinePkgSolution pkg ->
832+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
833+ (
834+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
835+ \ with your existing constraints."
836+ )
837+ [ D.reflow $
838+ "With applications, I try to broaden the constraints to see if anything works,\
839+ \ but messing with package constraints is much more delicate business. E.g. making\
840+ \ your constraints stricter may make it harder for applications to find compatible\
841+ \ dependencies. So fixing something here may break it for a lot of other people!"
842+ , D.reflow $
843+ "So I recommend making an application with the same dependencies as your package.\
844+ \ See if there is a solution at all. From there it may be easier to figure out\
845+ \ how to proceed in a way that will disrupt your users as little as possible. And\
846+ \ the solution may be to help other package authors to get their packages updated,\
847+ \ or to drop a dependency entirely."
848+ ]
849+
850+ InstallNoOfflinePkgSolution pkg ->
851+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
852+ (
853+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
854+ \ with your existing constraints."
855+ )
856+ [ D.reflow $
857+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
858+ \ able to look through packages that you have downloaded in the past."
859+ , D.reflow $
860+ "Try again later when you have internet!"
861+ ]
862+
863+ InstallHadSolverTrouble solver ->
864+ toSolverReport solver
865+
866+ InstallUnknownPackageOnline pkg suggestions ->
867+ Help.docReport "UNKNOWN PACKAGE" Nothing
868+ (
869+ D.fillSep
870+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
871+ )
872+ [ D.reflow $
873+ "I looked through https://package.elm-lang.org for packages with similar names\
874+ \ and found these:"
875+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
876+ , D.reflow $ "Maybe you want one of these instead?"
877+ ]
878+
879+ InstallUnknownPackageOffline pkg suggestions ->
880+ Help.docReport "UNKNOWN PACKAGE" Nothing
881+ (
882+ D.fillSep
883+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
884+ )
885+ [ D.reflow $
886+ "I could not connect to https://package.elm-lang.org though, so new packages may\
887+ \ have been published since I last updated my local cache of package names."
888+ , D.reflow $
889+ "Looking through the locally cached names, the closest ones are:"
890+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
891+ , D.reflow $ "Maybe you want one of these instead?"
892+ ]
893+
894+ InstallBadDetails details ->
895+ toDetailsReport details
896+
897+
898+
899+-- SOLVER
900+
901+
902+data Solver
903+ = SolverBadCacheData Pkg.Name V.Version
904+ | SolverBadHttpData Pkg.Name V.Version String
905+ | SolverBadHttp Pkg.Name V.Version Http.Error
906+
907+
908+toSolverReport :: Solver -> Help.Report
909+toSolverReport problem =
910+ case problem of
911+ SolverBadCacheData pkg vsn ->
912+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
913+ (
914+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
915+ \ help me search for a set of compatible packages. I had it cached locally, but\
916+ \ it looks like the file was corrupted!"
917+ )
918+ [ D.reflow $
919+ "I deleted the cached version, so the next run should download a fresh copy.\
920+ \ Hopefully that will get you unstuck, but it will not resolve the root\
921+ \ problem if a 3rd party tool is modifing cached files for some reason."
922+ ]
923+
924+ SolverBadHttpData pkg vsn url ->
925+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
926+ (
927+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
928+ \ help me search for a set of compatible packages, but I ran into corrupted\
929+ \ information from:"
930+ )
931+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
932+ , D.reflow $
933+ "Is something weird with your internet connection. We have gotten reports that\
934+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\
935+ \ to the body or change its contents entirely. Could that be the problem?"
936+ ]
937+
938+ SolverBadHttp pkg vsn httpError ->
939+ toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
940+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
941+ ++ " to help me search for a set of compatible packages"
942+
943+
944+
945+-- OUTLINE
946+
947+
948+data Outline
949+ = OutlineHasBadStructure (Decode.Error OutlineProblem)
950+ | OutlineHasMissingSrcDirs FilePath [FilePath]
951+ | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952+ | OutlineNoPkgCore
953+ | OutlineNoAppCore
954+ | OutlineNoAppJson
955+
956+
957+data OutlineProblem
958+ = OP_BadType
959+ | OP_BadPkgName Row Col
960+ | OP_BadVersion Row Col
961+ | OP_BadConstraint C.Error
962+ | OP_BadModuleName Row Col
963+ | OP_BadModuleHeaderTooLong
964+ | OP_BadDependencyName Row Col
965+ | OP_BadLicense Json.String [Json.String]
966+ | OP_BadSummaryTooLong
967+ | OP_NoSrcDirs
968+
969+
970+toOutlineReport :: Outline -> Help.Report
971+toOutlineReport problem =
972+ case problem of
973+ OutlineHasBadStructure decodeError ->
974+ Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
975+ Json.ExplicitReason "I ran into a problem with your elm.json file."
976+
977+ OutlineHasMissingSrcDirs dir dirs ->
978+ case dirs of
979+ [] ->
980+ Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
981+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
982+ [ D.indent 4 $ D.red $ D.fromChars dir
983+ , D.reflow $
984+ "I cannot find it though. Is it missing? Is there a typo?"
985+ ]
986+
987+ _:_ ->
988+ Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
989+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
990+ [ D.indent 4 $ D.vcat $
991+ map (D.red . D.fromChars) (dir:dirs)
992+ , D.reflow $
993+ "I cannot find them though. Are they missing? Are there typos?"
994+ ]
995+
996+ OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
997+ if dir1 == dir2 then
998+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
999+ "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
1000+ [ D.indent 4 $ D.vcat $
1001+ map (D.red . D.fromChars) [dir1,dir2]
1002+ , D.reflow $
1003+ "Remove one of the entries!"
1004+ ]
1005+ else
1006+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
1007+ "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
1008+ [ D.indent 4 $ D.vcat $
1009+ map (D.red . D.fromChars) [dir1,dir2]
1010+ , D.reflow $
1011+ "These are two different ways of refering to the same directory:"
1012+ , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
1013+ , D.reflow $
1014+ "Remove one of the redundant entries from your \"source-directories\" field."
1015+ ]
1016+
1017+ OutlineNoPkgCore ->
1018+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1019+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1020+ \ of `List` and `Maybe` do not work without it."
1021+ [ D.reflow $
1022+ "If you modified your elm.json by hand, try to change it back! And if you are\
1023+ \ having trouble getting back to a working elm.json, it may be easier to find a\
1024+ \ working package and start fresh with their elm.json file."
1025+ ]
1026+
1027+ OutlineNoAppCore ->
1028+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1029+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1030+ \ of `List` and `Maybe` do not work without it."
1031+ [ D.reflow $
1032+ "If you modified your elm.json by hand, try to change it back! And if you are\
1033+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1034+ \ and use `elm init` to start fresh."
1035+ ]
1036+
1037+ OutlineNoAppJson ->
1038+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1039+ "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
1040+ \ flags and ports."
1041+ [ D.reflow $
1042+ "If you modified your elm.json by hand, try to change it back! And if you are\
1043+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1044+ \ and use `elm init` to start fresh."
1045+ ]
1046+
1047+
1048+toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
1049+toOutlineProblemReport path source _ region problem =
1050+ let
1051+ toHighlight row col =
1052+ Just $ A.Region (A.Position row col) (A.Position row col)
1053+
1054+ toSnippet title highlight pair =
1055+ Help.jsonReport title (Just path) $
1056+ Code.toSnippet source region highlight pair
1057+ in
1058+ case problem of
1059+ OP_BadType ->
1060+ toSnippet "UNEXPECTED TYPE" Nothing
1061+ ( D.reflow $
1062+ "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
1063+ , D.fillSep
1064+ ["Try","changing","the","\"type\"","to"
1065+ ,D.green "\"application\"","or",D.green "\"package\"","instead."
1066+ ]
1067+ )
1068+
1069+ OP_BadPkgName row col ->
1070+ toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
1071+ ( D.reflow $
1072+ "I got stuck while reading your elm.json file. I ran into trouble with the package name:"
1073+ , D.stack
1074+ [ D.fillSep
1075+ ["Package","names","are","always","written","as"
1076+ ,D.green "\"author/project\""
1077+ ,"so","I","am","expecting","to","see","something","like:"
1078+ ]
1079+ , D.dullyellow $ D.indent 4 $ D.vcat $
1080+ [ "\"mdgriffith/elm-ui\""
1081+ , "\"w0rm/elm-physics\""
1082+ , "\"Microsoft/elm-json-tree-view\""
1083+ , "\"FordLabs/elm-star-rating\""
1084+ , "\"1602/json-schema\""
1085+ ]
1086+ , D.reflow
1087+ "The author name should match your GitHub name exactly, and the project name\
1088+ \ needs to follow these rules:"
1089+ , D.indent 4 $ D.vcat $
1090+ [ "+--------------------------------------+-----------+-----------+"
1091+ , "| RULE | BAD | GOOD |"
1092+ , "+--------------------------------------+-----------+-----------+"
1093+ , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
1094+ , "| no leading digits | 3D | elm-3d |"
1095+ , "| no non-ASCII characters | elm-bjørn | elm-bear |"
1096+ , "| no underscores | elm_ui | elm-ui |"
1097+ , "| no double hyphens | elm--hash | elm-hash |"
1098+ , "| no starting or ending hyphen | -elm-tar- | elm-tar |"
1099+ , "+--------------------------------------+-----------+-----------+"
1100+ ]
1101+ , D.toSimpleNote $
1102+ "These rules only apply to the project name, so you should never need\
1103+ \ to change your GitHub name!"
1104+ ]
1105+ )
1106+
1107+ OP_BadVersion row col ->
1108+ toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
1109+ ( D.reflow $
1110+ "I got stuck while reading your elm.json file. I was expecting a version number here:"
1111+ , D.fillSep
1112+ ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
1113+ ,"that","explicitly","states","all","three","numbers!"
1114+ ]
1115+ )
1116+
1117+ OP_BadConstraint constraintError ->
1118+ case constraintError of
1119+ C.BadFormat row col ->
1120+ toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
1121+ ( D.reflow $
1122+ "I got stuck while reading your elm.json file. I do not understand this version constraint:"
1123+ , D.stack
1124+ [ D.fillSep
1125+ ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
1126+ ,"that","explicitly","lists","the","lower","and","upper","bounds."
1127+ ]
1128+ , D.toSimpleNote $
1129+ "The spaces in there are required! Taking them out will confuse me. Adding\
1130+ \ extra spaces confuses me too. I recommend starting with a valid example\
1131+ \ and just changing the version numbers."
1132+ ]
1133+ )
1134+
1135+ C.InvalidRange before after ->
1136+ if before == after then
1137+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1138+ ( D.reflow $
1139+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1140+ , D.fillSep
1141+ ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
1142+ ,"so","it","is","best","to","use","wide","constraints.","I","recommend"
1143+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
1144+ ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
1145+ ,"happen","in","any","of","the","versions","in","that","range."
1146+ ]
1147+ )
1148+
1149+ else
1150+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1151+ ( D.reflow $
1152+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1153+ , D.fillSep
1154+ ["Maybe","you","want","something","like"
1155+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
1156+ ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
1157+ ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
1158+ ,"cannot","happen","in","any","of","the","versions","in","that","range."
1159+ ]
1160+ )
1161+
1162+ OP_BadModuleName row col ->
1163+ toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
1164+ ( D.reflow $
1165+ "I got stuck while reading your elm.json file. I was expecting a module name here:"
1166+ , D.fillSep
1167+ ["I","need","something","like",D.green "\"Html.Events\""
1168+ ,"or",D.green "\"Browser.Navigation\""
1169+ ,"where","each","segment","starts","with","a","capital"
1170+ ,"letter","and","the","segments","are","separated","by","dots."
1171+ ]
1172+ )
1173+
1174+ OP_BadModuleHeaderTooLong ->
1175+ toSnippet "HEADER TOO LONG" Nothing
1176+ ( D.reflow $
1177+ "I got stuck while reading your elm.json file. This section header is too long:"
1178+ , D.stack
1179+ [ D.fillSep
1180+ ["I","need","it","to","be"
1181+ ,D.green "under",D.green "20",D.green "bytes"
1182+ ,"so","it","renders","nicely","on","the","package","website!"
1183+ ]
1184+ , D.toSimpleNote
1185+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1186+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1187+ \ overly restrictive for your needs."
1188+ ]
1189+ )
1190+
1191+ OP_BadDependencyName row col ->
1192+ toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
1193+ ( D.reflow $
1194+ "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
1195+ , D.stack
1196+ [ D.fillSep
1197+ ["Package","names","always","include","the","name","of","the","author,"
1198+ ,"so","I","am","expecting","to","see","dependencies","like"
1199+ ,D.dullyellow "\"mdgriffith/elm-ui\"","and"
1200+ ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
1201+ ]
1202+ , D.fillSep $
1203+ ["I","generally","recommend","finding","the","package","you","want","on"
1204+ ,"the","package","website,","and","installing","it","with","the"
1205+ ,D.green "elm install","command!"
1206+ ]
1207+ ]
1208+ )
1209+
1210+ OP_BadLicense _ suggestions ->
1211+ toSnippet "UNKNOWN LICENSE" Nothing
1212+ ( D.reflow $
1213+ "I got stuck while reading your elm.json file. I do not know about this type of license:"
1214+ ,
1215+ D.stack
1216+ [ D.fillSep
1217+ ["Elm","packages","generally","use"
1218+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
1219+ ,"but","I","accept","any","OSI","approved","SPDX","license."
1220+ ,"Here","some","that","seem","close","to","what","you","wrote:"
1221+ ]
1222+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
1223+ , D.reflow $
1224+ "Check out https://spdx.org/licenses/ for the full list of options."
1225+ ]
1226+ )
1227+
1228+ OP_BadSummaryTooLong ->
1229+ toSnippet "SUMMARY TOO LONG" Nothing
1230+ ( D.reflow $
1231+ "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
1232+ , D.stack
1233+ [ D.fillSep
1234+ ["I","need","it","to","be"
1235+ ,D.green "under",D.green "80",D.green "bytes"
1236+ ,"so","it","renders","nicely","on","the","package","website!"
1237+ ]
1238+ , D.toSimpleNote
1239+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1240+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1241+ \ overly restrictive for your needs."
1242+ ]
1243+ )
1244+
1245+ OP_NoSrcDirs ->
1246+ toSnippet "NO SOURCE DIRECTORIES" Nothing
1247+ ( D.reflow $
1248+ "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
1249+ , D.fillSep
1250+ ["I","need","something","like",D.green "[\"src\"]"
1251+ ,"so","I","know","where","to","look","for","your","modules!"
1252+ ]
1253+ )
1254+
1255+
1256+
1257+-- DETAILS
1258+
1259+
1260+data Details
1261+ = DetailsNoSolution
1262+ | DetailsNoOfflineSolution
1263+ | DetailsSolverProblem Solver
1264+ | DetailsBadElmInPkg C.Constraint
1265+ | DetailsBadElmInAppOutline V.Version
1266+ | DetailsHandEditedDependencies
1267+ | DetailsBadOutline Outline
1268+ | DetailsCannotGetRegistry RegistryProblem
1269+ | DetailsBadDeps FilePath [DetailsBadDep]
1270+
668
1271
669−-- DETAILS TO REPORT
1272+data DetailsBadDep
1273+ = BD_BadDownload Pkg.Name V.Version PackageProblem
1274+ | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)
670
1275
671
1276
672−detailsToReport :: Details -> Help.Report
1277+toDetailsReport :: Details -> Help.Report
673−detailsToReport details =
1278+toDetailsReport details =
674 case details of
1279 case details of
675− DetailsCorrupt ->
1280+ DetailsNoSolution ->
676− error "TODO DetailsCorrupt"
1281+ Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json")
1282+ "The dependencies in your elm.json are not compatible."
1283+ [ D.fillSep
1284+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
1285+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1286+ ]
1287+ , D.reflow $
1288+ "Please ask for help on the community forums if you try those paths and are still\
1289+ \ having problems!"
1290+ ]
1291+
1292+ DetailsNoOfflineSolution ->
1293+ Help.report "TROUBLE VERIFYING DEPENDENCIES" (Just "elm.json")
1294+ "I could not connect to https://package.elm-lang.org to get the latest list of\
1295+ \ packages, and I was unable to verify your dependencies with the information I\
1296+ \ have cached locally."
1297+ [ D.reflow $
1298+ "Are you able to connect to the internet? These dependencies may work once you\
1299+ \ get access to the registry!"
1300+ , D.toFancyNote
1301+ ["If","you","changed","your","dependencies","by","hand,","try","to","change","them","back!"
1302+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1303+ ]
1304+ ]
1305+
1306+ DetailsSolverProblem solver ->
1307+ toSolverReport solver
677
1308
678 DetailsBadElmInPkg constraint ->
1309 DetailsBadElmInPkg constraint ->
679 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1310 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
680 "Your elm.json says this package needs a version of Elm in this range:"
1311 "Your elm.json says this package needs a version of Elm in this range:"
681− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ C.toString constraint
1312+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
682 , D.fillSep
1313 , D.fillSep
683 [ "But", "you", "are", "using", "Elm"
1314 [ "But", "you", "are", "using", "Elm"
684− , D.red (D.fromUtf8 (V.toString V.compiler))
1315+ , D.red (D.fromVersion V.compiler)
685 , "right", "now."
1316 , "right", "now."
686 ]
1317 ]
687 ]
1318 ]
@@ -691,40 +1322,286 @@ detailsToReport details =
691 "Your elm.json says this application needs a different version of Elm."
1322 "Your elm.json says this application needs a different version of Elm."
692 [ D.fillSep
1323 [ D.fillSep
693 [ "It", "requires"
1324 [ "It", "requires"
694− , D.green (D.fromUtf8 (V.toString version)) <> ","
1325+ , D.green (D.fromVersion version) <> ","
695 , "but", "you", "are", "using"
1326 , "but", "you", "are", "using"
696− , D.red (D.fromUtf8 (V.toString V.compiler))
1327+ , D.red (D.fromVersion V.compiler)
697 , "right", "now."
1328 , "right", "now."
698 ]
1329 ]
699 ]
1330 ]
700
1331
701 DetailsHandEditedDependencies ->
1332 DetailsHandEditedDependencies ->
702− error "TODO DetailsHandEditedDependencies"
1333+ Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
1334+ "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
1335+ \ party tool) leaving them in an invalid state."
1336+ [ D.fillSep
1337+ ["Try","to","change","them","back","to","what","they","were","before!"
1338+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1339+ ]
1340+ , D.reflow $
1341+ "Please ask for help on the community forums if you try those paths and are still\
1342+ \ having problems!"
1343+ ]
703
1344
704− DetailsBadOutline problem ->
1345+ DetailsBadOutline outline ->
705− error "TODO DetailsBadOutline" problem
1346+ toOutlineReport outline
706
1347
707 DetailsCannotGetRegistry problem ->
1348 DetailsCannotGetRegistry problem ->
708− error "TODO DetailsCannotGetRegistry" problem
1349+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
1350+ "I need the list of published packages to verify your dependencies"
1351+
1352+ DetailsBadDeps cacheDir deps ->
1353+ case List.sortOn toBadDepRank deps of
1354+ [] ->
1355+ Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1356+ "I am not sure what is going wrong though."
1357+ [ D.reflow $
1358+ "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
1359+ \ trying to build again. That will work if some cached files got corrupted\
1360+ \ somehow."
1361+ , D.reflow $
1362+ "If that does not work, go to https://elm-lang.org/community and ask for\
1363+ \ help. This is a weird case!"
1364+ ]
709
1365
710− DetailsCannotBuildPackage name version problem ->
1366+ d:_ ->
711− error "TODO DetailsCannotBuildPackage" name version problem
1367+ case d of
1368+ BD_BadDownload pkg vsn packageProblem ->
1369+ toPackageProblemReport pkg vsn packageProblem
712
1370
713− DetailsNoSolution ->
1371+ BD_BadBuild pkg vsn fingerprint ->
714− error "TODO DetailsNoSolution"
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+ ]
715
1391
716− DetailsNoOfflineSolution ->
717− error "TODO DetailsNoOfflineSolution"
718
1392
719− DetailsSolverProblem _ ->
1393+toBadDepRank :: DetailsBadDep -> Int -- lower is better
720− error "TODO DetailsSolverProblem"
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+ ]
721
1434
1435+ PP_BadArchiveRequest httpError ->
1436+ toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1437+ "I was trying to download the source code for " ++ thePackage
1438+
1439+ PP_BadArchiveContent url ->
1440+ Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1441+ (
1442+ "I downloaded the source code for " ++ thePackage ++ " from:"
1443+ )
1444+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1445+ , D.reflow $
1446+ "But I was unable to unzip the data. Maybe there is something weird with\
1447+ \ your internet connection. We have gotten reports that schools, businesses,\
1448+ \ airports, etc. sometimes intercept requests and add things to the body or\
1449+ \ change its contents entirely. Could that be the problem?"
1450+ ]
1451+
1452+ PP_BadArchiveHash url expectedHash actualHash ->
1453+ Help.report "CORRUPT PACKAGE DATA" Nothing
1454+ (
1455+ "I downloaded the source code for " ++ thePackage ++ " from:"
1456+ )
1457+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1458+ , D.reflow "But it looks like the hash of the archive has changed since publication:"
1459+ , D.vcat $ map D.fromChars $
1460+ [ " Expected: " ++ expectedHash
1461+ , " Actual: " ++ actualHash
1462+ ]
1463+ , D.reflow $
1464+ "This usually means that the package author moved the version\
1465+ \ tag, so report it to them and see if that is the issue. Folks\
1466+ \ on Elm slack can probably help as well."
1467+ ]
1468+
1469+
1470+
1471+-- REGISTRY PROBLEM
1472+
1473+
1474+data RegistryProblem
1475+ = RP_Http Http.Error
1476+ | RP_Data String BS.ByteString
1477+
1478+
1479+toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report
1480+toRegistryProblemReport title problem context =
1481+ case problem of
1482+ RP_Http err ->
1483+ toHttpErrorReport title err context
1484+
1485+ RP_Data url body ->
1486+ Help.report title Nothing (context ++ ", so I fetched:")
1487+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1488+ , D.reflow $
1489+ "I got the data back, but it was not what I was expecting. The response\
1490+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
1491+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
1492+ , D.indent 4 $ D.dullyellow $ D.fromChars $
1493+ if BS.length body <= 76
1494+ then BS_UTF8.toString body
1495+ else take 73 (BS_UTF8.toString body) ++ "..."
1496+ , D.reflow $
1497+ "Does this error keep showing up? Maybe there is something weird with your\
1498+ \ internet connection. We have gotten reports that schools, businesses,\
1499+ \ airports, etc. sometimes intercept requests and add things to the body\
1500+ \ or change its contents entirely. Could that be the problem?"
1501+ ]
1502+
1503+
1504+toHttpErrorReport :: String -> Http.Error -> String -> Help.Report
1505+toHttpErrorReport title err context =
1506+ let
1507+ toHttpReport intro url details =
1508+ Help.report title Nothing intro $
1509+ D.indent 4 (D.dullyellow (D.fromChars url)) : details
1510+ in
1511+ case err of
1512+ Http.BadUrl url reason ->
1513+ toHttpReport (context ++ ", so I wanted to fetch:") url
1514+ [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"
1515+ , D.indent 4 $ D.fromChars reason
1516+ , D.reflow $
1517+ "This may indicate that there is some problem in the compiler, so please open an\
1518+ \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\
1519+ \ version, the command you ran, the terminal output, and any additional information\
1520+ \ that might help others reproduce the error."
1521+ ]
1522+
1523+ Http.BadHttp url httpExceptionContent ->
1524+ case httpExceptionContent of
1525+ HTTP.StatusCodeException response body ->
1526+ let
1527+ (HTTP.Status code message) = HTTP.responseStatus response
1528+ in
1529+ toHttpReport (context ++ ", so I tried to fetch:") url
1530+ [ D.fillSep $
1531+ ["But","it","came","back","as",D.red (D.fromInt code)]
1532+ ++ map D.fromChars (words (BS_UTF8.toString message))
1533+ , D.indent 4 $ D.reflow $ BS_UTF8.toString body
1534+ , D.reflow $
1535+ "This may mean some online endpoint changed in an unexpected way, so if does not\
1536+ \ seem like something on your side is causing this (e.g. firewall) please report\
1537+ \ this to https://github.com/elm/compiler/issues with your operating system, Elm\
1538+ \ version, the command you ran, the terminal output, and any additional information\
1539+ \ that can help others reproduce the error!"
1540+ ]
1541+
1542+ HTTP.TooManyRedirects responses ->
1543+ toHttpReport (context ++ ", so I tried to fetch:") url
1544+ [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"
1545+ , D.indent 4 $ D.vcat $ map toRedirectDoc responses
1546+ , D.reflow $
1547+ "Is it possible that your internet connection intercepts certain requests? That\
1548+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1549+ \ and certain countries. Try asking for help locally or in a community forum!"
1550+ ]
1551+
1552+ otherException ->
1553+ toHttpReport (context ++ ", so I tried to fetch:") url
1554+ [ D.reflow $ "But my HTTP library is giving me the following error message:"
1555+ , D.indent 4 $ D.fromChars (show otherException)
1556+ , D.reflow $
1557+ "Are you somewhere with a slow internet connection? Or no internet?\
1558+ \ Does the link I am trying to fetch work in your browser? Maybe the\
1559+ \ site is down? Does your internet connection have a firewall that\
1560+ \ blocks certain domains? It is usually something like that!"
1561+ ]
1562+
1563+ Http.BadMystery url someException ->
1564+ toHttpReport (context ++ ", so I tried to fetch:") url
1565+ [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"
1566+ , D.indent 4 $ D.fromChars (show someException)
1567+ , D.reflow $
1568+ "Is it possible that your internet connection intercepts certain requests? That\
1569+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1570+ \ and certain countries. Try asking for help locally or in a community forum!"
1571+ ]
1572+
1573+
1574+toRedirectDoc :: HTTP.Response body -> D.Doc
1575+toRedirectDoc response =
1576+ let
1577+ (HTTP.Status code message) = HTTP.responseStatus response
1578+ in
1579+ case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of
1580+ Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)
1581+ Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)
1582+
1583+
1584+
1585+-- MAKE
1586+
1587+
1588+data Make
1589+ = MakeNoOutline
1590+ | MakeCannotOptimizeAndDebug
1591+ | MakeBadDetails Details
1592+ | MakeAppNeedsFileNames
1593+ | MakePkgNeedsExposing
1594+ | MakeMultipleFilesIntoHtml
1595+ | MakeNoMain
1596+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1597+ | MakeCannotBuild BuildProblem
1598+ | MakeBadGenerate Generate
722
1599
723
1600
724makeToReport :: Make -> Help.Report
1601makeToReport :: Make -> Help.Report
725makeToReport make =
1602makeToReport make =
726 case make of
1603 case make of
727− MakeNeedsOutline ->
1604+ MakeNoOutline ->
728 Help.report "NO elm.json FILE" Nothing
1605 Help.report "NO elm.json FILE" Nothing
729 "It looks like you are starting a new Elm project. Very exciting! Try running:"
1606 "It looks like you are starting a new Elm project. Very exciting! Try running:"
730 [ D.indent 4 $ D.green $ "elm init"
1607 [ D.indent 4 $ D.green $ "elm init"
@@ -745,27 +1622,344 @@ makeToReport make =
745 \ at once though! Pick just one of those flags and it should work!"
1622 \ at once though! Pick just one of those flags and it should work!"
746 ]
1623 ]
747
1624
748− MakeBlockedByDetailsProblem detailsProblem ->
1625+ MakeBadDetails detailsProblem ->
749− detailsToReport detailsProblem
1626+ toDetailsReport detailsProblem
750
1627
751 MakeAppNeedsFileNames ->
1628 MakeAppNeedsFileNames ->
752 Help.report "NO INPUT" Nothing
1629 Help.report "NO INPUT" Nothing
753− "What should I make though? I need a specific file like this:"
1630+ "What should I make though? I need specific files like:"
1631+ [ D.vcat
754− [ D.indent 4 $ D.green "elm make src/Main.elm"
1632+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1633+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1634+ ]
755− , D.reflow
1635+ , D.reflow $
756− "However many files you give, I will create one JS file out of them."
1636+ "I recommend reading through https://guide.elm-lang.org for guidance on what to\
1637+ \ actually put in those files!"
757 ]
1638 ]
758
1639
759 MakePkgNeedsExposing ->
1640 MakePkgNeedsExposing ->
760− error "TODO MakePkgNeedsExposing"
1641+ Help.report "NO INPUT" Nothing
1642+ "What should I make though? I need specific files like:"
1643+ [ D.vcat
1644+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1645+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1646+ ]
1647+ , D.reflow $
1648+ "You can also entries to the \"exposed-modules\" list in your elm.json file, and\
1649+ \ I will try to compile the relevant files."
1650+ ]
761
1651
762 MakeMultipleFilesIntoHtml ->
1652 MakeMultipleFilesIntoHtml ->
763− error "TODO MakeMultipleFilesIntoHtml"
1653+ Help.report "TOO MANY FILES" Nothing
1654+ (
1655+ "When producing an HTML file, I can only handle one file."
1656+ )
1657+ [ D.fillSep
1658+ ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"
1659+ ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"
1660+ ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."
1661+ ]
1662+ , D.fillSep
1663+ ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"
1664+ ,"`main`","values","available","in","a","single","JavaScript","file.","Then"
1665+ ,"you","can","make","your","own","customized","HTML","file","that","embeds"
1666+ ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"
1667+ ,"dependencies","between","modules,","so","it","should","be","smaller","than"
1668+ ,"compiling","each","module","separately."
1669+ ]
1670+ ]
1671+
1672+ MakeNoMain ->
1673+ Help.report "NO MAIN" Nothing
1674+ (
1675+ "When producing an HTML file, I require that the given file has a `main` value.\
1676+ \ That way I have something to show on screen!"
1677+ )
1678+ [ D.reflow $
1679+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1680+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1681+ \ altogether."
1682+ , D.toSimpleNote $
1683+ "Adding a `main` value can be as brief as adding something like this:"
1684+ , D.vcat
1685+ [ D.fillSep [D.cyan "import","Html"]
1686+ , ""
1687+ , D.fillSep [D.green "main","="]
1688+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1689+ ]
1690+ , D.reflow $
1691+ "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\
1692+ \ looking through https://guide.elm-lang.org for more guidance on how to fill in\
1693+ \ the `main` value."
1694+ ]
1695+
1696+ MakeNonMainFilesIntoJavaScript m ms ->
1697+ case ms of
1698+ [] ->
1699+ Help.report "NO MAIN" Nothing
1700+ (
1701+ "When producing a JS file, I require that the given file has a `main` value. That\
1702+ \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\
1703+ \ resulting file!"
1704+ )
1705+ [ D.reflow $
1706+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1707+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1708+ \ altogether."
1709+ , D.toSimpleNote $
1710+ "Adding a `main` value can be as brief as adding something like this:"
1711+ , D.vcat
1712+ [ D.fillSep [D.cyan "import","Html"]
1713+ , ""
1714+ , D.fillSep [D.green "main","="]
1715+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1716+ ]
1717+ , D.reflow $
1718+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1719+ \ make a `main` with no user interface."
1720+ ]
1721+
1722+ _:_ ->
1723+ Help.report "NO MAIN" Nothing
1724+ (
1725+ "When producing a JS file, I require that given files all have `main` values.\
1726+ \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\
1727+ \ definitely defined in the resulting file. I am missing `main` values in:"
1728+ )
1729+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)
1730+ , D.reflow $
1731+ "Try adding a `main` value to them? Or if you just want to verify that these\
1732+ \ modules compile, switch to --output=/dev/null to skip the code gen phase\
1733+ \ altogether."
1734+ , D.toSimpleNote $
1735+ "Adding a `main` value can be as brief as adding something like this:"
1736+ , D.vcat
1737+ [ D.fillSep [D.cyan "import","Html"]
1738+ , ""
1739+ , D.fillSep [D.green "main","="]
1740+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1741+ ]
1742+ , D.reflow $
1743+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1744+ \ make a `main` with no user interface."
1745+ ]
1746+
1747+ MakeCannotBuild buildProblem ->
1748+ toBuildProblemReport buildProblem
1749+
1750+ MakeBadGenerate generateProblem ->
1751+ toGenerateReport generateProblem
1752+
1753+
1754+
1755+-- BUILD PROBLEM
1756+
1757+
1758+data BuildProblem
1759+ = BuildBadModules FilePath Error.Module [Error.Module]
1760+ | BuildProjectProblem BuildProjectProblem
1761+
1762+
1763+data BuildProjectProblem
1764+ = BP_PathUnknown FilePath
1765+ | BP_WithBadExtension FilePath
1766+ | BP_WithAmbiguousSrcDir FilePath FilePath FilePath
1767+ | BP_MainPathDuplicate FilePath FilePath
1768+ | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath
1769+ | BP_RootNameInvalid FilePath FilePath [String]
1770+ | BP_CannotLoadDependencies
1771+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]
1772+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
1773+
1774+
1775+toBuildProblemReport :: BuildProblem -> Help.Report
1776+toBuildProblemReport problem =
1777+ case problem of
1778+ BuildBadModules root e es ->
1779+ Help.compilerReport root e es
1780+
1781+ BuildProjectProblem projectProblem ->
1782+ toProjectProblemReport projectProblem
1783+
1784+
1785+toProjectProblemReport :: BuildProjectProblem -> Help.Report
1786+toProjectProblemReport projectProblem =
1787+ case projectProblem of
1788+ BP_PathUnknown path ->
1789+ Help.report "FILE NOT FOUND" Nothing
1790+ "I cannot find this file:"
1791+ [ D.indent 4 $ D.red $ D.fromChars path
1792+ , D.reflow $ "Is there a typo?"
1793+ , D.toSimpleNote $
1794+ "If you are just getting started, try working through the examples in the\
1795+ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\
1796+ \ that typically go in a src/Main.elm file."
1797+ ]
1798+
1799+ BP_WithBadExtension path ->
1800+ Help.report "UNEXPECTED FILE EXTENSION" Nothing
1801+ "I can only compile Elm files (with a .elm extension) but you want me to compile:"
1802+ [ D.indent 4 $ D.red $ D.fromChars path
1803+ , D.reflow $ "Is there a typo? Can the file extension be changed?"
1804+ ]
1805+
1806+ BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->
1807+ Help.report "CONFUSING FILE" Nothing
1808+ "I am getting confused when I try to compile this file:"
1809+ [ D.indent 4 $ D.red $ D.fromChars path
1810+ , D.reflow $
1811+ "I always check if files appear in any of the \"source-directories\" listed in\
1812+ \ your elm.json to see if there might be some cached information about them. That\
1813+ \ can help me compile faster! But in this case, it looks like this file may be in\
1814+ \ either of these directories:"
1815+ , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]
1816+ , D.reflow $
1817+ "Try to make it so no source directory contains another source directory!"
1818+ ]
1819+
1820+ BP_MainPathDuplicate path1 path2 ->
1821+ Help.report "CONFUSING FILES" Nothing
1822+ "You are telling me to compile these two files:"
1823+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]
1824+ , D.reflow $
1825+ if path1 == path2 then
1826+ "Why are you telling me twice? Is something weird going on with a script?\
1827+ \ I figured I would let you know about it just in case something is wrong.\
1828+ \ Only list it once and you should be all set!"
1829+ else
1830+ "But seem to be the same file though... It makes me think something tricky is\
1831+ \ going on with symlinks in your project, so I figured I would let you know\
1832+ \ about it just in case. Remove one of these files from your command to get\
1833+ \ unstuck!"
1834+ ]
1835+
1836+ BP_RootNameDuplicate name outsidePath otherPath ->
1837+ Help.report "MODULE NAME CLASH" Nothing
1838+ "These two files are causing a module name clash:"
1839+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]
1840+ , D.reflow $
1841+ "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\
1842+ \ at the top, but they cannot have the same name!"
1843+ , D.reflow $
1844+ "Try changing to a different module name in one of them!"
1845+ ]
1846+
1847+ BP_RootNameInvalid givenPath srcDir _ ->
1848+ Help.report "UNEXPECTED FILE NAME" Nothing
1849+ "I am having trouble with this file name:"
1850+ [ D.indent 4 $ D.red $ D.fromChars givenPath
1851+ , D.reflow $
1852+ "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\
1853+ \ which is good, but I expect all of the files in there to use the following\
1854+ \ module naming convention:"
1855+ , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]
1856+ , D.reflow $
1857+ "Notice that the names always start with capital letters! Can you make your file\
1858+ \ use this naming convention?"
1859+ , D.toSimpleNote $
1860+ "Having a strict naming convention like this makes it a lot easier to find\
1861+ \ things in large projects. If you see a module imported, you know where to look\
1862+ \ for the corresponding file every time!"
1863+ ]
1864+
1865+ BP_CannotLoadDependencies ->
1866+ corruptCacheReport
1867+
1868+ BP_Cycle name names ->
1869+ Help.report "IMPORT CYCLE" Nothing
1870+ "Your module imports form a cycle:"
1871+ [ D.cycle 4 name names
1872+ , D.reflow $
1873+ "Learn more about why this is disallowed and how to break cycles here:"
1874+ ++ D.makeLink "import-cycles"
1875+ ]
1876+
1877+ BP_MissingExposed (NE.List (name, problem) _) ->
1878+ case problem of
1879+ Import.NotFound ->
1880+ Help.report "MISSING MODULE" (Just "elm.json")
1881+ "The \"exposed-modules\" of your elm.json lists the following module:"
1882+ [ D.indent 4 $ D.red $ D.fromName name
1883+ , D.reflow $
1884+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1885+ ]
1886+
1887+ Import.Ambiguous _ _ pkg _ ->
1888+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1889+ "The \"exposed-modules\" of your elm.json lists the following module:"
1890+ [ D.indent 4 $ D.red $ D.fromName name
1891+ , D.reflow $
1892+ "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\
1893+ \ choosing a different name for your local file."
1894+ ]
1895+
1896+ Import.AmbiguousLocal path1 path2 paths ->
1897+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1898+ "The \"exposed-modules\" of your elm.json lists the following module:"
1899+ [ D.indent 4 $ D.red $ D.fromName name
1900+ , D.reflow $
1901+ "But I found multiple files with that name:"
1902+ , D.dullyellow $ D.indent 4 $ D.vcat $
1903+ map D.fromChars (path1:path2:paths)
1904+ , D.reflow $
1905+ "Change the module names to be distinct!"
1906+ ]
1907+
1908+ Import.AmbiguousForeign _ _ _ ->
1909+ Help.report "MISSING MODULE" (Just "elm.json")
1910+ "The \"exposed-modules\" of your elm.json lists the following module:"
1911+ [ D.indent 4 $ D.red $ D.fromName name
1912+ , D.reflow $
1913+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1914+ , D.toSimpleNote $
1915+ "It is not possible to \"re-export\" modules from other packages. You can only\
1916+ \ expose modules that you define in your own code."
1917+ ]
1918+
1919+
1920+toModuleNameConventionTable :: FilePath -> [String] -> D.Doc
1921+toModuleNameConventionTable srcDir names =
1922+ let
1923+ toPair name =
1924+ ( name
1925+ , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"
1926+ )
1927+
1928+ namePairs = map toPair names
1929+ nameWidth = maximum (11 : map (length . fst) namePairs)
1930+ pathWidth = maximum ( 9 : map (length . snd) namePairs)
1931+
1932+ padded width str =
1933+ str ++ replicate (width - length str) ' '
1934+
1935+ toRow (name, path) =
1936+ D.fromChars $
1937+ "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"
1938+
1939+ bar =
1940+ D.fromChars $
1941+ "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"
1942+ in
1943+ D.indent 4 $ D.vcat $
1944+ [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]
1945+
1946+
1947+
1948+-- GENERATE
1949+
1950+
1951+data Generate
1952+ = GenerateCannotLoadArtifacts
1953+ | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
1954+
764
1955
765− MakeNonMainFilesIntoJavaScript _ _ ->
1956+toGenerateReport :: Generate -> Help.Report
766− error "TODO MakeNonMainFilesIntoJavaScript"
1957+toGenerateReport problem =
1958+ case problem of
1959+ GenerateCannotLoadArtifacts ->
1960+ corruptCacheReport
767
1961
768− MakeCannotOptimizeDebugValues m ms ->
1962+ GenerateCannotOptimizeDebugValues m ms ->
769 Help.report "DEBUG REMNANTS" Nothing
1963 Help.report "DEBUG REMNANTS" Nothing
770 "There are uses of the `Debug` module in the following modules:"
1964 "There are uses of the `Debug` module in the following modules:"
771 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
1965 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
@@ -774,7 +1968,7 @@ makeToReport make =
774 "The issue is that --optimize strips out info needed by `Debug` functions.\
1968 "The issue is that --optimize strips out info needed by `Debug` functions.\
775 \ Here are two examples:"
1969 \ Here are two examples:"
776 , D.indent 4 $ D.reflow $
1970 , D.indent 4 $ D.reflow $
777− "(1) It shortens record field names. This makes the generated JavaScript is\
1971+ "(1) It shortens record field names. This makes the generated JavaScript\
778 \ smaller, but `Debug.toString` cannot know the real field names anymore."
1972 \ smaller, but `Debug.toString` cannot know the real field names anymore."
779 , D.indent 4 $ D.reflow $
1973 , D.indent 4 $ D.reflow $
780 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
1974 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
@@ -787,42 +1981,89 @@ makeToReport make =
787 \ exists!"
1981 \ exists!"
788 ]
1982 ]
789
1983
790− MakeCannotBuild buildProblem ->
791− case buildProblem of
792− BuildProjectProblem bp ->
793− case bp of
794− BP_PathUnknown _ ->
795− error "TODO BP_PathUnknown"
796
1984
797− BP_WithBadExtension _ ->
798− error "TODO BP_WithBadExtension"
799
1985
800− BP_WithAmbiguousSrcDir _ _ ->
1986+-- CORRUPT CACHE
801− error "TODO BP_WithAmbiguousSrcDir"
802
1987
803− BP_MainPathDuplicate _ _ ->
804− error "TODO BP_MainPathDuplicate"
805
1988
806− BP_MainNameDuplicate _ _ _ ->
1989+corruptCacheReport :: Help.Report
807− error "TODO BP_MainNameDuplicate"
1990+corruptCacheReport =
1991+ Help.report "CORRUPT CACHE" Nothing
1992+ "It looks like some of the information cached in elm-stuff/ has been corrupted."
1993+ [ D.reflow $
1994+ "Try deleting your elm-stuff/ directory to get unstuck."
1995+ , D.toSimpleNote $
1996+ "This almost certainly means that a 3rd party tool (or editor plugin) is\
1997+ \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\
1998+ \ one by one until you figure out which it is!"
1999+ ]
808
2000
809− BP_CannotLoadDependencies ->
810− error "TODO BP_CannotLoadDependencies"
811
2001
812− BP_Cycle name names ->
813− Help.report "IMPORT CYCLE" Nothing
814− "Your module imports form a cycle:"
815− [ D.cycle 4 name names
816− , D.reflow $
817− "Learn more about why this is disallowed and how to break cycles here:"
818− ++ D.makeLink "import-cycles"
819− ]
820
2002
821− BP_MissingExposed _ ->
2003+-- REACTOR
822− error "TODO BP_MissingExposed"
2004+
2005+
2006+data Reactor
2007+ = ReactorNoOutline
2008+ | ReactorBadDetails Details
2009+ | ReactorBadBuild BuildProblem
2010+ | ReactorBadGenerate Generate
2011+
2012+
2013+reactorToReport :: Reactor -> Help.Report
2014+reactorToReport problem =
2015+ case problem of
2016+ ReactorNoOutline ->
2017+ Help.report "NEW PROJECT?" Nothing
2018+ "Are you trying to start a new project? Try this command in the terminal:"
2019+ [ D.indent 4 $ D.green "elm init"
2020+ , D.reflow "It will help you get started!"
2021+ ]
2022+
2023+ ReactorBadDetails details ->
2024+ toDetailsReport details
2025+
2026+ ReactorBadBuild buildProblem ->
2027+ toBuildProblemReport buildProblem
2028+
2029+ ReactorBadGenerate generate ->
2030+ toGenerateReport generate
2031+
2032+
2033+
2034+-- REPL
2035+
2036+
2037+data Repl
2038+ = ReplBadDetails Details
2039+ | ReplBadInput BS.ByteString Error.Error
2040+ | ReplBadLocalDeps FilePath Error.Module [Error.Module]
2041+ | ReplProjectProblem BuildProjectProblem
2042+ | ReplBadGenerate Generate
2043+ | ReplBadCache
2044+ | ReplBlocked
2045+
2046+
2047+replToReport :: Repl -> Help.Report
2048+replToReport problem =
2049+ case problem of
2050+ ReplBadDetails details ->
2051+ toDetailsReport details
2052+
2053+ ReplBadInput source err ->
2054+ Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
2055+
2056+ ReplBadLocalDeps root e es ->
2057+ Help.compilerReport root e es
2058+
2059+ ReplProjectProblem projectProblem ->
2060+ toProjectProblemReport projectProblem
2061+
2062+ ReplBadGenerate generate ->
2063+ toGenerateReport generate
823
2064
824− BuildModuleProblems p ps ->
2065+ ReplBadCache ->
825− Help.compilerReport p ps
2066+ corruptCacheReport
826
2067
827− MakeCannotLoadArtifacts ->
2068+ ReplBlocked ->
828− error "TODO MakeCannotLoadArtifacts"
2069+ corruptCacheReport
builder/src/Reporting/Exit/Assets.hsdeleted−227
@@ -1,227 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Assets
3− ( Exit(..)
4− , ElmJsonProblem(..)
5− , toReport
6− , BadElmJsonContent(..)
7− , badContentToDocs
8− )
9− where
10−
11−
12−import qualified Data.Text as Text
13−
14−import qualified Elm.Package as Pkg
15−import Reporting.Doc ((<>))
16−import qualified Reporting.Doc as D
17−import qualified Reporting.Exit.Help as Help
18−
19−
20−
21−-- EXITS
22−
23−
24−data Exit
25− = BadElmJson ElmJsonProblem
26− | CorruptElmJson Pkg.Name Pkg.Version
27− | CorruptDocumentation Pkg.Name Pkg.Version
28− | CorruptBinary FilePath FilePath
29−
30−
31−
32−-- ELM JSON PROBLEM
33−
34−
35−data ElmJsonProblem
36− = BadJson D.Doc
37− | BadSrcDir FilePath
38− | NoPkgCore
39− | NoAppCore
40− | NoAppJson
41−
42−
43−
44−-- TO REPORT
45−
46−
47−toReport :: Exit -> Help.Report
48−toReport exit =
49− case exit of
50− CorruptElmJson pkg vsn ->
51− corruptJsonToReport "elm.json" pkg vsn
52−
53− CorruptDocumentation pkg vsn ->
54− corruptJsonToReport "docs.json" pkg vsn
55−
56− CorruptBinary elmHome path ->
57− Help.report "CORRUPT BINARY" (Just path)
58− ("The binary data at " ++ path ++ " is corrupt.")
59− [ D.reflow "Elm caches build artifacts in the following directories:"
60− , D.dullyellow $ D.indent 4 $ D.vcat $
61− [ D.fromString elmHome
62− , "elm-stuff/"
63− ]
64− , D.reflow
65− "Maybe you recently installed a command line tool or editor plugin that messes\
66− \ with them? They definitely should not be doing that, but you never know! So\
67− \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
68− \ help reveal the corrupting influence."
69− ]
70−
71− BadElmJson problem ->
72− elmJsonProblemToReport problem
73−
74−
75−
76−-- CORRUPT JSON
77−
78−
79−corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
80−corruptJsonToReport path pkg vsn =
81− Help.report "CORRUPT JSON" Nothing
82− ( "The " ++ path ++ " for " ++ Pkg.toString pkg
83− ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
84− )
85− [ D.reflow $
86− "I removed it from my file cache, so if it was some transient\
87− \ error it should be fixed if you try the same thing again.\
88− \ Please report this if it seems like an Elm problem though!"
89− ]
90−
91−
92−
93−-- BAD ELM JSON
94−
95−
96−elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
97−elmJsonProblemToReport problem =
98− case problem of
99− BadJson doc ->
100− Help.jsonReport "BAD JSON" (Just "elm.json") doc
101−
102− BadSrcDir dir ->
103− Help.report "BAD JSON" (Just "elm.json")
104− "The \"source-directories\" in your elm.json lists the following directory:"
105− [ D.indent 4 (D.dullyellow (D.fromString dir))
106− , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
107− ]
108−
109− NoPkgCore ->
110− Help.report "MISSING DEPENDENCY" (Just "elm.json")
111− "A package must have \"elm/core\" as a dependency. Try running:"
112− [ D.indent 4 $ D.green $ "elm install elm/core"
113− , D.reflow "I need it for the default imports that make `List` and `Maybe` available."
114− ]
115−
116− NoAppCore ->
117− Help.report "MISSING DEPENDENCY" (Just "elm.json")
118− "An application must have \"elm/core\" as a dependency. Try running:"
119− [ D.indent 4 $ D.green $ "elm install elm/core"
120− , D.reflow "It has some supporting code that is needed by every Elm application!"
121− ]
122−
123− NoAppJson ->
124− Help.report "MISSING DEPENDENCY" (Just "elm.json")
125− "An application must have \"elm/json\" as a dependency. Try running:"
126− [ D.indent 4 $ D.green $ "elm install elm/json"
127− , D.reflow "It helps me handle flags and ports."
128− ]
129−
130−
131−
132−-- PROBLEM TO DOCS
133−
134−
135−data BadElmJsonContent
136− = BadType Text.Text
137− | BadPkgName String
138− | BadVersion Text.Text
139− | BadConstraint String
140− | BadModuleName Text.Text
141− | BadModuleHeaderTooLong Text.Text
142− | BadDependencyName Text.Text
143− | BadLicense Text.Text [Text.Text]
144− | BadDirectoryNotString
145− | BadSummaryTooLong
146−
147−
148−badContentToDocs :: BadElmJsonContent -> [D.Doc]
149−badContentToDocs badContent =
150− case badContent of
151− BadType _ ->
152− ["The","only","valid","types","of","elm.json","are"
153− ,D.green "\"application\"","and",D.green "\"package\"" <> "."
154− ]
155−
156− BadPkgName problem ->
157− map D.fromString (words problem)
158−
159− BadVersion txt ->
160− ["You","provided",D.red (D.fromString (show txt))
161− ,"which","is","not","a","valid","version.","I","need","something","like"
162− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
163− ]
164−
165− BadConstraint problem ->
166− map D.fromString (words ("It is not a valid constraint. " ++ problem))
167−
168− BadModuleName name ->
169− ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
170− ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
171− ]
172−
173− BadModuleHeaderTooLong header ->
174− ["The",D.fromString (show header),"header","is","too","long."
175− ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
176− ,"to","ensure","that","formatting","is","nice","on","the","package","website."
177− ]
178−
179− BadDependencyName name ->
180− ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
181− ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
182− ,"the","package","website,","and","installing","it","with","the"
183− ,D.green "`elm install`","command","instead."
184− ]
185−
186− BadLicense _given suggestions ->
187− case suggestions of
188− [] ->
189− ["I","need","an","OSI","approved","SPDX","license,","like"
190− ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
191− ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
192− ]
193−
194− code:codes ->
195− ["I","need","an","OSI","approved","SPDX","license."]
196− ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
197− ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
198−
199− BadDirectoryNotString ->
200− ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
201− ]
202−
203− BadSummaryTooLong ->
204− ["Your","summary","is","too","long.","I","need","it","to"
205− ,"be",D.green "under",D.green "80",D.green "characters."
206− ]
207−
208−
209−oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
210−oneOf code codes =
211− let
212− toDoc spdx =
213− D.green (D.fromString (show spdx))
214− in
215− case codes of
216− [] ->
217− [toDoc code]
218−
219− [code2] ->
220− [toDoc code,"or",toDoc code2]
221−
222− _:_ ->
223− let
224− these = code : init codes
225− final = last codes
226− in
227− map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Exit/Crawl.hsdeleted−345
@@ -1,345 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Crawl
3− ( Exit(..)
4− , Problem(..)
5− , Origin(..)
6− , SrcDirs(..)
7− , toReport
8− )
9− where
10−
11−
12−import qualified Data.Char as Char
13−import qualified Data.Map as Map
14−import qualified Data.Time.Clock as Time
15−
16−import qualified Elm.Compiler as Compiler
17−import qualified Elm.ModuleName as ModuleName
18−import qualified Elm.Package as Pkg
19−import qualified Elm.Version as V
20−import Reporting.Doc ((<+>), (<>))
21−import qualified Reporting.Doc as D
22−import qualified Reporting.Exit.Compile as Compile
23−import qualified Reporting.Exit.Help as Help
24−
25−
26−
27−-- EXIT
28−
29−
30−data Exit
31− = RootFileNotFound FilePath
32− | RootModuleNameDuplicate ModuleName.Raw [FilePath]
33− | RootNameless FilePath
34− | DependencyProblems Problem [Problem]
35− | BadKernelHeader FilePath
36−
37−
38−data Problem
39− = ModuleNotFound Origin ModuleName.Raw SrcDirs
40− | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]
41− | BadHeader FilePath Time.UTCTime String Compiler.Error
42− | ModuleNameReservedForKernel Origin ModuleName.Raw
43− | ModuleNameMissing FilePath ModuleName.Raw
44− | ModuleNameMismatch
45− FilePath
46− ModuleName.Raw -- expected
47− ModuleName.Raw -- actual
48− | PortsInPackage FilePath ModuleName.Raw
49− | EffectsUnexpected FilePath ModuleName.Raw
50−
51−
52−data Origin
53− = ElmJson
54− | File FilePath
55− | Module FilePath ModuleName.Raw
56−
57−
58−data SrcDirs
59− = App [FilePath]
60− | Pkg
61−
62−
63−
64−-- TO REPORT
65−
66−
67−toReport :: Exit -> Help.Report
68−toReport exit =
69− case exit of
70− RootFileNotFound path ->
71− Help.report "FILE NOT FOUND" Nothing
72− "You want me to compile this file:"
73− [ D.indent 4 $ D.dullyellow $ D.fromChars path
74− , "I cannot find it though! Is there a typo?"
75− ]
76−
77− RootModuleNameDuplicate name paths ->
78− Help.report "DUPLICATE NAMES" Nothing
79− "I am trying to compile multiple modules with the same name:"
80− [ D.indent 4 $ D.dullyellow $ D.vcat $
81− map D.fromChars paths
82− , D.fillSep $
83− [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
84− , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."
85− , "Change", "them", "to", "have", "unique", "names", "and", "you"
86− , "should", "be", "all", "set!"
87− ]
88− ]
89−
90− RootNameless path ->
91− namelessToDoc path "Main"
92−
93− DependencyProblems problem otherProblems ->
94− case otherProblems of
95− [] ->
96− problemToReport problem
97−
98− _ ->
99− problemToReport problem
100− -- error "TODO handle multiple dependency errors"
101−
102− BadKernelHeader filePath ->
103− Help.report "BAD KERNEL HEADER" Nothing
104− "I ran into a bad header in this file:"
105− [ D.indent 4 $ D.dullyellow $ D.fromChars filePath
106− , D.reflow $
107− "NOTE: Kernel code is only available to core Elm libraries to ensure\
108− \ the portability and security of the Elm ecosystem. This restriction\
109− \ also makes it possible to improve code gen (i.e. performance) without\
110− \ disrupting the ecosystem."
111− ]
112−
113−
114−
115−-- PROBLEM TO REPORT
116−
117−
118−problemToReport :: Problem -> Help.Report
119−problemToReport problem =
120− case problem of
121− ModuleNotFound origin name srcDirs ->
122− notFoundToDoc origin name srcDirs
123−
124− ModuleAmbiguous origin child paths pkgs ->
125− ambiguousToDoc origin child paths pkgs
126−
127− BadHeader path time source compilerError ->
128− let
129− compilerExit =
130− Compile.Exit "???" path time source [compilerError]
131− in
132− Help.compilerReport compilerExit []
133−
134− ModuleNameMissing path name ->
135− namelessToDoc path name
136−
137− ModuleNameMismatch path expected actual ->
138− Help.report "MODULE NAME MISMATCH" (Just path)
139− ( "The file at " ++ path ++ " has a typo in the module name. It says:"
140− )
141− [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"
142− , "Looks like a typo or copy/paste error. Instead it needs to say:"
143− , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"
144− , "Make the change and you should be all set!"
145− ]
146−
147− ModuleNameReservedForKernel origin name ->
148− kernelNameToDoc origin name
149−
150− PortsInPackage path name ->
151− badTagToDoc path name "port" "port-modules" $
152− "Packages cannot have any `port` modules."
153−
154− EffectsUnexpected path name ->
155− badTagToDoc path name "effect" "effect-modules" $
156− "Creating `effect` modules is relatively experimental. There are a\
157− \ couple in @elm repos right now, but we have decided to be very\
158− \ cautious in expanding its usage."
159−
160−
161−badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report
162−badTagToDoc path name tag hintName summary =
163− Help.report
164− ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
165− (Just path)
166− summary
167− [ D.fillSep $
168− [ "Get", "rid", "of", "all", "the"
169− , D.red (D.fromChars tag)
170− , "stuff", "in"
171− , D.dullyellow (D.fromChars (ModuleName.nameToChars name))
172− , "to", "proceed."
173− ]
174− , D.toSimpleNote $
175− "You can learn the reasoning behind this design choice at "
176− ++ D.makeLink hintName
177− ]
178−
179−
180−
181−-- NAMELESS
182−
183−
184−namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report
185−namelessToDoc path name =
186− Help.report "UNNAMED MODULE" (Just path)
187− ( "The `" ++ ModuleName.nameToChars name
188− ++ "` module must start with a line like this:"
189− )
190− [ D.indent 4 $ D.dullyellow $ D.fromChars $
191− "module " ++ ModuleName.nameToChars name ++ " exposing (..)"
192− , D.reflow $
193− "Try adding that as the first line of your file!"
194− , D.toSimpleNote $
195− "It is best to replace (..) with an explicit list of types and\
196− \ functions you want to expose. If you know a value is only used\
197− \ WITHIN this module, it is extra easy to refactor. This kind of\
198− \ information is great, especially as your project grows!"
199− ]
200−
201−
202−
203−-- NOT FOUND
204−
205−
206−notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report
207−notFoundToDoc origin child srcDirs =
208− case origin of
209− ElmJson ->
210− Help.report "MODULE NOT FOUND" (Just "elm.json")
211− "Your elm.json says your project has the following module:"
212− [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child
213− , D.reflow $
214− "When creating packages, all modules must live in the src/ directory."
215− ]
216−
217− File path ->
218− Help.report "UNKNOWN IMPORT" (Just path)
219− ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")
220− (notFoundDetails child srcDirs)
221−
222− Module path parent ->
223− Help.report "UNKNOWN IMPORT" (Just path)
224− ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")
225− (notFoundDetails child srcDirs)
226−
227−
228−notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]
229−notFoundDetails child srcDirs =
230− let
231− simulatedCode =
232− D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child
233− in
234− case Map.lookup child Pkg.suggestions of
235− Just pkg ->
236− [ simulatedCode
237− , D.reflow $
238− "Do you want the one from the " ++ Pkg.toChars pkg
239− ++ " package? If so, run this command to add that dependency to your elm.json file:"
240− , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg
241− , case srcDirs of
242− Pkg ->
243− D.reflow $
244− "If you want a local file, make sure the `"
245− ++ ModuleName.nameToChars child
246− ++ "` module is in your src/ directory."
247−
248− App _ ->
249− D.reflow $
250− "If you want a local file, make sure the `"
251− ++ ModuleName.nameToChars child
252− ++ "` module is in one of the \"source-directories\" listed in your elm.json file."
253− ]
254−
255− Nothing ->
256− [ simulatedCode
257− , "I cannot find that module! Is there a typo in the module name?"
258− , D.reflow $
259− case srcDirs of
260− Pkg ->
261− "When creating a package, all modules must live in the src/ directory."
262−
263− App [] ->
264− "The \"source-directories\" field of your elm.json is empty, so I only\
265− \ searched in packages. Maybe you need to add a \"src\" directory there?"
266−
267− App [dir] ->
268− "The \"source-directories\" field of your elm.json tells me to only look in the "
269− ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
270−
271− App (dir:_:_) ->
272− "The \"source-directories\" field of your elm.json tells me to look in directories like "
273− ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
274− ]
275−
276−
277−ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report
278−ambiguousToDoc origin child paths pkgs =
279− let
280− pkgToString (Pkg.Canonical pkg vsn) =
281− "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
282−
283− makeReport maybePath summary yellowString =
284− Help.report "AMBIGUOUS IMPORT" maybePath summary
285− [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString
286− , D.reflow $
287− "I found multiple module with that name though:"
288− , D.indent 4 $ D.dullyellow $ D.vcat $
289− map D.fromChars $ paths ++ map pkgToString pkgs
290− , D.reflow $
291− if null paths then
292− "It looks like the name clash is in your dependencies, which is\
293− \ out of your control. Elm does not support this scenario right\
294− \ now, but it may be worthwhile. Please open an issue describing\
295− \ your scenario so we can gather more usage information!"
296− else
297− "Which is the right one? Try renaming your modules to have unique names."
298− ]
299− in
300− case origin of
301− ElmJson ->
302− makeReport
303− Nothing
304− "Your elm.json wants the following module:"
305− (ModuleName.nameToChars child)
306−
307− File path ->
308− makeReport
309− (Just path)
310− ("The file at " ++ path ++ " has an ambiguous import:")
311− ("import " ++ ModuleName.nameToChars child)
312−
313− Module path parent ->
314− makeReport
315− (Just path)
316− ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")
317− ("import " ++ ModuleName.nameToChars child)
318−
319−
320−kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report
321−kernelNameToDoc origin kernelName =
322− let
323− (maybePath, statement) =
324− case origin of
325− ElmJson ->
326− ( Nothing
327− , "Your elm.json says your project has the following module:"
328− )
329−
330− File path ->
331− ( Just path
332− , "This file is trying to import the following module:"
333− )
334−
335− Module path parent ->
336− ( Just path
337− , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"
338− )
339− in
340− Help.report "BAD MODULE NAME" maybePath statement
341− [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName
342− , D.reflow $
343− "But names like that are reserved for internal use.\
344− \ Switch to a name outside of the Elm/Kernel/ namespace."
345− ]
builder/src/Reporting/Exit/Deps.hsdeleted−123
@@ -1,123 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Deps
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Elm.Constraint as Con
10−import qualified Elm.Package as Pkg
11−import qualified Elm.Version as V
12−import Reporting.Doc ((<>))
13−import qualified Reporting.Doc as D
14−import qualified Reporting.Exit.Help as Help
15−
16−
17−
18−-- EXITS
19−
20−
21−data Exit
22− = CorruptVersionCache FilePath Pkg.Name
23− | PackageNotFound Pkg.Name [Pkg.Name]
24− -- verify
25− | PkgBadElm Con.Constraint
26− | AppBadElm V.Version
27− | AppMissingTrans [(Pkg.Name, V.Version)]
28− | BadDeps
29− | BuildFailure FilePath Pkg.Name V.Version
30−
31−
32−
33−-- TO DOC
34−
35−
36−toReport :: Exit -> Help.Report
37−toReport exit =
38− case exit of
39− CorruptVersionCache elmHome pkg ->
40− Help.report "CORRUPT CACHE" Nothing
41− ( "I ran into an unknown package while exploring dependencies:"
42− )
43− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg
44− , D.reflow $
45− "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
46− \ Maybe some program is messing with it? It is just cached files,\
47− \ so you can delete it and see if that fixes the issue."
48− ]
49−
50− PackageNotFound package suggestions ->
51− Help.docReport "PACKAGE NOT FOUND" Nothing
52− ( D.fillSep
53− ["I","cannot","find","a"
54− ,D.red (D.fromUtf8 (Pkg.toString package))
55− ,"package","on","the","package","website."
56− ]
57− )
58− [ "Maybe you want one of these instead?"
59− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
60− , "But check <https://package.elm-lang.org> to see all possibilities!"
61− ]
62−
63− PkgBadElm constraint ->
64− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
65− "Your elm.json says this package needs a version of Elm in this range:"
66− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint
67− , D.fillSep
68− [ "But", "you", "are", "using", "Elm"
69− , D.red (D.fromUtf8 (V.toString V.compiler))
70− , "right", "now."
71− ]
72− ]
73−
74− AppBadElm version ->
75− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
76− "Your elm.json says this application needs a different version of Elm."
77− [ D.fillSep
78− [ "It", "requires"
79− , D.green (D.fromUtf8 (V.toString version)) <> ","
80− , "but", "you", "are", "using"
81− , D.red (D.fromUtf8 (V.toString V.compiler))
82− , "right", "now."
83− ]
84− ]
85−
86− AppMissingTrans missingDeps ->
87− let
88− toEntry (pkg, vsn) =
89− "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""
90− in
91− Help.report "MISSING DEPENDENCIES" (Just "elm.json")
92− "Your elm.json is missing some \"indirect\" dependencies:"
93− [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps
94− , D.fillSep
95− ["This","usually","means","you","are","editing","elm.json","by","hand."
96− ,"It","is","much","more","reliable","to","use","the"
97− ,D.green "elm install","command","instead."
98− ]
99− ]
100−
101− BadDeps ->
102− Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")
103− "The dependencies in your elm.json are not compatible."
104− [ D.fillSep
105− ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
106− ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"
107− ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."
108− ]
109− , D.reflow $
110− "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
111− \ you try those paths and still cannot figure it out!"
112− ]
113−
114− BuildFailure elmHome pkg vsn ->
115− Help.report "CORRUPT DEPENDENCY" Nothing
116− "I ran into a problem while building the following package:"
117− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
118− , D.fillSep
119− ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
120− ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"
121− ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
122− ]
123− ]
builder/src/Reporting/Exit/Help.hs+9−10
@@ -14,7 +14,6 @@ module Reporting.Exit.Help
14 where
14 where
15
15
16
16
17−import qualified Data.Utf8 as Utf8
18import GHC.IO.Handle (hIsTerminalDevice)
17import GHC.IO.Handle (hIsTerminalDevice)
19import System.IO (Handle, hPutStr, stderr, stdout)
18import System.IO (Handle, hPutStr, stderr, stdout)
20
19
@@ -30,7 +29,7 @@ import qualified Reporting.Error as Error
30
29
31
30
32data Report
31data Report
33− = CompilerReport Error.Module [Error.Module]
32+ = CompilerReport FilePath Error.Module [Error.Module]
34 | Report
33 | Report
35 { _title :: String
34 { _title :: String
36 , _path :: Maybe FilePath
35 , _path :: Maybe FilePath
@@ -53,7 +52,7 @@ jsonReport =
53 Report
52 Report
54
53
55
54
56−compilerReport :: Error.Module -> [Error.Module] -> Report
55+compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
57compilerReport =
56compilerReport =
58 CompilerReport
57 CompilerReport
59
58
@@ -65,8 +64,8 @@ compilerReport =
65reportToDoc :: Report -> D.Doc
64reportToDoc :: Report -> D.Doc
66reportToDoc report_ =
65reportToDoc report_ =
67 case report_ of
66 case report_ of
68− CompilerReport e es ->
67+ CompilerReport root e es ->
69− Error.toDoc e es
68+ Error.toDoc root e es
70
69
71 Report title maybePath message ->
70 Report title maybePath message ->
72 let
71 let
@@ -95,17 +94,17 @@ reportToDoc report_ =
95reportToJson :: Report -> E.Value
94reportToJson :: Report -> E.Value
96reportToJson report_ =
95reportToJson report_ =
97 case report_ of
96 case report_ of
98− CompilerReport e es ->
97+ CompilerReport _ e es ->
99 E.object
98 E.object
100− [ "type" ==> E.string "compile-errors"
99+ [ "type" ==> E.chars "compile-errors"
101 , "errors" ==> E.list Error.toJson (e:es)
100 , "errors" ==> E.list Error.toJson (e:es)
102 ]
101 ]
103
102
104 Report title maybePath message ->
103 Report title maybePath message ->
105 E.object
104 E.object
106− [ "type" ==> E.string "error"
105+ [ "type" ==> E.chars "error"
107− , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath
106+ , "path" ==> maybe E.null E.chars maybePath
108− , "title" ==> E.string (Utf8.fromChars title)
107+ , "title" ==> E.chars title
109 , "message" ==> D.encode message
108 , "message" ==> D.encode message
110 ]
109 ]
111
110
builder/src/Reporting/Exit/Http.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Http
3− ( Exit(..)
4− , toReport
5− , BadJson(..)
6− , badJsonToDocs
7− )
8− where
9−
10−
11−import qualified Data.Text as Text
12−
13−import Reporting.Doc ((<>))
14−import qualified Reporting.Doc as D
15−import qualified Reporting.Exit.Help as Help
16−
17−
18−
19−-- EXITS
20−
21−
22−data Exit
23− = Unknown String
24− | BadJson String D.Doc
25− | BadZipData
26− | BadZipSha String String
27−
28−
29−
30−-- TO REPORT
31−
32−
33−toReport :: String -> Exit -> Help.Report
34−toReport url exit =
35− let
36− urlDoc =
37− D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"
38− in
39− case exit of
40− Unknown message ->
41− Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
42− [ urlDoc
43− , D.stack
44− [ "Here is the error message I was able to extract:"
45− , D.indent 4 $ D.reflow message
46− ]
47− ]
48−
49− BadJson path doc ->
50− Help.jsonReport "UNEXPECTED JSON" (Just path) doc
51−
52− BadZipData ->
53− Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
54− [ urlDoc
55− , D.reflow $
56− "If it is a transient issue, it should be fixed if you try this\
57− \ again. If it seems like an Elm problem, please report it though!"
58− ]
59−
60− BadZipSha expectedHash actualHash ->
61− Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
62− [ urlDoc
63− , D.reflow "I check the hash the zip, and it seems off:"
64− , D.vcat $ map D.fromString $
65− [ " Expected: " ++ expectedHash
66− , " Actual: " ++ actualHash
67− ]
68− , D.reflow $
69− "This usually means that the package author moved the version\
70− \ tag, so report it to them and see if that is the issue. Folks\
71− \ on Elm slack can probably help as well."
72− ]
73−
74−
75−
76−-- BAD JSON
77−
78−
79−data BadJson
80− = BadNewPkg Text.Text
81− | BadAllPkg Text.Text String
82− | BadAllVsn Text.Text
83−
84−
85−badJsonToDocs :: BadJson -> [D.Doc]
86−badJsonToDocs badJson =
87− case badJson of
88− BadNewPkg txt ->
89− ["I","ran","into",D.red (D.fromString (show txt)) <> ","
90− ,"but","I","need","entries","like"
91− ,D.green "\"elm/core@6.0.0\"" <> "."
92− ]
93−
94− BadAllPkg txt suggestion ->
95− ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
96− ]
97− ++ map D.fromString (words suggestion)
98−
99− BadAllVsn txt ->
100− ["You","provided",D.red (D.fromString (show txt))
101− ,"which","is","not","a","valid","version.","I","need","something","like"
102− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
103− ]
104−
builder/src/Reporting/Task.hs+17
@@ -3,8 +3,10 @@ module Reporting.Task
3 ( Task
3 ( Task
4 , run
4 , run
5 , throw
5 , throw
6+ , mapError
6 --
7 --
7 , io
8 , io
9+ , mio
8 , eio
10 , eio
9 )
11 )
10 where
12 where
@@ -31,6 +33,12 @@ throw x =
31 Task $ \_ err -> err x
33 Task $ \_ err -> err x
32
34
33
35
36+mapError :: (x -> y) -> Task x a -> Task y a
37+mapError func (Task task) =
38+ Task $ \ok err ->
39+ task ok (err . func)
40+
41+
34
42
35-- IO
43-- IO
36
44
@@ -41,6 +49,15 @@ io work =
41 Task $ \ok _ -> work >>= ok
49 Task $ \ok _ -> work >>= ok
42
50
43
51
52+mio :: x -> IO (Maybe a) -> Task x a
53+mio x work =
54+ Task $ \ok err ->
55+ do result <- work
56+ case result of
57+ Just a -> ok a
58+ Nothing -> err x
59+
60+
44eio :: (x -> y) -> IO (Either x a) -> Task y a
61eio :: (x -> y) -> IO (Either x a) -> Task y a
45eio func work =
62eio func work =
46 Task $ \ok err ->
63 Task $ \ok err ->
builder/src/Stuff.hs+8−9
@@ -8,8 +8,8 @@ module Stuff
8 , elmo
8 , elmo
9 , temp
9 , temp
10 , findRoot
10 , findRoot
11− , withProjectLock
11+ , withRootLock
12− , withCacheLock
12+ , withRegistryLock
13 , PackageCache
13 , PackageCache
14 , getPackageCache
14 , getPackageCache
15 , registry
15 , registry
@@ -120,17 +120,16 @@ findRootHelp dirs =
120-- LOCKS
120-- LOCKS
121
121
122
122
123−withProjectLock :: FilePath -> IO a -> IO a
123+withRootLock :: FilePath -> IO a -> IO a
124−withProjectLock root work =
124+withRootLock 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 </> "project.lock") Lock.Exclusive (\_ -> work)
127+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
128
128
129
129
130−withCacheLock :: PackageCache -> IO a -> IO a
130+withRegistryLock :: PackageCache -> IO a -> IO a
131−withCacheLock (PackageCache dir) work =
131+withRegistryLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)
132+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
133−
134
133
135
134
136
135
cabal.confignew file+2
@@ -0,0 +1,2 @@
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− _ -> error "binary encoding of CtorOpts was corrupted"
345+ _ -> fail "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− _ -> error "binary encoding of AliasType was corrupted"
396+ _ -> fail "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 -- TODO profile switching Global to Name
138+ , _l_nodes :: Map.Map Global Node -- PERF 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− _ -> error "problem getting Opt.Expr binary"
311+ _ -> fail "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− _ -> error "problem getting Opt.Def binary"
325+ _ -> fail "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− _ -> error "problem getting Opt.Path binary"
348+ _ -> fail "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− _ -> error "problem getting Opt.Decider binary"
364+ _ -> fail "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− _ -> error "problem getting Opt.Choice binary"
378+ _ -> fail "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− _ -> error "problem getting Opt.Main binary"
403+ _ -> fail "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− _ -> error "problem getting Opt.Node binary"
435+ _ -> fail "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− _ -> error "problem getting Opt.EffectsType binary"
451+ _ -> fail "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 [A.Located Exposed]
198+ | Explicit [Exposed]
199
199
200
200
201data Exposed
201data Exposed
202− = Lower Name
202+ = Lower (A.Located Name)
203− | Upper Name Privacy
203+ | Upper (A.Located Name) Privacy
204− | Operator Name
204+ | Operator A.Region Name
205
205
206
206
207data Privacy
207data Privacy
208− = Public
208+ = Public A.Region
209 | Private
209 | Private
compiler/src/AST/Utils/Binop.hs+5−6
@@ -41,12 +41,11 @@ 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 $
45− case n of
44+ case n of
46− 0 -> Left
45+ 0 -> return Left
47− 1 -> Non
46+ 1 -> return Non
48− 2 -> Right
47+ 2 -> return Right
49− _ -> error "Error reading valid associativity from serialized string"
48+ _ -> fail "Error reading valid associativity from serialized string"
50
49
51 put assoc =
50 put assoc =
52 putWord8 $
51 putWord8 $
compiler/src/AST/Utils/Shader.hs+2
@@ -74,9 +74,11 @@ escape chars =
74 []
74 []
75
75
76 c:cs
76 c:cs
77+ | c == '\r' -> escape cs
77 | c == '\n' -> '\\' : 'n' : escape cs
78 | c == '\n' -> '\\' : 'n' : escape cs
78 | c == '\"' -> '\\' : '"' : escape cs
79 | c == '\"' -> '\\' : '"' : escape cs
79 | c == '\'' -> '\\' : '\'' : escape cs
80 | c == '\'' -> '\\' : '\'' : escape cs
81+ | c == '\\' -> '\\' : '\\' : escape cs
80 | otherwise -> c : escape cs
82 | otherwise -> c : escape cs
81
83
82
84
compiler/src/AST/Utils/Type.hs−1
@@ -1,5 +1,4 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3module AST.Utils.Type
2module AST.Utils.Type
4 ( delambda
3 ( delambda
5 , dealias
4 , dealias
compiler/src/Canonicalize/Environment.hs+50−20
@@ -4,6 +4,8 @@ module Canonicalize.Environment
4 ( Env(..)
4 ( Env(..)
5 , Exposed
5 , Exposed
6 , Qualified
6 , Qualified
7+ , Info(..)
8+ , mergeInfo
7 , Var(..)
9 , Var(..)
8 , Type(..)
10 , Type(..)
9 , Ctor(..)
11 , Ctor(..)
@@ -20,8 +22,8 @@ module Canonicalize.Environment
20
22
21import qualified Data.Map.Merge.Strict as Map
23import qualified Data.Map.Merge.Strict as Map
22import qualified Data.Map.Strict as Map
24import qualified Data.Map.Strict as Map
23−import qualified Data.Map.Strict.Internal as I
24import qualified Data.Name as Name
25import qualified Data.Name as Name
26+import qualified Data.OneOrMore as OneOrMore
25
27
26import qualified AST.Utils.Binop as Binop
28import qualified AST.Utils.Binop as Binop
27import qualified AST.Canonical as Can
29import qualified AST.Canonical as Can
@@ -58,11 +60,34 @@ data Env =
58
60
59
61
60type Exposed a =
62type Exposed a =
61− Map.Map Name.Name (Map.Map ModuleName.Canonical a)
63+ Map.Map Name.Name (Info a)
62
64
63
65
64type Qualified a =
66type Qualified a =
65− Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))
67+ Map.Map Name.Name (Map.Map Name.Name (Info a))
68+
69+
70+
71+-- INFO
72+
73+
74+data Info a
75+ = Specific ModuleName.Canonical a
76+ | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77+
78+
79+mergeInfo :: Info a -> Info a -> Info a
80+mergeInfo info1 info2 =
81+ case info1 of
82+ Specific h1 _ ->
83+ case info2 of
84+ Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)
85+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86+
87+ Ambiguous h1 hs1 ->
88+ case info2 of
89+ Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
66
91
67
92
68
93
@@ -72,7 +97,8 @@ type Qualified a =
72data Var
97data Var
73 = Local A.Region
98 = Local A.Region
74 | TopLevel A.Region
99 | TopLevel A.Region
75− | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
100+ | Foreign ModuleName.Canonical Can.Annotation
101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
76
102
77
103
78
104
@@ -139,7 +165,10 @@ addLocalLeft _ region =
139addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
165addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
140addLocalBoth name region var =
166addLocalBoth name region var =
141 case var of
167 case var of
142− Foreign _ ->
168+ Foreign _ _ ->
169+ Result.ok (Local region)
170+
171+ Foreigns _ _ ->
143 Result.ok (Local region)
172 Result.ok (Local region)
144
173
145 Local parentRegion ->
174 Local parentRegion ->
@@ -150,17 +179,18 @@ addLocalBoth name region var =
150
179
151
180
152
181
182+
153-- FIND TYPE
183-- FIND TYPE
154
184
155
185
156findType :: A.Region -> Env -> Name.Name -> Result i w Type
186findType :: A.Region -> Env -> Name.Name -> Result i w Type
157findType region (Env _ _ ts _ _ _ qts _) name =
187findType region (Env _ _ ts _ _ _ qts _) name =
158 case Map.lookup name ts of
188 case Map.lookup name ts of
159− Just (I.Bin 1 _ tipe _ _) ->
189+ Just (Specific _ tipe) ->
160 Result.ok tipe
190 Result.ok tipe
161
191
162− Just homes ->
192+ Just (Ambiguous h hs) ->
163− Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
193+ Result.throw (Error.AmbiguousType region Nothing name h hs)
164
194
165 Nothing ->
195 Nothing ->
166 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -171,11 +201,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
171 case Map.lookup prefix qts of
201 case Map.lookup prefix qts of
172 Just qualified ->
202 Just qualified ->
173 case Map.lookup name qualified of
203 case Map.lookup name qualified of
174− Just (I.Bin 1 _ tipe _ _) ->
204+ Just (Specific _ tipe) ->
175 Result.ok tipe
205 Result.ok tipe
176
206
177− Just homes ->
207+ Just (Ambiguous h hs) ->
178− Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
179
209
180 Nothing ->
210 Nothing ->
181 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -191,11 +221,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
191findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
221findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
192findCtor region (Env _ _ _ cs _ _ _ qcs) name =
222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
193 case Map.lookup name cs of
223 case Map.lookup name cs of
194− Just (I.Bin 1 _ ctor _ _) ->
224+ Just (Specific _ ctor) ->
195 Result.ok ctor
225 Result.ok ctor
196
226
197− Just homes ->
227+ Just (Ambiguous h hs) ->
198− Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)
199
229
200 Nothing ->
230 Nothing ->
201 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
231 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -206,11 +236,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
206 case Map.lookup prefix qcs of
236 case Map.lookup prefix qcs of
207 Just qualified ->
237 Just qualified ->
208 case Map.lookup name qualified of
238 case Map.lookup name qualified of
209− Just (I.Bin 1 _ pattern _ _) ->
239+ Just (Specific _ pattern) ->
210 Result.ok pattern
240 Result.ok pattern
211
241
212− Just homes ->
242+ Just (Ambiguous h hs) ->
213− Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
214
244
215 Nothing ->
245 Nothing ->
216 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
246 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -226,11 +256,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
226findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
256findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
227findBinop region (Env _ _ _ _ binops _ _ _) name =
257findBinop region (Env _ _ _ _ binops _ _ _) name =
228 case Map.lookup name binops of
258 case Map.lookup name binops of
229− Just (I.Bin 1 _ binop _ _) ->
259+ Just (Specific _ binop) ->
230 Result.ok binop
260 Result.ok binop
231
261
232− Just homes ->
262+ Just (Ambiguous h hs) ->
233− Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
263+ Result.throw (Error.AmbiguousBinop region name h hs)
234
264
235 Nothing ->
265 Nothing ->
236 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
266 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 OneOrMore.more name (OneOrMore.one (Info region value)) dict
108+ Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
109
109
110
110
111union :: Dict a -> Dict a -> Dict a
111union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+49−37
@@ -35,7 +35,14 @@ 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 Env.Foreign vs) ts cs bs qvs qts qcs)
38+ Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
39+
40+
41+infoToVar :: Env.Info Can.Annotation -> Env.Var
42+infoToVar info =
43+ case info of
44+ Env.Specific home tipe -> Env.Foreign home tipe
45+ Env.Ambiguous h hs -> Env.Foreigns h hs
39
46
40
47
41
48
@@ -61,7 +68,7 @@ emptyState =
61
68
62emptyTypes :: Env.Exposed Env.Type
69emptyTypes :: Env.Exposed Env.Type
63emptyTypes =
70emptyTypes =
64− Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
71+ Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
65
72
66
73
67
74
@@ -102,8 +109,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
102 (Map.mapMaybeWithKey (unionToType home) unions)
109 (Map.mapMaybeWithKey (unionToType home) unions)
103 (Map.mapMaybeWithKey (aliasToType home) aliases)
110 (Map.mapMaybeWithKey (aliasToType home) aliases)
104
111
105− !vars = Map.map (Map.singleton home) defs
112+ !vars = Map.map (Env.Specific home) defs
106− !types = Map.map (Map.singleton home . fst) rawTypeInfo
113+ !types = Map.map (Env.Specific home . fst) rawTypeInfo
107 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
114 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
108
115
109 !qvs2 = addQualified prefix vars qvs
116 !qvs2 = addQualified prefix vars qvs
@@ -129,7 +136,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
129
136
130addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
131addExposed =
138addExposed =
132− Map.unionWith Map.union
139+ Map.unionWith Env.mergeInfo
133
140
134
141
135addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -150,7 +157,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
150unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
157unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
151 let
158 let
152 addCtor dict (Can.Ctor ctor index _ args) =
159 addCtor dict (Can.Ctor ctor index _ args) =
153− Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
160+ Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
154 in
161 in
155 ( Env.Union (length vars) home
162 ( Env.Union (length vars) home
156 , List.foldl' addCtor Map.empty ctors
163 , List.foldl' addCtor Map.empty ctors
@@ -181,7 +188,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
181 (Can.TAlias home name avars (Can.Filled tipe))
188 (Can.TAlias home name avars (Can.Filled tipe))
182 (Can.fieldsToList fields)
189 (Can.fieldsToList fields)
183 in
190 in
184− Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
191+ Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
185
192
186 _ ->
193 _ ->
187 Map.empty
194 Map.empty
@@ -192,9 +199,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
192-- BINOP
199-- BINOP
193
200
194
201
195−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
202+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
196binopToBinop home op (I.Binop name annotation associativity precedence) =
203binopToBinop home op (I.Binop name annotation associativity precedence) =
197− Map.singleton home (Env.Binop op home name annotation associativity precedence)
204+ Env.Specific home (Env.Binop op home name annotation associativity precedence)
198
205
199
206
200
207
@@ -207,19 +214,19 @@ addExposedValue
207 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
214 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
208 -> Map.Map Name.Name I.Binop
215 -> Map.Map Name.Name I.Binop
209 -> State
216 -> State
210− -> A.Located Src.Exposed
217+ -> Src.Exposed
211 -> Result i w State
218 -> Result i w State
212−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
219+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
213 case exposed of
220 case exposed of
214− Src.Lower name ->
221+ Src.Lower (A.At region name) ->
215 case Map.lookup name vars of
222 case Map.lookup name vars of
216 Just info ->
223 Just info ->
217− Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
224+ Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
218
225
219 Nothing ->
226 Nothing ->
220 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
227 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
221
228
222− Src.Upper name privacy ->
229+ Src.Upper (A.At region name) privacy ->
223 case privacy of
230 case privacy of
224 Src.Private ->
231 Src.Private ->
225 case Map.lookup name types of
232 case Map.lookup name types of
@@ -227,43 +234,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg
227 case tipe of
234 case tipe of
228 Env.Union _ _ ->
235 Env.Union _ _ ->
229 let
236 let
230− !ts2 = Map.insert name (Map.singleton home tipe) ts
237+ !ts2 = Map.insert name (Env.Specific home tipe) ts
231 in
238 in
232 Result.ok (State vs ts2 cs bs qvs qts qcs)
239 Result.ok (State vs ts2 cs bs qvs qts qcs)
233
240
234 Env.Alias _ _ _ _ ->
241 Env.Alias _ _ _ _ ->
235 let
242 let
236− !ts2 = Map.insert name (Map.singleton home tipe) ts
243+ !ts2 = Map.insert name (Env.Specific home tipe) ts
237 !cs2 = addExposed cs ctors
244 !cs2 = addExposed cs ctors
238 in
245 in
239 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
246 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
240
247
241 Nothing ->
248 Nothing ->
242− case Map.lookup name (toCtors types) of
249+ case checkForCtorMistake name types of
243− Just tipe ->
250+ tipe:_ ->
244 Result.throw $ Error.ImportCtorByName region name tipe
251 Result.throw $ Error.ImportCtorByName region name tipe
245
252
246− Nothing ->
253+ [] ->
247 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
254 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
248
255
249− Src.Public ->
256+ Src.Public dotDotRegion ->
250 case Map.lookup name types of
257 case Map.lookup name types of
251 Just (tipe, ctors) ->
258 Just (tipe, ctors) ->
252 case tipe of
259 case tipe of
253 Env.Union _ _ ->
260 Env.Union _ _ ->
254 let
261 let
255− !ts2 = Map.insert name (Map.singleton home tipe) ts
262+ !ts2 = Map.insert name (Env.Specific home tipe) ts
256 !cs2 = addExposed cs ctors
263 !cs2 = addExposed cs ctors
257 in
264 in
258 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
265 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
259
266
260 Env.Alias _ _ _ _ ->
267 Env.Alias _ _ _ _ ->
261− Result.throw (Error.ImportOpenAlias region name)
268+ Result.throw (Error.ImportOpenAlias dotDotRegion name)
262
269
263 Nothing ->
270 Nothing ->
264 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
271 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
265
272
266− Src.Operator op ->
273+ Src.Operator region op ->
267 case Map.lookup op binops of
274 case Map.lookup op binops of
268 Just binop ->
275 Just binop ->
269 let
276 let
@@ -275,18 +282,23 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg
275 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
282 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
276
283
277
284
278−
279−toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
285+checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
280−toCtors types =
286+checkForCtorMistake givenName types =
281− Map.foldr addCtors Map.empty types
287+ Map.foldr addMatches [] types
282 where
288 where
283− addCtors (_, exposedCtors) dict =
289+ addMatches (_, exposedCtors) matches =
284− Map.foldrWithKey addCtor dict exposedCtors
290+ Map.foldrWithKey addMatch matches exposedCtors
285−
291+
286− addCtor ctorName homes dict =
292+ addMatch ctorName info matches =
293+ if ctorName /= givenName
294+ then matches
295+ else
287− case Map.elems homes of
296+ case info of
288− [Env.Ctor _ tipeName _ _ _] ->
297+ Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
289− Map.insert ctorName tipeName dict
298+ tipeName : matches
290−
299+
291− _ ->
300+ Env.Specific _ (Env.RecordCtor _ _ _) ->
292− dict
301+ matches
302+
303+ Env.Ambiguous _ _ ->
304+ matches
compiler/src/Canonicalize/Environment/Local.hs+5−5
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs
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 = Map.singleton home (Env.Union arity home)
113+ let one = Env.Specific 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 = Map.singleton home (Env.Alias (length args) home args ctype)
136+ let one = Env.Specific 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 (Map.Map ModuleName.Canonical Env.Ctor)
284+type CtorDups = Dups.Dict (Env.Info 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 (Map.singleton home (toRecordCtor home name vars fields))
300+ Dups.one name region (Env.Specific 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 $ Map.singleton home $
354+ Dups.one name region $ Env.Specific home $
355 Env.Ctor home typeName union index args
355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+6−7
@@ -14,7 +14,6 @@ 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
18import qualified Data.Name as Name
17import qualified Data.Name as Name
19
18
20import qualified AST.Canonical as Can
19import qualified AST.Canonical as Can
@@ -696,15 +695,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
696 Env.TopLevel _ ->
695 Env.TopLevel _ ->
697 logVar name (Can.VarTopLevel localHome name)
696 logVar name (Can.VarTopLevel localHome name)
698
697
699− Env.Foreign (I.Bin 1 home annotation _ _) ->
698+ Env.Foreign home annotation ->
700 Result.ok $
699 Result.ok $
701 if home == ModuleName.debug then
700 if home == ModuleName.debug then
702 Can.VarDebug localHome name annotation
701 Can.VarDebug localHome name annotation
703 else
702 else
704 Can.VarForeign home name annotation
703 Can.VarForeign home name annotation
705
704
706− Env.Foreign homes ->
705+ Env.Foreigns h hs ->
707− Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)
708
707
709 Nothing ->
708 Nothing ->
710 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -715,15 +714,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
715 case Map.lookup prefix qvs of
714 case Map.lookup prefix qvs of
716 Just qualified ->
715 Just qualified ->
717 case Map.lookup name qualified of
716 case Map.lookup name qualified of
718− Just (I.Bin 1 home annotation _ _) ->
717+ Just (Env.Specific home annotation) ->
719 Result.ok $
718 Result.ok $
720 if home == ModuleName.debug then
719 if home == ModuleName.debug then
721 Can.VarDebug localHome name annotation
720 Can.VarDebug localHome name annotation
722 else
721 else
723 Can.VarForeign home name annotation
722 Can.VarForeign home name annotation
724
723
725− Just homes ->
724+ Just (Env.Ambiguous h hs) ->
726− Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
727
726
728 Nothing ->
727 Nothing ->
729 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
728 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− -> A.Located Src.Exposed
239+ -> 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 (A.At region exposed) =
241+checkExposed values unions aliases binops effects exposed =
242 case exposed of
242 case exposed of
243− Src.Lower name ->
243+ Src.Lower (A.At region 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 (A.At region 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 name ->
255+ Src.Operator region 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 name Src.Public ->
262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
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 region name
266+ Result.throw $ Error.ExportOpenAlias dotDotRegion 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 name Src.Private ->
271+ Src.Upper (A.At region 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+3−2
@@ -8,6 +8,7 @@ module Canonicalize.Pattern
8 where
8 where
9
9
10
10
11+import qualified Data.List as List
11import qualified Data.Map.Strict as Map
12import qualified Data.Map.Strict as Map
12import qualified Data.Name as Name
13import qualified Data.Name as Name
13
14
@@ -173,8 +174,8 @@ logVar name region value =
173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
174logFields fields value =
175logFields fields value =
175 let
176 let
176− addField (A.At region name) dict =
177+ addField dict (A.At region name) =
177 Dups.insert name region region dict
178 Dups.insert name region region dict
178 in
179 in
179 Result.Result $ \bindings warnings _ ok ->
180 Result.Result $ \bindings warnings _ ok ->
180− ok (foldr addField bindings fields) warnings value
181+ ok (List.foldl' addField bindings fields) warnings value
compiler/src/Data/Name.hs+60−60
@@ -19,7 +19,6 @@ module Data.Name
19 , isAppendableType
19 , isAppendableType
20 , isCompappendType
20 , isCompappendType
21 , fromVarIndex
21 , fromVarIndex
22− , fromReplCount
23 , fromWords
22 , fromWords
24 , fromManyNames
23 , fromManyNames
25 , fromTypeVariable
24 , fromTypeVariable
@@ -32,7 +31,7 @@ module Data.Name
32 , shader, debug, debugger, bitwise, basics
31 , shader, debug, debugger, bitwise, basics
33 , utils, negate, true, false, value
32 , utils, negate, true, false, value
34 , node, program, _main, _Main, dollar, identity
33 , node, program, _main, _Main, dollar, identity
35− , replModule
34+ , replModule, replValueToPrint
36 )
35 )
37 where
36 where
38
37
@@ -45,19 +44,14 @@ import qualified Data.Coerce as Coerce
45import qualified Data.List as List
44import qualified Data.List as List
46import qualified Data.String as Chars
45import qualified Data.String as Chars
47import qualified Data.Utf8 as Utf8
46import qualified Data.Utf8 as Utf8
48−import Foreign.Ptr (plusPtr, minusPtr)
49import GHC.Exts
47import GHC.Exts
50− ( Int(I#), Ptr(Ptr)
48+ ( Int(I#), Ptr
51− , RealWorld
52 , MutableByteArray#
49 , MutableByteArray#
53 , isTrue#
50 , isTrue#
54 , newByteArray#
51 , newByteArray#
55 , sizeofByteArray#
52 , sizeofByteArray#
56− , writeWord8OffAddr#
57− , copyByteArrayToAddr#
58 , unsafeFreezeByteArray#
53 , unsafeFreezeByteArray#
59 )
54 )
60−import GHC.IO
61import GHC.ST (ST(ST), runST)
55import GHC.ST (ST(ST), runST)
62import GHC.Prim
56import GHC.Prim
63import GHC.Word (Word8(W8#))
57import GHC.Word (Word8(W8#))
@@ -208,11 +202,11 @@ fromVarIndex :: Int -> Name
208fromVarIndex n =
202fromVarIndex n =
209 runST
203 runST
210 (
204 (
211− do let !size = getIndexSize n
205+ do let !size = 2 + getIndexSize n
212 mba <- newByteArray size
206 mba <- newByteArray size
213 writeWord8 mba 0 0x5F {- _ -}
207 writeWord8 mba 0 0x5F {- _ -}
214 writeWord8 mba 1 0x76 {- v -}
208 writeWord8 mba 1 0x76 {- v -}
215− writeDigits mba (size - 1) n
209+ writeDigitsAtEnd mba size n
216 freeze mba
210 freeze mba
217 )
211 )
218
212
@@ -220,19 +214,20 @@ fromVarIndex n =
220{-# INLINE getIndexSize #-}
214{-# INLINE getIndexSize #-}
221getIndexSize :: Int -> Int
215getIndexSize :: Int -> Int
222getIndexSize n
216getIndexSize n
223− | n < 10 = 3
217+ | n < 10 = 1
224− | n < 100 = 4
218+ | n < 100 = 2
225− | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
219+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
226
220
227
221
228
222
229−writeDigits :: MBA s -> Int -> Int -> ST s ()
223+writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
230−writeDigits !mba !offset !n =
224+writeDigitsAtEnd !mba !oldOffset !n =
231 do let (q,r) = quotRem n 10
225 do let (q,r) = quotRem n 10
226+ let !newOffset = oldOffset - 1
232− writeWord8 mba offset (0x30 + fromIntegral r)
227+ writeWord8 mba newOffset (0x30 + fromIntegral r)
233 if q <= 0
228 if q <= 0
234 then return ()
229 then return ()
235− else writeDigits mba (offset-1) q
230+ else writeDigitsAtEnd mba newOffset q
236
231
237
232
238
233
@@ -255,7 +250,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
255 mba <- newByteArray size
250 mba <- newByteArray size
256 copyToMBA name mba
251 copyToMBA name mba
257 writeWord8 mba (I# len#) 0x5F {- _ -}
252 writeWord8 mba (I# len#) 0x5F {- _ -}
258− writeDigits mba (size - 1) index
253+ writeDigitsAtEnd mba size index
259 freeze mba
254 freeze mba
260 )
255 )
261 else
256 else
@@ -264,7 +259,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
264 do let !size = I# len# + getIndexSize index
259 do let !size = I# len# + getIndexSize index
265 mba <- newByteArray size
260 mba <- newByteArray size
266 copyToMBA name mba
261 copyToMBA name mba
267− writeDigits mba (size - 1) index
262+ writeDigitsAtEnd mba size index
268 freeze mba
263 freeze mba
269 )
264 )
270
265
@@ -283,61 +278,61 @@ fromTypeVariableScheme scheme =
283 freeze mba
278 freeze mba
284 else
279 else
285 do let (extra, letter) = quotRem scheme 26
280 do let (extra, letter) = quotRem scheme 26
286− let !size = getIndexSize extra
281+ let !size = 1 + getIndexSize extra
287 mba <- newByteArray size
282 mba <- newByteArray size
288 writeWord8 mba 0 (0x61 + fromIntegral letter)
283 writeWord8 mba 0 (0x61 + fromIntegral letter)
289− writeDigits mba (size - 1) extra
284+ writeDigitsAtEnd mba size extra
290 freeze mba
285 freeze mba
291 )
286 )
292
287
293
288
294
289
295−-- FROM REPL COUNT
296−
297−
298−fromReplCount :: Int -> Name
299−fromReplCount n =
300− Utf8.fromChars ("repl_value_" ++ show n)
301−
302−
303−
304-- FROM MANY NAMES
290-- FROM MANY NAMES
291+--
292+-- Creating a unique name by combining all the subnames can create names
293+-- longer than 256 bytes relatively easily. So instead, the first given name
294+-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295+--
296+-- This should be a unique name since 0.19 disallows shadowing. It would not
297+-- be possible for multiple top-level cycles to include values with the same
298+-- name, so the important thing is to make the cycle name distinct from the
299+-- normal name. Same logic for destructuring patterns like (x,y)
305
300
306
301
307fromManyNames :: [Name] -> Name
302fromManyNames :: [Name] -> Name
308fromManyNames names =
303fromManyNames names =
309− let
310− !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
311− in
312− runST
313− (
314− ST $ \s ->
315− case newByteArray# size# s of
316− (# s, mba# #) ->
317− case writeNames mba# 0# names s of
318− s ->
319− case unsafeFreezeByteArray# mba# s of
320− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
321− )
322−
323−
324−writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
325−writeNames mba# !offset# names s =
326 case names of
304 case names of
327 [] ->
305 [] ->
328− s
306+ blank
329−
307+ -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)
308+ -- but maybe unused patterns should be stripped out instead
309+
330− (Utf8.Utf8 ba#) : names ->
310+ Utf8.Utf8 ba# : _ ->
331− case writeWord8Array# mba# offset# 0x24## {- $ -} s of
311+ let
332− s ->
333− let
334− !offset1# = offset# +# 1#
335− !len# = sizeofByteArray# ba#
312+ len# = sizeofByteArray# ba#
336− !newOffset# = offset1# +# len#
313+ in
337− in
314+ runST
338− case copyByteArray# ba# 0# mba# offset1# len# s of
315+ (
316+ ST $ \s ->
317+ case newByteArray# (len# +# 3#) s of
339− s ->
318+ (# s, mba# #) ->
340− writeNames mba# newOffset# names 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
328+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329+ )
330+
331+
332+{-# NOINLINE blank #-}
333+blank :: Name
334+blank =
335+ fromWords [0x5F,0x4D,0x24] {-_M$-}
341
336
342
337
343
338
@@ -608,3 +603,8 @@ identity = fromChars "identity"
608{-# NOINLINE replModule #-}
603{-# NOINLINE replModule #-}
609replModule :: Name
604replModule :: Name
610replModule = fromChars "Elm_Repl"
605replModule = fromChars "Elm_Repl"
606+
607+
608+{-# NOINLINE replValueToPrint #-}
609+replValueToPrint :: Name
610+replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hs+6−2
@@ -52,8 +52,12 @@ instance Foldable List where
52-- SORT BY
52-- SORT BY
53
53
54
54
55−sortBy :: (a -> a -> Ordering) -> List a -> List a
55+sortBy :: (Ord b) => (a -> b) -> List a -> List a
56−sortBy comparison (List x xs) =
56+sortBy toRank (List x xs) =
57+ let
58+ comparison a b =
59+ compare (toRank a) (toRank b)
60+ in
57 case List.sortBy comparison xs of
61 case List.sortBy comparison xs of
58 [] ->
62 [] ->
59 List x []
63 List x []
compiler/src/Data/Utf8.hs+6−4
@@ -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#), Word16(W16#))
66+import GHC.Word (Word8(W8#))
67
67
68import qualified Parse.Primitives as P
68import qualified Parse.Primitives as P
69
69
@@ -261,7 +261,9 @@ 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+--
265
267
266instance Ord (Utf8 t) where
268instance Ord (Utf8 t) where
267 compare (Utf8 ba1#) (Utf8 ba2#) =
269 compare (Utf8 ba1#) (Utf8 ba2#) =
@@ -455,7 +457,7 @@ toEscapedBuilderHelp before after !name@(Utf8 ba#) k =
455 !bLen = minusPtr bEnd bOffset
457 !bLen = minusPtr bEnd bOffset
456 in
458 in
457 if len <= bLen then
459 if len <= bLen then
458− do -- TODO test if writing word-by-word is faster
460+ do -- PERF test if writing word-by-word is faster
459 copyToPtr name offset bOffset len
461 copyToPtr name offset bOffset len
460 escape before after bOffset name offset len 0
462 escape before after bOffset name offset len 0
461 let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
463 let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
@@ -565,7 +567,7 @@ data MBA s =
565 MBA# (MutableByteArray# s)
567 MBA# (MutableByteArray# s)
566
568
567
569
568−newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
569newByteArray (I# len#) =
571newByteArray (I# len#) =
570 ST $ \s ->
572 ST $ \s ->
571 case newByteArray# len# s of
573 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 [ A.At A.zero (Src.Upper name Src.Public) ]
52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
53
53
54
54
55typeClosed :: Name.Name -> Src.Exposing
55typeClosed :: Name.Name -> Src.Exposing
56typeClosed name =
56typeClosed name =
57− Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
58
58
59
59
60operator :: Name.Name -> Src.Exposing
60operator :: Name.Name -> Src.Exposing
61operator op =
61operator op =
62− Src.Explicit [ A.At A.zero (Src.Operator op) ]
62+ Src.Explicit [ Src.Operator A.zero 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− -- TODO profile Opt.Global representation
90+ -- PERF 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− _ -> error "binary encoding of Op was corrupted"
219+ _ -> fail "binary encoding of Op was corrupted"
220
220
221
221
222
222
compiler/src/Elm/Docs.hs+4−4
@@ -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.Export
349+ P.oneOf E.Name
350− [ Var.lower E.Export
350+ [ Var.lower E.Name
351− , Var.upper E.Export
351+ , Var.upper E.Name
352 , chompOperator
352 , chompOperator
353 ]
353 ]
354
354
@@ -404,7 +404,7 @@ untilDocs pos end row col =
404 then
404 then
405 (# True, pos5, row, col + 5 #)
405 (# True, pos5, row, col + 5 #)
406 else
406 else
407− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
407+ let !newPos = plusPtr pos (P.getCharWidth word) in
408 untilDocs newPos end row (col + 1)
408 untilDocs newPos end row (col + 1)
409
409
410
410
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− _ -> error "binary encoding of Union was corrupted"
218+ _ -> fail "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− _ -> error "binary encoding of Alias was corrupted"
232+ _ -> fail "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− _ -> error "binary encoding of DependencyInterface was corrupted"
254+ _ -> fail "binary encoding of DependencyInterface was corrupted"
compiler/src/Elm/Kernel.hs+10−10
@@ -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, Word16)
18+import Data.Word (Word8)
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 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
131+chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
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
@@ -152,7 +152,7 @@ chompChunks vs es fs src pos end row col lastPos revChunks =
152
152
153 else
153 else
154 let
154 let
155− !newPos = plusPtr pos (getCharWidth pos end word)
155+ !newPos = plusPtr pos (getCharWidth word)
156 in
156 in
157 chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
157 chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
158
158
@@ -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 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
171+chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
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 :: A.Located Src.Exposed -> Name.Name
322+toName :: Src.Exposed -> Name.Name
323−toName (A.At _ exposed) =
323+toName exposed =
324 case exposed of
324 case exposed of
325− Src.Lower name ->
325+ Src.Lower (A.At _ name) ->
326 name
326 name
327
327
328− Src.Upper name Src.Private ->
328+ Src.Upper (A.At _ 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,63 +83,61 @@ 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"
86− [ "AFL-1.1" ==> "Academic Free License v1.1"
88+ , "AFL-1.1" ==> "Academic Free License v1.1"
87 , "AFL-1.2" ==> "Academic Free License v1.2"
89 , "AFL-1.2" ==> "Academic Free License v1.2"
88 , "AFL-2.0" ==> "Academic Free License v2.0"
90 , "AFL-2.0" ==> "Academic Free License v2.0"
89 , "AFL-2.1" ==> "Academic Free License v2.1"
91 , "AFL-2.1" ==> "Academic Free License v2.1"
90 , "AFL-3.0" ==> "Academic Free License v3.0"
92 , "AFL-3.0" ==> "Academic Free License v3.0"
91− , "APL-1.0" ==> "Adaptive Public License 1.0"
93+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
92 , "Apache-1.1" ==> "Apache License 1.1"
94 , "Apache-1.1" ==> "Apache License 1.1"
93 , "Apache-2.0" ==> "Apache License 2.0"
95 , "Apache-2.0" ==> "Apache License 2.0"
96+ , "APL-1.0" ==> "Adaptive Public License 1.0"
94 , "APSL-1.0" ==> "Apple Public Source License 1.0"
97 , "APSL-1.0" ==> "Apple Public Source License 1.0"
95 , "APSL-1.1" ==> "Apple Public Source License 1.1"
98 , "APSL-1.1" ==> "Apple Public Source License 1.1"
96 , "APSL-1.2" ==> "Apple Public Source License 1.2"
99 , "APSL-1.2" ==> "Apple Public Source License 1.2"
97 , "APSL-2.0" ==> "Apple Public Source License 2.0"
100 , "APSL-2.0" ==> "Apple Public Source License 2.0"
98 , "Artistic-1.0" ==> "Artistic License 1.0"
101 , "Artistic-1.0" ==> "Artistic License 1.0"
99− , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
100 , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
102 , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
103+ , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
101 , "Artistic-2.0" ==> "Artistic License 2.0"
104 , "Artistic-2.0" ==> "Artistic License 2.0"
102− , "AAL" ==> "Attribution Assurance License"
103− , "BSL-1.0" ==> "Boost Software License 1.0"
104 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
105 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
106− , "0BSD" ==> "BSD Zero Clause License"
107+ , "BSL-1.0" ==> "Boost Software License 1.0"
108+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
107 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
108 , "CNRI-Python" ==> "CNRI Python License"
111 , "CNRI-Python" ==> "CNRI Python License"
109− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
110 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
111 , "CPL-1.0" ==> "Common Public License 1.0"
113 , "CPL-1.0" ==> "Common Public License 1.0"
112− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
113 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
114 , "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"
120 , "EUDatagrid" ==> "EU DataGrid Software License"
121 , "EUDatagrid" ==> "EU DataGrid Software License"
121 , "EUPL-1.1" ==> "European Union Public License 1.1"
122 , "EUPL-1.1" ==> "European Union Public License 1.1"
122 , "Fair" ==> "Fair License"
123 , "Fair" ==> "Fair License"
123 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
124 , "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"
130 , "HPND" ==> "Historic Permission Notice and Disclaimer"
127 , "HPND" ==> "Historic Permission Notice and Disclaimer"
131− , "IPL-1.0" ==> "IBM Public License v1.0"
132 , "Intel" ==> "Intel Open Source License"
128 , "Intel" ==> "Intel Open Source License"
133 , "IPA" ==> "IPA Font License"
129 , "IPA" ==> "IPA Font License"
130+ , "IPL-1.0" ==> "IBM Public License v1.0"
134 , "ISC" ==> "ISC License"
131 , "ISC" ==> "ISC License"
135− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
132+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
133+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
136 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
137− , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
138 , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
136 , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
139− , "LPL-1.02" ==> "Lucent Public License v1.02"
137+ , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
140 , "LPL-1.0" ==> "Lucent Public License Version 1.0"
138 , "LPL-1.0" ==> "Lucent Public License Version 1.0"
141− , "MS-PL" ==> "Microsoft Public License"
139+ , "LPL-1.02" ==> "Lucent Public License v1.02"
142− , "MS-RL" ==> "Microsoft Reciprocal License"
140+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
143 , "MirOS" ==> "MirOS Licence"
141 , "MirOS" ==> "MirOS Licence"
144 , "MIT" ==> "MIT License"
142 , "MIT" ==> "MIT License"
145 , "Motosoto" ==> "Motosoto License"
143 , "Motosoto" ==> "Motosoto License"
@@ -147,38 +145,40 @@ osiApprovedSpdxLicenses =
147 , "MPL-1.1" ==> "Mozilla Public License 1.1"
145 , "MPL-1.1" ==> "Mozilla Public License 1.1"
148 , "MPL-2.0" ==> "Mozilla Public License 2.0"
146 , "MPL-2.0" ==> "Mozilla Public License 2.0"
149 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
147 , "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"
153 , "NGPL" ==> "Nethack General Public License"
154 , "NGPL" ==> "Nethack General Public License"
154 , "Nokia" ==> "Nokia Open Source License"
155 , "Nokia" ==> "Nokia Open Source License"
155 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
156 , "NTP" ==> "NTP License"
157 , "NTP" ==> "NTP License"
157 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
158 , "OGTSL" ==> "Open Group Test Suite License"
160 , "OGTSL" ==> "Open Group Test Suite License"
161+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
159 , "OSL-1.0" ==> "Open Software License 1.0"
162 , "OSL-1.0" ==> "Open Software License 1.0"
160 , "OSL-2.0" ==> "Open Software License 2.0"
163 , "OSL-2.0" ==> "Open Software License 2.0"
161 , "OSL-2.1" ==> "Open Software License 2.1"
164 , "OSL-2.1" ==> "Open Software License 2.1"
162 , "OSL-3.0" ==> "Open Software License 3.0"
165 , "OSL-3.0" ==> "Open Software License 3.0"
163− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
164 , "PHP-3.0" ==> "PHP License v3.0"
166 , "PHP-3.0" ==> "PHP License v3.0"
165 , "PostgreSQL" ==> "PostgreSQL License"
167 , "PostgreSQL" ==> "PostgreSQL License"
166 , "Python-2.0" ==> "Python License 2.0"
168 , "Python-2.0" ==> "Python License 2.0"
167 , "QPL-1.0" ==> "Q Public License 1.0"
169 , "QPL-1.0" ==> "Q Public License 1.0"
168− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
169 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
170 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
171 , "RSCPL" ==> "Ricoh Source Code Public License"
173 , "RSCPL" ==> "Ricoh Source Code Public License"
172− , "OFL-1.1" ==> "SIL Open Font License 1.1"
173 , "SimPL-2.0" ==> "Simple Public License 2.0"
174 , "SimPL-2.0" ==> "Simple Public License 2.0"
174− , "Sleepycat" ==> "Sleepycat License"
175 , "SISSL" ==> "Sun Industry Standards Source License v1.1"
175 , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176+ , "Sleepycat" ==> "Sleepycat License"
176 , "SPL-1.0" ==> "Sun Public License v1.0"
177 , "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"
180 , "VSL-1.0" ==> "Vovida Software License v1.0"
179 , "VSL-1.0" ==> "Vovida Software License v1.0"
181 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
180 , "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+2−7
@@ -7,12 +7,13 @@ module Elm.ModuleName
7 --
7 --
8 , encode
8 , encode
9 , decoder
9 , decoder
10+ , parser
10 --
11 --
11 , Canonical(..)
12 , Canonical(..)
12 , basics, char, string
13 , basics, char, string
13 , maybe, result, list, array, dict, tuple
14 , maybe, result, list, array, dict, tuple
14 , platform, cmd, sub
15 , platform, cmd, sub
15− , debug, bitwise
16+ , debug
16 , virtualDom
17 , virtualDom
17 , jsonDecode, jsonEncode
18 , jsonDecode, jsonEncode
18 , webgl, texture, vector2, vector3, vector4, matrix4
19 , webgl, texture, vector2, vector3, vector4, matrix4
@@ -22,7 +23,6 @@ module Elm.ModuleName
22
23
23import Control.Monad (liftM2)
24import Control.Monad (liftM2)
24import Data.Binary (Binary(..))
25import 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,11 +226,6 @@ 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−
234
229
235-- HTML
230-- HTML
236
231
compiler/src/Elm/Package.hs+5−15
@@ -31,7 +31,6 @@ 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)
35import qualified Data.List as List
34import qualified Data.List as List
36import qualified Data.Map as Map
35import qualified Data.Map as Map
37import qualified Data.Name as Name
36import qualified Data.Name as Name
@@ -59,6 +58,7 @@ data Name =
59 { _author :: !Author
58 { _author :: !Author
60 , _project :: !Project
59 , _project :: !Project
61 }
60 }
61+ deriving (Ord)
62
62
63
63
64type Author = Utf8.Utf8 AUTHOR
64type Author = Utf8.Utf8 AUTHOR
@@ -236,12 +236,10 @@ 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− addDistance name@(Name author2 project2) =
239+ nameDistance (Name author2 project2) =
240− ( authorDist author2 + projectDist project2, name )
240+ authorDist author2 + projectDist project2
241 in
241 in
242− map snd $ take 4 $
242+ take 4 $ List.sortOn nameDistance possibleNames
243− List.sortBy (compare `on` fst) $
244− map addDistance possibleNames
245
243
246
244
247authorDistance :: [Char] -> Author -> Int
245authorDistance :: [Char] -> Author -> Int
@@ -270,19 +268,11 @@ instance Eq Canonical where
270 version1 == version2 && package1 == package2
268 version1 == version2 && package1 == package2
271
269
272
270
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−
281
271
282-- BINARY
272-- BINARY
283
273
284
274
285−instance Binary Name where -- TODO try storing as a Word16
275+instance Binary Name where -- PERF try storing as a Word16
286 get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
276 get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
287 put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
277 put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
288
278
compiler/src/Elm/String.hs−1
@@ -108,7 +108,6 @@ 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
112writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
111writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
113writeCode mba offset code =
112writeCode mba offset code =
114 do writeWord8 mba offset 0x5C {- \ -}
113 do writeWord8 mba offset 0x5C {- \ -}
compiler/src/Generate/Html.hs+11−10
@@ -29,22 +29,23 @@ sandwich moduleName javascript =
29
29
30<body>
30<body>
31
31
32−<pre id="elm">
32+<pre id="elm"></pre>
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>
39
33
40<script>
34<script>
35+try {
41|] <> javascript <> [r|
36|] <> javascript <> [r|
42
37
43−try {
44 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
38 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
39+}
45−} catch (e) {
40+catch (e)
41+{
46 // display initialization errors (e.g. bad flags, infinite recursion)
42 // 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";
47− document.getElementById("elm").innerText = e;
46+ var pre = document.getElementById("elm");
47+ document.body.insertBefore(header, pre);
48+ pre.innerText = e;
48 throw e;
49 throw e;
49}
50}
50</script>
51</script>
compiler/src/Generate/JavaScript.hs+51−19
@@ -2,6 +2,7 @@
2module Generate.JavaScript
2module Generate.JavaScript
3 ( generate
3 ( generate
4 , generateForRepl
4 , generateForRepl
5+ , generateForReplEndpoint
5 )
6 )
6 where
7 where
7
8
@@ -85,7 +86,9 @@ generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _
85 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
86 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
86 evalState = addGlobal mode graph debugState (Opt.Global home name)
87 evalState = addGlobal mode graph debugState (Opt.Global home name)
87 in
88 in
89+ "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90+ <> Functions.functions
88− stateToBuilder evalState
91+ <> stateToBuilder evalState
89 <> print ansi localizer home name tipe
92 <> print ansi localizer home name tipe
90
93
91
94
@@ -97,14 +100,47 @@ print ansi localizer home name tipe =
97 tipeDoc = RT.canToDoc localizer RT.None tipe
100 tipeDoc = RT.canToDoc localizer RT.None tipe
98 bool = if ansi then "true" else "false"
101 bool = if ansi then "true" else "false"
99 in
102 in
100− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
103+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
101− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
104+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
102− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
105+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
103− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
106+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
104− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
107+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
105− \} else {\n\
108+ \} else {\n\
106− \ _print(' : ' + _type);\n\
109+ \ _print(' : ' + _type);\n\
110+ \}\n"
111+
112+
113+
114+-- GENERATE FOR REPL ENDPOINT
115+
116+
117+generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118+generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119+ let
120+ name = maybe Name.replValueToPrint id maybeName
121+ mode = Mode.Dev Nothing
122+ debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
123+ evalState = addGlobal mode graph debugState (Opt.Global home name)
124+ in
125+ Functions.functions
126+ <> stateToBuilder evalState
127+ <> postMessage localizer home maybeName tipe
128+
129+
130+postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131+postMessage localizer home maybeName tipe =
132+ let
133+ name = maybe Name.replValueToPrint id maybeName
134+ value = JsName.toBuilder (JsName.fromGlobal home name)
135+ toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136+ tipeDoc = RT.canToDoc localizer RT.None tipe
137+ toName n = "\"" <> Name.toBuilder n <> "\""
138+ in
139+ "self.postMessage({\n\
140+ \ name: " <> maybe "null" toName maybeName <> ",\n\
141+ \ value: " <> toString <> "(true, " <> value <> "),\n\
142+ \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
107− \}\n"
143+ \});\n"
108
144
109
145
110
146
@@ -256,7 +292,7 @@ generateCycle mode (Opt.Global home _) names values functions =
256 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
257 <> drawCycle names
293 <> drawCycle names
258 <> "\\n\\nThese errors are very tricky, so read "
294 <> "\\n\\nThese errors are very tricky, so read "
259− <> B.stringUtf8 (D.makeNakedLink "halting-problem")
295+ <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
260 <> " to learn how to fix it!"
296 <> " to learn how to fix it!"
261 ]
297 ]
262
298
@@ -314,7 +350,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
314addChunk mode chunk builder =
350addChunk mode chunk builder =
315 case chunk of
351 case chunk of
316 K.JS javascript ->
352 K.JS javascript ->
317− Utf8.toBuilder javascript <> builder
353+ B.byteString javascript <> builder
318
354
319 K.ElmVar home name ->
355 K.ElmVar home name ->
320 JsName.toBuilder (JsName.fromGlobal home name) <> builder
356 JsName.toBuilder (JsName.fromGlobal home name) <> builder
@@ -498,7 +534,7 @@ generateExports mode (Trie maybeMain subs) =
498 <> List.foldl' (addSubTrie mode) "}" otherSubTries
534 <> List.foldl' (addSubTrie mode) "}" otherSubTries
499
535
500
536
501−addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
537+addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
502addSubTrie mode end (name, trie) =
538addSubTrie mode end (name, trie) =
503 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
504
540
@@ -510,7 +546,7 @@ addSubTrie mode end (name, trie) =
510data Trie =
546data Trie =
511 Trie
547 Trie
512 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
513− , _subs :: Map.Map Utf8.String Trie
549+ , _subs :: Map.Map Name.Name Trie
514 }
550 }
515
551
516
552
@@ -521,14 +557,10 @@ emptyTrie =
521
557
522addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
523addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
524− let
525− segments =
526− Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
527− in
528− merge trie $ segmentsToTrie home segments main
560+ merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
529
561
530
562
531−segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
563+segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
532segmentsToTrie home segments main =
564segmentsToTrie home segments main =
533 case segments of
565 case segments of
534 [] ->
566 [] ->
compiler/src/Generate/JavaScript/Builder.hs+13
@@ -28,6 +28,19 @@ import qualified Json.Encode as Json
28-- EXPRESSIONS
28-- EXPRESSIONS
29
29
30
30
31+-- NOTE: I tried making this create a B.Builder directly.
32+--
33+-- The hope was that it'd allocate less and speed things up, but it seemed
34+-- to be neutral for perf.
35+--
36+-- The downside is that Generate.JavaScript.Expression inspects the
37+-- structure of Expr and Stmt on some occassions to try to strip out
38+-- unnecessary closures. I think these closures are already avoided
39+-- by other logic in code gen these days, but I am not 100% certain.
40+--
41+-- For this to be worth it, I think it would be necessary to avoid
42+-- returning tuples when generating expressions.
43+--
31data Expr
44data Expr
32 = String Builder
45 = String Builder
33 | Float Builder
46 | Float Builder
compiler/src/Generate/JavaScript/Expression.hs+5−3
@@ -22,6 +22,7 @@ import qualified Data.Utf8 as Utf8
22
22
23import qualified AST.Canonical as Can
23import qualified AST.Canonical as Can
24import qualified AST.Optimized as Opt
24import qualified AST.Optimized as Opt
25+import qualified AST.Utils.Shader as Shader
25import qualified Data.Index as Index
26import qualified Data.Index as Index
26import qualified Elm.Compiler.Type as Type
27import qualified Elm.Compiler.Type as Type
27import qualified Elm.Compiler.Type.Extract as Extract
28import qualified Elm.Compiler.Type.Extract as Extract
@@ -32,6 +33,7 @@ import qualified Generate.JavaScript.Builder as JS
32import qualified Generate.JavaScript.Name as JsName
33import qualified Generate.JavaScript.Name as JsName
33import qualified Generate.Mode as Mode
34import qualified Generate.Mode as Mode
34import qualified Json.Encode as Encode
35import qualified Json.Encode as Encode
36+import Json.Encode ((==>))
35import qualified Optimize.DecisionTree as DT
37import qualified Optimize.DecisionTree as DT
36import qualified Reporting.Annotation as A
38import qualified Reporting.Annotation as A
37
39
@@ -189,7 +191,7 @@ generate mode expression =
189 JS.Object (map toTranlation (Set.toList fields))
191 JS.Object (map toTranlation (Set.toList fields))
190 in
192 in
191 JsExpr $ JS.Object $
193 JsExpr $ JS.Object $
192− [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
194+ [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
193 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
194 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
195 ]
197 ]
@@ -1063,6 +1065,6 @@ toDebugMetadata mode msgType =
1063
1065
1064 Mode.Dev (Just interfaces) ->
1066 Mode.Dev (Just interfaces) ->
1065 JS.Json $ Encode.object $
1067 JS.Json $ Encode.object $
1066− [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1068+ [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1067− , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
1069+ , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
1068 ]
1070 ]
compiler/src/Generate/JavaScript/Name.hs+22−12
@@ -62,19 +62,13 @@ fromLocal name =
62
62
63
63
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
65−fromGlobal (ModuleName.Canonical (Pkg.Name author project) home) name =
65+fromGlobal home name =
66− Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
67− <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
68− <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
69− <> "$" <> Name.toBuilder name
66+ Name $ homeToBuilder home <> usd <> Name.toBuilder name
70
67
71
68
72fromCycle :: ModuleName.Canonical -> Name.Name -> Name
69fromCycle :: ModuleName.Canonical -> Name.Name -> Name
73−fromCycle (ModuleName.Canonical (Pkg.Name author project) home) name =
70+fromCycle home name =
74− Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
75− <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
76− <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
77− <> "$cyclic$" <> Name.toBuilder name
71+ Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name
78
72
79
73
80fromKernel :: Name.Name -> Name.Name -> Name
74fromKernel :: Name.Name -> Name.Name -> Name
@@ -82,6 +76,17 @@ fromKernel home name =
82 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
76 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
83
77
84
78
79+{-# INLINE homeToBuilder #-}
80+homeToBuilder :: ModuleName.Canonical -> B.Builder
81+homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =
82+ usd <>
83+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
84+ <> usd <>
85+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
86+ <> usd <>
87+ Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
88+
89+
85
90
86-- TEMPORARY NAMES
91-- TEMPORARY NAMES
87
92
@@ -98,7 +103,7 @@ makeA n =
98
103
99makeLabel :: Name.Name -> Int -> Name
104makeLabel :: Name.Name -> Int -> Name
100makeLabel name index =
105makeLabel name index =
101− Name (Name.toBuilder name <> "$" <> B.intDec index)
106+ Name (Name.toBuilder name <> usd <> B.intDec index)
102
107
103
108
104makeTemp :: Name.Name -> Name
109makeTemp :: Name.Name -> Name
@@ -108,7 +113,12 @@ makeTemp name =
108
113
109dollar :: Name
114dollar :: Name
110dollar =
115dollar =
116+ Name usd
117+
118+
119+usd :: B.Builder
120+usd =
111− Name (Name.toBuilder Name.dollar)
121+ Name.toBuilder Name.dollar
112
122
113
123
114
124
compiler/src/Generate/Mode.hs−1
@@ -49,7 +49,6 @@ 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
53 Map.insertWith (++) frequency [field] buckets
52 Map.insertWith (++) frequency [field] buckets
54
53
55
54
compiler/src/Json/Decode.hs+78−73
@@ -24,6 +24,7 @@ module Json.Decode
24 , Problem(..)
24 , Problem(..)
25 , DecodeExpectation(..)
25 , DecodeExpectation(..)
26 , ParseError(..)
26 , ParseError(..)
27+ , StringProblem(..)
27 )
28 )
28 where
29 where
29
30
@@ -31,7 +32,7 @@ module Json.Decode
31import qualified Data.ByteString.Internal as B
32import qualified Data.ByteString.Internal as B
32import qualified Data.Map as Map
33import qualified Data.Map as Map
33import qualified Data.NonEmptyList as NE
34import qualified Data.NonEmptyList as NE
34−import Data.Word (Word8, Word16)
35+import Data.Word (Word8)
35import Foreign.Ptr (Ptr, plusPtr, minusPtr)
36import Foreign.Ptr (Ptr, plusPtr, minusPtr)
36import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
37import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
37
38
@@ -39,6 +40,7 @@ import qualified Json.String as Json
39import qualified Parse.Keyword as K
40import qualified Parse.Keyword as K
40import qualified Parse.Primitives as P
41import qualified Parse.Primitives as P
41import Parse.Primitives (Row, Col)
42import Parse.Primitives (Row, Col)
43+import qualified Reporting.Annotation as A
42
44
43
45
44
46
@@ -49,10 +51,10 @@ fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
49fromByteString (Decoder decode) src =
51fromByteString (Decoder decode) src =
50 case P.fromByteString pFile BadEnd src of
52 case P.fromByteString pFile BadEnd src of
51 Right ast ->
53 Right ast ->
52− decode ast Right (Left . DecodeProblem)
54+ decode ast Right (Left . DecodeProblem src)
53
55
54 Left problem ->
56 Left problem ->
55− Left (ParseProblem problem)
57+ Left (ParseProblem src problem)
56
58
57
59
58
60
@@ -75,8 +77,8 @@ newtype Decoder x a =
75
77
76
78
77data Error x
79data Error x
78− = DecodeProblem (Problem x)
80+ = DecodeProblem B.ByteString (Problem x)
79− | ParseProblem ParseError
81+ | ParseProblem B.ByteString ParseError
80
82
81
83
82
84
@@ -87,8 +89,8 @@ data Problem x
87 = Field B.ByteString (Problem x)
89 = Field B.ByteString (Problem x)
88 | Index Int (Problem x)
90 | Index Int (Problem x)
89 | OneOf (Problem x) [Problem x]
91 | OneOf (Problem x) [Problem x]
90− | Failure x
92+ | Failure A.Region x
91− | Expecting DecodeExpectation
93+ | Expecting A.Region DecodeExpectation
92
94
93
95
94data DecodeExpectation
96data DecodeExpectation
@@ -155,26 +157,26 @@ instance Monad (Decoder x) where
155
157
156string :: Decoder x Json.String
158string :: Decoder x Json.String
157string =
159string =
158− Decoder $ \ast ok err ->
160+ Decoder $ \(A.At region ast) ok err ->
159 case ast of
161 case ast of
160 String snippet ->
162 String snippet ->
161 ok (Json.fromSnippet snippet)
163 ok (Json.fromSnippet snippet)
162
164
163 _ ->
165 _ ->
164− err (Expecting TString)
166+ err (Expecting region TString)
165
167
166
168
167customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
169customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
168customString parser toBadEnd =
170customString parser toBadEnd =
169− Decoder $ \ast ok err ->
171+ Decoder $ \(A.At region ast) ok err ->
170 case ast of
172 case ast of
171 String snippet ->
173 String snippet ->
172 case P.fromSnippet parser toBadEnd snippet of
174 case P.fromSnippet parser toBadEnd snippet of
173 Right a -> ok a
175 Right a -> ok a
174− Left x -> err (Failure x)
176+ Left x -> err (Failure region x)
175
177
176 _ ->
178 _ ->
177− err (Expecting TString)
179+ err (Expecting region TString)
178
180
179
181
180
182
@@ -183,7 +185,7 @@ customString parser toBadEnd =
183
185
184bool :: Decoder x Bool
186bool :: Decoder x Bool
185bool =
187bool =
186− Decoder $ \ast ok err ->
188+ Decoder $ \(A.At region ast) ok err ->
187 case ast of
189 case ast of
188 TRUE ->
190 TRUE ->
189 ok True
191 ok True
@@ -192,7 +194,7 @@ bool =
192 ok False
194 ok False
193
195
194 _ ->
196 _ ->
195− err (Expecting TBool)
197+ err (Expecting region TBool)
196
198
197
199
198
200
@@ -201,13 +203,13 @@ bool =
201
203
202int :: Decoder x Int
204int :: Decoder x Int
203int =
205int =
204− Decoder $ \ast ok err ->
206+ Decoder $ \(A.At region ast) ok err ->
205 case ast of
207 case ast of
206 Int n ->
208 Int n ->
207 ok n
209 ok n
208
210
209 _ ->
211 _ ->
210− err (Expecting TInt)
212+ err (Expecting region TInt)
211
213
212
214
213
215
@@ -216,13 +218,13 @@ int =
216
218
217list :: Decoder x a -> Decoder x [a]
219list :: Decoder x a -> Decoder x [a]
218list decoder =
220list decoder =
219− Decoder $ \ast ok err ->
221+ Decoder $ \(A.At region ast) ok err ->
220 case ast of
222 case ast of
221 Array asts ->
223 Array asts ->
222 listHelp decoder ok err 0 asts []
224 listHelp decoder ok err 0 asts []
223
225
224 _ ->
226 _ ->
225− err (Expecting TArray)
227+ err (Expecting region TArray)
226
228
227
229
228listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
230listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
@@ -257,7 +259,7 @@ nonEmptyList decoder x =
257
259
258pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
260pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
259pair (Decoder decodeA) (Decoder decodeB) =
261pair (Decoder decodeA) (Decoder decodeB) =
260− Decoder $ \ast ok err ->
262+ Decoder $ \(A.At region ast) ok err ->
261 case ast of
263 case ast of
262 Array vs ->
264 Array vs ->
263 case vs of
265 case vs of
@@ -274,10 +276,10 @@ pair (Decoder decodeA) (Decoder decodeB) =
274 decodeA astA ok0 err0
276 decodeA astA ok0 err0
275
277
276 _ ->
278 _ ->
277− err (Expecting (TArrayPair (length vs)))
279+ err (Expecting region (TArrayPair (length vs)))
278
280
279 _ ->
281 _ ->
280− err (Expecting TArray)
282+ err (Expecting region TArray)
281
283
282
284
283
285
@@ -295,13 +297,13 @@ dict keyDecoder valueDecoder =
295
297
296pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
298pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
297pairs keyDecoder valueDecoder =
299pairs keyDecoder valueDecoder =
298− Decoder $ \ast ok err ->
300+ Decoder $ \(A.At region ast) ok err ->
299 case ast of
301 case ast of
300 Object kvs ->
302 Object kvs ->
301 pairsHelp keyDecoder valueDecoder ok err kvs []
303 pairsHelp keyDecoder valueDecoder ok err kvs []
302
304
303 _ ->
305 _ ->
304− err (Expecting TObject)
306+ err (Expecting region TObject)
305
307
306
308
307pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
309pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
@@ -313,7 +315,7 @@ pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decod
313 (snippet, ast) : kvs ->
315 (snippet, ast) : kvs ->
314 case P.fromSnippet keyParser toBadEnd snippet of
316 case P.fromSnippet keyParser toBadEnd snippet of
315 Left x ->
317 Left x ->
316− err (Failure x)
318+ err (Failure (snippetToRegion snippet) x)
317
319
318 Right key ->
320 Right key ->
319 let
321 let
@@ -325,13 +327,18 @@ pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decod
325 decodeA ast ok' err'
327 decodeA ast ok' err'
326
328
327
329
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+
328
335
329-- FIELDS
336-- FIELDS
330
337
331
338
332field :: B.ByteString -> Decoder x a -> Decoder x a
339field :: B.ByteString -> Decoder x a -> Decoder x a
333field key (Decoder decodeA) =
340field key (Decoder decodeA) =
334− Decoder $ \ast ok err ->
341+ Decoder $ \(A.At region ast) ok err ->
335 case ast of
342 case ast of
336 Object kvs ->
343 Object kvs ->
337 case findField key kvs of
344 case findField key kvs of
@@ -343,10 +350,10 @@ field key (Decoder decodeA) =
343 decodeA value ok err'
350 decodeA value ok err'
344
351
345 Nothing ->
352 Nothing ->
346− err (Expecting (TObjectWith key))
353+ err (Expecting region (TObjectWith key))
347
354
348 _ ->
355 _ ->
349− err (Expecting TObject)
356+ err (Expecting region TObject)
350
357
351
358
352findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
359findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
@@ -410,8 +417,8 @@ oneOfError problems prob ps =
410
417
411failure :: x -> Decoder x a
418failure :: x -> Decoder x a
412failure x =
419failure x =
413− Decoder $ \_ _ err ->
420+ Decoder $ \(A.At region _) _ err ->
414− err (Failure x)
421+ err (Failure region x)
415
422
416
423
417
424
@@ -430,18 +437,22 @@ mapError func (Decoder decodeA) =
430mapErrorHelp :: (x -> y) -> Problem x -> Problem y
437mapErrorHelp :: (x -> y) -> Problem x -> Problem y
431mapErrorHelp func problem =
438mapErrorHelp func problem =
432 case problem of
439 case problem of
433− Field k p -> Field k (mapErrorHelp func p)
440+ Field k p -> Field k (mapErrorHelp func p)
434− Index i p -> Index i (mapErrorHelp func p)
441+ Index i p -> Index i (mapErrorHelp func p)
435− OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
442+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
436− Failure x -> Failure (func x)
443+ Failure r x -> Failure r (func x)
437− Expecting e -> Expecting e
444+ Expecting r e -> Expecting r e
438
445
439
446
440
447
441-- AST
448-- AST
442
449
443
450
444−data AST
451+type AST =
452+ A.Located AST_
453+
454+
455+data AST_
445 = Array [AST]
456 = Array [AST]
446 | Object [(P.Snippet, AST)]
457 | Object [(P.Snippet, AST)]
447 | String P.Snippet
458 | String P.Snippet
@@ -460,21 +471,14 @@ type Parser a =
460
471
461
472
462data ParseError
473data ParseError
463− = ObjectStart Row Col
474+ = Start Row Col
464− | ObjectMore Row Col
475+ | ObjectField Row Col
476+ | ObjectColon Row Col
465 | ObjectEnd Row Col
477 | ObjectEnd Row Col
466− | ArrayStart Row Col
467− | ArrayMore Row Col
468 | ArrayEnd Row Col
478 | ArrayEnd Row Col
469− | StringStart Row Col
470 | StringProblem StringProblem Row Col
479 | StringProblem StringProblem Row Col
471− | IntStart Row Col
472 | NoLeadingZeros Row Col
480 | NoLeadingZeros Row Col
473 | NoFloats Row Col
481 | NoFloats Row Col
474− | Bool Row Col
475− | Null Row Col
476− | Value Row Col
477− | Colon Row Col
478 | BadEnd Row Col
482 | BadEnd Row Col
479
483
480-- PIndex Int ParseError Row Col
484-- PIndex Int ParseError Row Col
@@ -502,14 +506,15 @@ pFile =
502
506
503pValue :: Parser AST
507pValue :: Parser AST
504pValue =
508pValue =
509+ P.addLocation $
505− P.oneOf Value
510+ P.oneOf Start
506− [ String <$> pString
511+ [ String <$> pString Start
507 , pObject
512 , pObject
508 , pArray
513 , pArray
509 , pInt
514 , pInt
510− , K.k4 0x74 0x72 0x75 0x65 Bool >> return TRUE
515+ , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
511− , K.k5 0x66 0x61 0x6C 0x73 0x65 Bool >> return FALSE
516+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
512− , K.k4 0x6E 0x75 0x6C 0x6C Null >> return NULL
517+ , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
513 ]
518 ]
514
519
515
520
@@ -517,11 +522,11 @@ pValue =
517-- OBJECT
522-- OBJECT
518
523
519
524
520−pObject :: Parser AST
525+pObject :: Parser AST_
521pObject =
526pObject =
522− do P.word1 0x7B {- { -} ObjectStart
527+ do P.word1 0x7B {- { -} Start
523 spaces
528 spaces
524− P.oneOf ObjectMore
529+ P.oneOf ObjectField
525 [ do entry <- pField
530 [ do entry <- pField
526 spaces
531 spaces
527 pObjectHelp [entry]
532 pObjectHelp [entry]
@@ -530,11 +535,11 @@ pObject =
530 ]
535 ]
531
536
532
537
533−pObjectHelp :: [(P.Snippet, AST)] -> Parser AST
538+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
534pObjectHelp revEntries =
539pObjectHelp revEntries =
535− P.oneOf ObjectMore
540+ P.oneOf ObjectEnd
536 [
541 [
537− do P.word1 0x2C {-,-} ObjectMore
542+ do P.word1 0x2C {-,-} ObjectEnd
538 spaces
543 spaces
539 entry <- pField
544 entry <- pField
540 spaces
545 spaces
@@ -547,9 +552,9 @@ pObjectHelp revEntries =
547
552
548pField :: Parser (P.Snippet, AST)
553pField :: Parser (P.Snippet, AST)
549pField =
554pField =
550− do key <- pString
555+ do key <- pString ObjectField
551 spaces
556 spaces
552− P.word1 0x3A {-:-} Colon
557+ P.word1 0x3A {-:-} ObjectColon
553 spaces
558 spaces
554 value <- pValue
559 value <- pValue
555 return (key, value)
560 return (key, value)
@@ -559,11 +564,11 @@ pField =
559-- ARRAY
564-- ARRAY
560
565
561
566
562−pArray :: Parser AST
567+pArray :: Parser AST_
563pArray =
568pArray =
564− do P.word1 0x5B {-[-} ArrayStart
569+ do P.word1 0x5B {-[-} Start
565 spaces
570 spaces
566− P.oneOf ArrayMore
571+ P.oneOf Start
567 [ do entry <- pValue
572 [ do entry <- pValue
568 spaces
573 spaces
569 pArrayHelp 1 [entry]
574 pArrayHelp 1 [entry]
@@ -572,11 +577,11 @@ pArray =
572 ]
577 ]
573
578
574
579
575−pArrayHelp :: Int -> [AST] -> Parser AST
580+pArrayHelp :: Int -> [AST] -> Parser AST_
576pArrayHelp !len revEntries =
581pArrayHelp !len revEntries =
577− P.oneOf ArrayMore
582+ P.oneOf ArrayEnd
578 [
583 [
579− do P.word1 0x2C {-,-} ArrayMore
584+ do P.word1 0x2C {-,-} ArrayEnd
580 spaces
585 spaces
581 entry <- pValue
586 entry <- pValue
582 spaces
587 spaces
@@ -591,8 +596,8 @@ pArrayHelp !len revEntries =
591-- STRING
596-- STRING
592
597
593
598
594−pString :: Parser P.Snippet
599+pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
595−pString =
600+pString start =
596 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
601 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
597 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
598
603
@@ -617,7 +622,7 @@ pString =
617 cerr newRow newCol (StringProblem problem)
622 cerr newRow newCol (StringProblem problem)
618
623
619 else
624 else
620− eerr row col StringStart
625+ eerr row col start
621
626
622
627
623data StringStatus
628data StringStatus
@@ -625,7 +630,7 @@ data StringStatus
625 | BadString StringProblem
630 | BadString StringProblem
626
631
627
632
628−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
633+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
629pStringHelp pos end row col =
634pStringHelp pos end row col =
630 if pos >= end then
635 if pos >= end then
631 (# BadString BadStringEnd, pos, row, col #)
636 (# BadString BadStringEnd, pos, row, col #)
@@ -671,7 +676,7 @@ pStringHelp pos end row col =
671 if word < 0x20 then
676 if word < 0x20 then
672 (# BadString BadStringControlChar, pos, row, col #)
677 (# BadString BadStringControlChar, pos, row, col #)
673 else
678 else
674− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
679+ let !newPos = plusPtr pos (P.getCharWidth word) in
675 pStringHelp newPos end row (col + 1)
680 pStringHelp newPos end row (col + 1)
676
681
677
682
@@ -703,7 +708,7 @@ spaces =
703 cok () newState
708 cok () newState
704
709
705
710
706−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
711+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
707eatSpaces pos end row col =
712eatSpaces pos end row col =
708 if pos >= end then
713 if pos >= end then
709 (# pos, row, col #)
714 (# pos, row, col #)
@@ -722,16 +727,16 @@ eatSpaces pos end row col =
722-- INTS
727-- INTS
723
728
724
729
725−pInt :: Parser AST
730+pInt :: Parser AST_
726pInt =
731pInt =
727 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
732 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
728 if pos >= end then
733 if pos >= end then
729− eerr row col IntStart
734+ eerr row col Start
730
735
731 else
736 else
732 let !word = P.unsafeIndex pos in
737 let !word = P.unsafeIndex pos in
733 if not (isDecimalDigit word) then
738 if not (isDecimalDigit word) then
734− eerr row col IntStart
739+ eerr row col Start
735
740
736 else if word == 0x30 {-0-} then
741 else if word == 0x30 {-0-} then
737
742
compiler/src/Json/Encode.hs+4−3
@@ -104,21 +104,22 @@ list encodeEntry entries =
104-- CHARS
104-- CHARS
105
105
106
106
107−chars :: [Char] -> Value -- TODO can this be done better? Look for examples.
107+chars :: [Char] -> Value -- PERF 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] -- TODO is this correct?
112+escape :: [Char] -> [Char]
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
119 | c == '\n' -> '\\' : 'n' : escape cs
120 | c == '\n' -> '\\' : 'n' : escape cs
120 | c == '\"' -> '\\' : '"' : escape cs
121 | c == '\"' -> '\\' : '"' : escape cs
121− | c == '\'' -> '\\' : '\'' : escape cs
122+ | c == '\\' -> '\\' : '\\' : escape cs
122 | otherwise -> c : escape cs
123 | otherwise -> c : escape cs
123
124
124
125
compiler/src/Json/String.hs+8−3
@@ -2,6 +2,7 @@
2{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
2{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
3module Json.String
3module Json.String
4 ( String
4 ( String
5+ , isEmpty
5 --
6 --
6 , fromPtr
7 , fromPtr
7 , fromName
8 , fromName
@@ -36,7 +37,7 @@ import qualified Parse.Primitives as P
36
37
37
38
38-- INVARIANT: any Json.String is appropriately escaped already
39-- INVARIANT: any Json.String is appropriately escaped already
39−-- TODO: is this the right representation for Json.String? Maybe ByteString instead?
40+-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
40--
41--
41type String =
42type String =
42 Utf8.Utf8 JSON_STRING
43 Utf8.Utf8 JSON_STRING
@@ -45,6 +46,11 @@ type String =
45data JSON_STRING
46data JSON_STRING
46
47
47
48
49+isEmpty :: String -> Bool
50+isEmpty =
51+ Utf8.isEmpty
52+
53+
48
54
49-- FROM
55-- FROM
50
56
@@ -110,7 +116,6 @@ chompChunks pos end start revChunks =
110 case word of
116 case word of
111 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
117 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
112 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
118 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
113− 0x27 {-'-} -> chompEscape 0x27 {-'-} pos end start revChunks
114 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
119 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
115 0x0D {-\r-} ->
120 0x0D {-\r-} ->
116 let
121 let
@@ -120,7 +125,7 @@ chompChunks pos end start revChunks =
120
125
121 _ ->
126 _ ->
122 let
127 let
123− !width = P.getCharWidth pos end word
128+ !width = P.getCharWidth word
124 !newPos = plusPtr pos width
129 !newPos = plusPtr pos width
125 in
130 in
126 chompChunks newPos end start revChunks
131 chompChunks newPos end start revChunks
compiler/src/Nitpick/PatternMatches.hs+3−3
@@ -22,11 +22,11 @@ import qualified Data.Map as Map
22import qualified Data.Maybe as Maybe
22import qualified Data.Maybe as Maybe
23import qualified Data.Name as Name
23import qualified Data.Name as Name
24import qualified Data.NonEmptyList as NE
24import qualified Data.NonEmptyList as NE
25−import qualified Data.Utf8 as Utf8
26
25
27import qualified AST.Canonical as Can
26import qualified AST.Canonical as Can
28import qualified Data.Index as Index
27import qualified Data.Index as Index
29import qualified Elm.ModuleName as ModuleName
28import qualified Elm.ModuleName as ModuleName
29+import qualified Elm.String as ES
30import qualified Reporting.Annotation as A
30import qualified Reporting.Annotation as A
31
31
32
32
@@ -41,8 +41,8 @@ data Pattern
41
41
42
42
43data Literal
43data Literal
44− = Chr Utf8.String
44+ = Chr ES.String
45− | Str Utf8.String
45+ | Str ES.String
46 | Int Int
46 | Int Int
47 deriving (Eq)
47 deriving (Eq)
48
48
compiler/src/Optimize/DecisionTree.hs+5−5
@@ -27,11 +27,11 @@ import qualified Data.List as List
27import qualified Data.Maybe as Maybe
27import qualified Data.Maybe as Maybe
28import qualified Data.Name as Name
28import qualified Data.Name as Name
29import qualified Data.Set as Set
29import qualified Data.Set as Set
30−import qualified Data.Utf8 as Utf8
31
30
32import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
33import qualified Data.Index as Index
32import qualified Data.Index as Index
34import qualified Elm.ModuleName as ModuleName
33import qualified Elm.ModuleName as ModuleName
34+import qualified Elm.String as ES
35import qualified Reporting.Annotation as A
35import qualified Reporting.Annotation as A
36
36
37
37
@@ -77,8 +77,8 @@ data Test
77 | IsNil
77 | IsNil
78 | IsTuple
78 | IsTuple
79 | IsInt Int
79 | IsInt Int
80− | IsChr Utf8.String
80+ | IsChr ES.String
81− | IsStr Utf8.String
81+ | IsStr ES.String
82 | IsBool Bool
82 | IsBool Bool
83 deriving (Eq, Ord)
83 deriving (Eq, Ord)
84
84
@@ -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− _ -> error "problem getting DecisionTree.Test binary"
621+ _ -> fail "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− _ -> error "problem getting DecisionTree.Path binary"
637+ _ -> fail "problem getting DecisionTree.Path binary"
compiler/src/Optimize/Module.hs+3−3
@@ -213,10 +213,10 @@ findMain defs =
213 def:rest ->
213 def:rest ->
214 case def of
214 case def of
215 Can.Def (A.At region name) _ _ ->
215 Can.Def (A.At region name) _ _ ->
216− if name == Name.main then Just region else findMain rest
216+ if name == Name._main then Just region else findMain rest
217
217
218 Can.TypedDef (A.At region name) _ _ _ _ ->
218 Can.TypedDef (A.At region name) _ _ _ _ ->
219− if name == Name.main then Just region else findMain rest
219+ if name == Name._main then Just region else findMain rest
220
220
221
221
222defToName :: Can.Def -> Name.Name
222defToName :: Can.Def -> Name.Name
@@ -244,7 +244,7 @@ addDef home annotations def graph =
244
244
245addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
245addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
246addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
246addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
247− if name /= Name.main then
247+ if name /= Name._main then
248 Result.ok (addDefNode home name args body Set.empty graph)
248 Result.ok (addDefNode home name args body Set.empty graph)
249 else
249 else
250 let
250 let
compiler/src/Optimize/Port.hs+3−3
@@ -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 union type"
61+ error "toEncoder: bad custom type"
62
62
63 Can.TRecord _ (Just _) ->
63 Can.TRecord _ (Just _) ->
64 error "toEncoder: bad record"
64 error "toEncoder: bad record"
@@ -68,7 +68,7 @@ toEncoder tipe =
68 encodeField (name, Can.FieldType _ fieldType) =
68 encodeField (name, Can.FieldType _ fieldType) =
69 do encoder <- toEncoder fieldType
69 do encoder <- toEncoder fieldType
70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
71− return $ Opt.Tuple (Opt.Str (Name.toUtf8 name)) value Nothing
71+ return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing
72 in
72 in
73 do object <- encode "object"
73 do object <- encode "object"
74 keyValuePairs <- traverse encodeField (Map.toList fields)
74 keyValuePairs <- traverse encodeField (Map.toList fields)
@@ -309,7 +309,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) =
309 return $
309 return $
310 Opt.Call andThen
310 Opt.Call andThen
311 [ Opt.Function [key] decoder
311 [ Opt.Function [key] decoder
312− , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]
312+ , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]
313 ]
313 ]
314
314
315
315
compiler/src/Parse/Docs.hsdeleted−275
@@ -1,275 +0,0 @@
1−module Parse.Docs
2− ( Docs(..)
3− , parser
4− )
5− where
6−
7−
8−
9−-- DOCS
10−
11−
12−data Docs =
13− Docs
14− { _exposed :: [A.Located Name.Name]
15− , _overview :: Utf8.String
16− , _listed :: [A.Located Name.Name]
17− , _comments :: Map.Map Name.Name Utf8.String
18− }
19−
20−
21−
22−-- PARSER
23−
24−
25−parser :: Parser Docs
26−parser =
27− error "TODO implement docs parser"
28−
29−
30−chompUntilDocs :: Parser Bool
31−chompUntilDocs =
32− P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33− let
34− (# isStart, newOffset, newRow, newCol #) =
35− eatDocs fp offset terminal row col
36−
37− !newState =
38− P.State fp newOffset terminal indent newRow newCol ctx
39− in
40− cok isStart newState
41−
42−
43−eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44−eatDocs fp offset terminal row col =
45− if offset >= terminal then
46− (# False, offset, row, col #)
47−
48− else if isDocsStart fp offset terminal then
49− (# True, offset + 5, row, col + 5 #)
50−
51− else
52− let !word = P.unsafeIndex fp offset in
53− if word == 0x0A {- \n -} then
54− eatDocs fp (offset + 1) terminal (row + 1) 1
55−
56− else
57− let !newOffset = offset + P.getCharWidth fp offset terminal word in
58− eatDocs fp newOffset terminal row (col + 1)
59−
60−
61−isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62−isDocsStart =
63− let (B.PS dfp doff dlen) = docsStart in
64− P.isSubstring dfp doff dlen
65−
66−
67−{-# NOINLINE docsStart #-}
68−docsStart :: B.ByteString
69−docsStart =
70− "@docs"
71−
72−
73−chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74−chompOverview names =
75− do isDocs <- chompUntilDocs
76− if isDocs
77− then chompOverviewHelp names
78− else return names
79−
80−
81−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82−chompOverviewHelp names =
83− do pos <- getPosition
84− (SPos spos) <- whitespace
85− if pos == spos
86− then chompOverview names
87− else chompOverview =<< chompDocs names
88−
89−
90−chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91−chompDocs names =
92− do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93− spos <- whitespace
94− oneOf SE.XXX
95− [ do checkSpace spos
96− word1 0x2C {-,-} SE.XXX
97− spaces
98− chompDocs (name:names)
99− , return (name:names)
100− ]
101−
102−
103−chompBinop :: Parser Name.Name
104−chompBinop =
105− do word1 0x28 {-(-} SE.XXX
106− name <- Symbol.binop
107− word1 0x29 {-)-} SE.XXX
108− return name
109−
110−
111−
112−
113−-- CHECK NAMES
114−
115−
116−type Result i w a =
117− Result.Result i w E.Error a
118−
119−
120−type Dups =
121− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122−
123−
124−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125−checkNames exports names =
126− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127− let overlap = Map.size (Map.intersection docs exports)
128− if Map.size exports == overlap && overlap == Map.size docs
129− then Result.ok ()
130− else
131− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133− Result.ok ()
134−
135−
136−addName :: Dups -> A.Located Name.Name -> Dups
137−addName dict (A.At region name) =
138− Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139−
140−
141−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142−isUnique name regions =
143− case regions of
144− OneOrMore.One region ->
145− Result.ok region
146−
147− OneOrMore.More _ _ ->
148− let (r1:r2:_) = OneOrMore.toList regions in
149− Result.throw (E.Duplicate name r1 r2)
150−
151−
152−onlyInDocs :: Name.Name -> A.Region -> Result i w a
153−onlyInDocs name region =
154− Result.throw $ E.OnlyInDocs name region
155−
156−
157−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158−onlyInExports name (A.At region _) =
159− Result.throw $ E.OnlyInExports name region
160−
161−
162−
163−-- CHECK EXPORTS
164−
165−
166−data Info =
167− Info
168− { _iComments :: Map.Map Name.Name Comment
169− , _iValues :: Types
170− , _iUnions :: Map.Map Name.Name Can.Union
171− , _iAliases :: Map.Map Name.Name Can.Alias
172− , _iBinops :: Map.Map Name.Name Can.Binop
173− , _iEffects :: Can.Effects
174− }
175−
176−
177−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178−checkExport info name (A.At region export) =
179− case export of
180− Can.ExportValue ->
181− do tipe <- getType name info
182− comment <- getComment region name info
183− Result.ok $ \m ->
184− m { _values = Map.insert name (Value comment tipe) (_values m) }
185−
186− Can.ExportBinop ->
187− do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188− tipe <- getType realName info
189− comment <- getComment region realName info
190− Result.ok $ \m ->
191− m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192−
193− Can.ExportAlias ->
194− do let (Can.Alias tvars tipe) = _iAliases info ! name
195− comment <- getComment region name info
196− Result.ok $ \m ->
197− m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198−
199− Can.ExportUnionOpen ->
200− do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201− comment <- getComment region name info
202− Result.ok $ \m ->
203− m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204−
205− Can.ExportUnionClosed ->
206− do let (Can.Union tvars _ _ _) = _iUnions info ! name
207− comment <- getComment region name info
208− Result.ok $ \m ->
209− m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210−
211− Can.ExportPort ->
212− do tipe <- getType name info
213− comment <- getComment region name info
214− Result.ok $ \m ->
215− m { _values = Map.insert name (Value comment tipe) (_values m) }
216−
217−
218−getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219−getComment region name info =
220− case Map.lookup name (_iComments info) of
221− Nothing ->
222− Result.throw (E.NoComment name region)
223−
224− Just comment ->
225− Result.ok comment
226−
227−
228−getType :: Name.Name -> Info -> Result i w Type.Type
229−getType name info =
230− case _iValues info ! name of
231− A.At defRegion Nothing ->
232− Result.throw (E.NoAnnotation name defRegion)
233−
234− A.At _ (Just tipe) ->
235− Result.ok (Extract.fromType tipe)
236−
237−
238−dector :: Can.Ctor -> (Name.Name, [Type.Type])
239−dector (Can.Ctor name _ _ args) =
240− ( name, map Extract.fromType args )
241−
242−
243−
244−-- GATHER TYPES
245−
246−
247−type Types =
248− Map.Map Name.Name (A.Located (Maybe Can.Type))
249−
250−
251−gatherTypes :: Can.Decls -> Types -> Types
252−gatherTypes decls types =
253− case decls of
254− Can.Declare def subDecls ->
255− gatherTypes subDecls (addDef types def)
256−
257− Can.DeclareRec defs subDecls ->
258− gatherTypes subDecls (List.foldl' addDef types defs)
259−
260− Can.SaveTheEnvironment ->
261− types
262−
263−
264−addDef :: Types -> Can.Def -> Types
265−addDef types def =
266− case def of
267− Can.Def (A.At region name) _ _ ->
268− Map.insert name (A.At region Nothing) types
269−
270− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271− let
272− tipe =
273− foldr Can.TLambda resultType (map snd typedArgs)
274− in
275− Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+40−32
@@ -128,38 +128,46 @@ 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
131− oneOf E.TupleIndentExpr1
140+ oneOf E.TupleIndentExpr1
132− [
141+ [
133− do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
142+ do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
134− if op == "-"
143+ if op == "-"
135− then
144+ then
136− oneOf E.TupleOperatorClose
145+ oneOf E.TupleOperatorClose
137− [
146+ [
138− do word1 0x29 {-)-} E.TupleOperatorClose
147+ do word1 0x29 {-)-} E.TupleOperatorClose
139− addEnd start (Src.Op op)
148+ addEnd start (Src.Op op)
140− ,
149+ ,
141− do (entry, end) <-
150+ do (entry, end) <-
142− specialize E.TupleExpr $
151+ specialize E.TupleExpr $
143− do negatedExpr@(A.At (A.Region _ end) _) <- term
152+ do negatedExpr@(A.At (A.Region _ end) _) <- term
144− Space.chomp E.Space
153+ Space.chomp E.Space
145− let exprStart = A.Position row (col + 2)
154+ let exprStart = A.Position row (col + 2)
146− let expr = A.at exprStart end (Src.Negate negatedExpr)
155+ let expr = A.at exprStart end (Src.Negate negatedExpr)
147− chompExprEnd exprStart (State [] expr [] end)
156+ chompExprEnd exprStart (State [] expr [] end)
148− Space.checkIndent end E.TupleIndentEnd
157+ Space.checkIndent end E.TupleIndentEnd
149− chompTupleEnd start entry []
158+ chompTupleEnd start entry []
150− ]
159+ ]
151− else
160+ else
152− do word1 0x29 {-)-} E.TupleOperatorClose
161+ do word1 0x29 {-)-} E.TupleOperatorClose
153− addEnd start (Src.Op op)
162+ addEnd start (Src.Op op)
154− ,
163+ ,
155− do word1 0x29 {-)-} E.TupleIndentExpr1
164+ do word1 0x29 {-)-} E.TupleIndentExpr1
156− addEnd start Src.Unit
165+ addEnd start Src.Unit
157− ,
166+ ,
158− do Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
159− (entry, end) <- specialize E.TupleExpr expression
167+ do (entry, end) <- specialize E.TupleExpr expression
160− Space.checkIndent end E.TupleIndentEnd
168+ Space.checkIndent end E.TupleIndentEnd
161− chompTupleEnd start entry []
169+ chompTupleEnd start entry []
162− ]
170+ ]
163
171
164
172
165chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
173chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
compiler/src/Parse/Module.hs+110−60
@@ -2,7 +2,10 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Module
3module Parse.Module
4 ( fromByteString
4 ( fromByteString
5+ , ProjectType(..)
6+ , isKernel
5 , chompImports
7 , chompImports
8+ , chompImport
6 )
9 )
7 where
10 where
8
11
@@ -28,14 +31,37 @@ import qualified Reporting.Error.Syntax as E
28-- FROM BYTE STRING
31-- FROM BYTE STRING
29
32
30
33
31−fromByteString :: Pkg.Name -> BS.ByteString -> Either E.Error Src.Module
34+fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module
32−fromByteString pkg source =
35+fromByteString projectType source =
33− case P.fromByteString (chompModule pkg) E.ModuleBadEnd source of
36+ case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of
34− Right modul -> checkModule modul
37+ Right modul -> checkModule projectType modul
35 Left err -> Left (E.ParseError err)
38 Left err -> Left (E.ParseError err)
36
39
37
40
38
41
42+-- PROJECT TYPE
43+
44+
45+data ProjectType
46+ = Package Pkg.Name
47+ | Application
48+
49+
50+isCore :: ProjectType -> Bool
51+isCore projectType =
52+ case projectType of
53+ Package pkg -> pkg == Pkg.core
54+ Application -> False
55+
56+
57+isKernel :: ProjectType -> Bool
58+isKernel projectType =
59+ case projectType of
60+ Package pkg -> Pkg.isKernel pkg
61+ Application -> False
62+
63+
64+
39-- MODULE
65-- MODULE
40
66
41
67
@@ -48,11 +74,11 @@ data Module =
48 }
74 }
49
75
50
76
51−chompModule :: Pkg.Name -> Parser E.Module Module
77+chompModule :: ProjectType -> Parser E.Module Module
52−chompModule pkg =
78+chompModule projectType =
53 do header <- chompHeader
79 do header <- chompHeader
54− imports <- chompImports (if pkg == Pkg.core then [] else Imports.defaults)
80+ imports <- chompImports (if isCore projectType then [] else Imports.defaults)
55− infixes <- if Pkg.isKernel pkg then chompInfixes [] else return []
81+ infixes <- if isKernel projectType then chompInfixes [] else return []
56 decls <- specialize E.Declarations $ chompDecls []
82 decls <- specialize E.Declarations $ chompDecls []
57 return (Module header imports infixes decls)
83 return (Module header imports infixes decls)
58
84
@@ -61,15 +87,15 @@ chompModule pkg =
61-- CHECK MODULE
87-- CHECK MODULE
62
88
63
89
64−checkModule :: Module -> Either E.Error Src.Module
90+checkModule :: ProjectType -> Module -> Either E.Error Src.Module
65−checkModule (Module maybeHeader imports infixes decls) =
91+checkModule projectType (Module maybeHeader imports infixes decls) =
66 let
92 let
67 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
93 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
68 in
94 in
69 case maybeHeader of
95 case maybeHeader of
70 Just (Header name effects exports docs) ->
96 Just (Header name effects exports docs) ->
71 Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
97 Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
72− <$> checkEffects ports effects
98+ <$> checkEffects projectType ports effects
73
99
74 Nothing ->
100 Nothing ->
75 Right $
101 Right $
@@ -79,23 +105,37 @@ checkModule (Module maybeHeader imports infixes decls) =
79 _:_ -> Src.Ports ports
105 _:_ -> Src.Ports ports
80
106
81
107
82−checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects
108+checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
83−checkEffects ports effects =
109+checkEffects projectType ports effects =
84 case effects of
110 case effects of
85 NoEffects region ->
111 NoEffects region ->
86 case ports of
112 case ports of
113+ [] ->
87− [] -> Right Src.NoEffects
114+ Right Src.NoEffects
115+
116+ Src.Port name _ : _ ->
117+ case projectType of
118+ Package _ -> Left (E.NoPortsInPackage name)
88− _:_ -> Left (E.UnexpectedPort region)
119+ Application -> Left (E.UnexpectedPort region)
89
120
90 Ports region ->
121 Ports region ->
91− case ports of
122+ case projectType of
123+ Package _ ->
124+ Left (E.NoPortModulesInPackage region)
125+
126+ Application ->
127+ case ports of
92− [] -> Left (E.NoPorts region)
128+ [] -> Left (E.NoPorts region)
93− _:_ -> Right (Src.Ports ports)
129+ _:_ -> Right (Src.Ports ports)
94
130
95 Manager region manager ->
131 Manager region manager ->
132+ if isKernel projectType then
96− case ports of
133+ case ports of
97− [] -> Right (Src.Manager region manager)
134+ [] -> Right (Src.Manager region manager)
98− _:_ -> Left (E.UnexpectedPort region)
135+ _:_ -> Left (E.UnexpectedPort region)
136+ else
137+ Left (E.NoEffectsOutsideKernel region)
138+
99
139
100
140
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] )
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] )
@@ -332,28 +372,33 @@ spaces_em =
332
372
333
373
334chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
374chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
335−chompImports imports =
375+chompImports is =
336 oneOfWithFallback
376 oneOfWithFallback
337− [ do Keyword.import_ E.ImportStart
377+ [ do i <- chompImport
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
343− chompImports $
378+ chompImports (i:is)
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− ]
351 ]
379 ]
352− (reverse imports)
380+ (reverse is)
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+ ]
353
398
354
399
355−chompAs :: A.Located Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
400+chompAs :: A.Located Name.Name -> Parser E.Module Src.Import
356−chompAs name imports =
401+chompAs name =
357 do Keyword.as_ E.ImportAs
402 do Keyword.as_ E.ImportAs
358 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
403 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
359 alias <- Var.upper E.ImportAlias
404 alias <- Var.upper E.ImportAlias
@@ -361,21 +406,19 @@ chompAs name imports =
361 Space.chomp E.ModuleSpace
406 Space.chomp E.ModuleSpace
362 oneOf E.ImportEnd
407 oneOf E.ImportEnd
363 [ do Space.checkFreshLine E.ImportEnd
408 [ do Space.checkFreshLine E.ImportEnd
364− chompImports $
365− Src.Import name (Just alias) (Src.Explicit []) : imports
409+ return $ Src.Import name (Just alias) (Src.Explicit [])
366 , do Space.checkIndent end E.ImportEnd
410 , do Space.checkIndent end E.ImportEnd
367− chompExposing name (Just alias) imports
411+ chompExposing name (Just alias)
368 ]
412 ]
369
413
370
414
371−chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
415+chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import
372−chompExposing name maybeAlias imports =
416+chompExposing name maybeAlias =
373 do Keyword.exposing_ E.ImportExposing
417 do Keyword.exposing_ E.ImportExposing
374 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
418 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
375 exposed <- specialize E.ImportExposingList exposing
419 exposed <- specialize E.ImportExposingList exposing
376 freshLine E.ImportEnd
420 freshLine E.ImportEnd
377− chompImports $
378− Src.Import name maybeAlias exposed : imports
421+ return $ Src.Import name maybeAlias exposed
379
422
380
423
381
424
@@ -391,18 +434,18 @@ exposing =
391 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
434 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
392 word1 0x29 {-)-} E.ExposingEnd
435 word1 0x29 {-)-} E.ExposingEnd
393 return Src.Open
436 return Src.Open
394− , do exposed <- addLocation chompExposed
437+ , do exposed <- chompExposed
395 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
438 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
396 exposingHelp [exposed]
439 exposingHelp [exposed]
397 ]
440 ]
398
441
399
442
400−exposingHelp :: [A.Located Src.Exposed] -> Parser E.Exposing Src.Exposing
443+exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing
401exposingHelp revExposed =
444exposingHelp revExposed =
402 oneOf E.ExposingEnd
445 oneOf E.ExposingEnd
403 [ do word1 0x2C {-,-} E.ExposingEnd
446 [ do word1 0x2C {-,-} E.ExposingEnd
404 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
447 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
405− exposed <- addLocation chompExposed
448+ exposed <- chompExposed
406 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
449 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
407 exposingHelp (exposed:revExposed)
450 exposingHelp (exposed:revExposed)
408 , do word1 0x29 {-)-} E.ExposingEnd
451 , do word1 0x29 {-)-} E.ExposingEnd
@@ -412,16 +455,21 @@ exposingHelp revExposed =
412
455
413chompExposed :: Parser E.Exposing Src.Exposed
456chompExposed :: Parser E.Exposing Src.Exposed
414chompExposed =
457chompExposed =
458+ do start <- getPosition
415− oneOf E.ExposingValue
459+ oneOf E.ExposingValue
416− [ Src.Lower <$> Var.lower E.ExposingValue
460+ [ do name <- Var.lower E.ExposingValue
461+ end <- getPosition
462+ return $ Src.Lower $ A.at start end name
417− , do word1 0x28 {-(-} E.ExposingValue
463+ , do word1 0x28 {-(-} E.ExposingValue
418− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
464+ op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
419− word1 0x29 {-)-} E.ExposingOperatorRightParen
465+ word1 0x29 {-)-} E.ExposingOperatorRightParen
466+ end <- getPosition
420− return (Src.Operator op)
467+ return $ Src.Operator (A.Region start end) op
421− , do name <- Var.upper E.ExposingValue
468+ , do name <- Var.upper E.ExposingValue
469+ end <- getPosition
422− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
470+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
423− Src.Upper name <$> privacy
471+ Src.Upper (A.at start end name) <$> privacy
424− ]
472+ ]
425
473
426
474
427privacy :: Parser E.Exposing Src.Privacy
475privacy :: Parser E.Exposing Src.Privacy
@@ -429,9 +477,11 @@ privacy =
429 oneOfWithFallback
477 oneOfWithFallback
430 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
478 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
431 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
479 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
480+ start <- getPosition
432 word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
481 word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
482+ end <- getPosition
433 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
483 Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
434 word1 0x29 {-)-} E.ExposingTypePrivacy
484 word1 0x29 {-)-} E.ExposingTypePrivacy
435− return Src.Public
485+ return $ Src.Public (A.Region start end)
436 ]
486 ]
437 Src.Private
487 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 vars)
132+ addEnd start (Src.PRecord (reverse vars))
133 ]
133 ]
134
134
135
135
compiler/src/Parse/Primitives.hs+4−4
@@ -46,7 +46,7 @@ newtype Parser x a =
46 )
46 )
47
47
48
48
49−data State = -- TODO try taking some out to avoid allocation?
49+data State = -- PERF 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 -- TODO is this function okay? Worried about allocation/laziness with fallback values.
148+oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values.
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
@@ -394,8 +394,8 @@ isWord pos end word =
394 pos < end && unsafeIndex pos == word
394 pos < end && unsafeIndex pos == word
395
395
396
396
397−getCharWidth :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
397+getCharWidth :: Word8 -> Int
398−getCharWidth _pos _end word -- TODO remove unused variables. Shorter stack?
398+getCharWidth word
399 | word < 0x80 = 1
399 | word < 0x80 = 1
400 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
400 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
401 | word < 0xe0 = 2
401 | word < 0xe0 = 2
compiler/src/Parse/Repl.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Parse.Repl
4− ( Entry(..)
5− , parseEntry
6− )
7− where
8−
9−
10−import qualified Data.ByteString.UTF8 as BS_UTF8
11−import Data.Name (Name)
12−
13−import qualified AST.Source as Src
14−import qualified Parse.Primitives as P
15−import Parse.Utils
16−
17−
18−
19−-- ENTRY
20−
21−
22−data Entry
23− = Import Name (Maybe Name) Src.Exposing String
24− | Type Name String
25− | Def (Maybe Name) String
26− | Other String
27− | Annotation
28− | Port
29−
30−
31−
32−-- PARSE
33−
34−
35−parseEntry :: String -> Entry
36−parseEntry source =
37− case P.fromByteString parser (BS_UTF8.fromString source) of
38− P.Ok entry _ ->
39− entry
40−
41− P.Err _ _ _ _ ->
42− Other source
43−
44−
45−parser :: Parser Entry
46−parser =
47− error "TODO parse the REPL stuff"
48−
49−{-
50− oneOf
51− [
52− do Keyword.import_
53− spaces
54− name <- Var.moduleName
55− alias <- tryAlias
56− exposing <-
57− oneOf
58− [ do spaces
59− Keyword.exposing_
60− spaces
61− Module.exposing
62− , return (Src.Explicit [])
63− ]
64− return (Import name alias exposing source)
65− ,
66− do Keyword.port_
67− return Port
68− ,
69− do Keyword.type_
70− spaces
71− oneOf
72− [ do Keyword.alias_
73− spaces
74− , return ()
75− ]
76− name <- Var.upper
77− return (Type name source)
78− ,
79− do root <- Pattern.term
80− spaces
81− case A.toValue root of
82− Src.PVar name ->
83− oneOf
84− [ do word1 0x3A {-:-} E.XXX
85− return Annotation
86− , do chompArgs
87− return (Def (Just name) source)
88− ]
89−
90− _ ->
91− do word1 0x3D {-=-} E.XXX
92− return (Def Nothing source)
93− ]
94−
95−
96−chompArgs :: Parser ()
97−chompArgs =
98− oneOf
99− [ do Pattern.term
100− spaces
101− chompArgs
102− , do word1 0x3D {-=-} E.XXX
103− return ()
104− ]
105−
106−
107−tryAlias :: Parser (Maybe Name)
108−tryAlias =
109− oneOf
110− [ try $
111− do spaces
112− Keyword.as_
113− spaces
114− Just <$> Var.upper
115− , return Nothing
116− ]
117−-}
compiler/src/Parse/Shader.hs+1−1
@@ -96,7 +96,7 @@ eatShader pos end row col =
96 eatShader (plusPtr pos 1) end (row + 1) 1
96 eatShader (plusPtr pos 1) end (row + 1) 1
97
97
98 else
98 else
99− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
99+ let !newPos = plusPtr pos (P.getCharWidth word) in
100 eatShader newPos end row (col + 1)
100 eatShader newPos end row (col + 1)
101
101
102
102
compiler/src/Parse/Space.hs+4−4
@@ -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 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
160+eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
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 #)
@@ -167,7 +167,7 @@ eatLineComment pos end row col =
167 if word == 0x0A {- \n -} then
167 if word == 0x0A {- \n -} then
168 eatSpaces (plusPtr pos 1) end (row + 1) 1
168 eatSpaces (plusPtr pos 1) end (row + 1) 1
169 else
169 else
170− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
170+ let !newPos = plusPtr pos (P.getCharWidth word) in
171 eatLineComment newPos end row (col + 1)
171 eatLineComment newPos end row (col + 1)
172
172
173
173
@@ -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, Word16, Word16 #)
211+eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)
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 #)
@@ -231,7 +231,7 @@ eatMultiCommentHelp pos end row col openComments =
231 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
231 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
232
232
233 else
233 else
234− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
234+ let !newPos = plusPtr pos (P.getCharWidth word) in
235 eatMultiCommentHelp newPos end row (col + 1) openComments
235 eatMultiCommentHelp newPos end row (col + 1) openComments
236
236
237
237
compiler/src/Parse/String.hs+5−5
@@ -87,7 +87,7 @@ chompChar pos end row col numChars mostRecent =
87
87
88 else
88 else
89 let
89 let
90− !width = P.getCharWidth pos end word
90+ !width = P.getCharWidth word
91 !newPos = plusPtr pos width
91 !newPos = plusPtr pos width
92 in
92 in
93 chompChar newPos end row (col + 1) (numChars + 1) (ES.Slice pos width)
93 chompChar newPos end row (col + 1) (numChars + 1) (ES.Slice pos width)
@@ -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 -> Word16 -> Word16 -> Ptr Word8 -> [ES.Chunk] -> StringResult
168+singleString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> 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
@@ -203,7 +203,7 @@ singleString pos end row col initialPos revChunks =
203 Err row (col + 1) E.StringEndless_Single
203 Err row (col + 1) E.StringEndless_Single
204
204
205 else
205 else
206− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
206+ let !newPos = plusPtr pos (P.getCharWidth word) in
207 singleString newPos end row (col + 1) initialPos revChunks
207 singleString newPos end row (col + 1) initialPos revChunks
208
208
209
209
@@ -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 -> Word16 -> Word16 -> Ptr Word8 -> Word16 -> Word16 -> [ES.Chunk] -> StringResult
214+multiString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> Row -> Col -> [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
@@ -254,7 +254,7 @@ multiString pos end row col initialPos sr sc revChunks =
254 Err sr sc E.StringEndless_Multi
254 Err sr sc E.StringEndless_Multi
255
255
256 else
256 else
257− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
257+ let !newPos = plusPtr pos (P.getCharWidth word) in
258 multiString newPos end row (col + 1) initialPos sr sc revChunks
258 multiString newPos end row (col + 1) initialPos sr sc revChunks
259
259
260
260
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− "." -> cerr row col (toError BadDot)
43+ "." -> eerr 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 -- TODO try using a trie instead
70+reservedWords :: Set.Set Name.Name -- PERF 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− !foreign =
152+ !upperName =
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 foreign newState
159+ cok upperName 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 -- TODO see if unpacking region is helpful
29+ At Region a -- PERF see if unpacking region is helpful
30
30
31
31
32instance Functor Located where
32instance Functor Located where
compiler/src/Reporting/Doc.hs+79−47
@@ -7,16 +7,38 @@ module Reporting.Doc
7 , P.hcat, P.hsep, P.indent, P.sep, P.vcat
7 , P.hcat, P.hsep, P.indent, P.sep, P.vcat
8 , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow
8 , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow
9 , P.dullred, P.dullcyan, P.dullyellow
9 , P.dullred, P.dullcyan, P.dullyellow
10−
10+ --
11− , fromChars, fromName, fromInt, fromUtf8
11+ , fromChars
12+ , fromName
13+ , fromVersion
14+ , fromPackage
15+ , fromInt
16+ --
17+ , toAnsi
12− , toAnsi, toString, toLine
18+ , toString
19+ , toLine
20+ --
13 , encode
21 , encode
14−
22+ --
23+ , stack
24+ , reflow
15− , stack, reflow, commaSep
25+ , commaSep
26+ --
16− , toSimpleNote, toSimpleHint, toFancyHint
27+ , toSimpleNote
28+ , toFancyNote
29+ , toSimpleHint
30+ , toFancyHint
31+ --
32+ , link
33+ , fancyLink
34+ , reflowLink
35+ , makeLink
17− , link, fancyLink, reflowLink, makeLink, makeNakedLink
36+ , makeNakedLink
37+ --
38+ , args
18− , args, moreArgs
39+ , moreArgs
40+ , ordinal
19− , ordinal, intToOrdinal
41+ , intToOrdinal
20 , cycle
42 , cycle
21 )
43 )
22 where
44 where
@@ -26,14 +48,17 @@ import Prelude hiding (cycle)
26import qualified Data.List as List
48import qualified Data.List as List
27import Data.Monoid ((<>))
49import Data.Monoid ((<>))
28import qualified Data.Name as Name
50import qualified Data.Name as Name
29−import qualified Data.Utf8 as Utf8
30import qualified System.Console.ANSI.Types as Ansi
51import qualified System.Console.ANSI.Types as Ansi
31import qualified System.Info as Info
52import qualified System.Info as Info
32import System.IO (Handle)
53import System.IO (Handle)
33import qualified Text.PrettyPrint.ANSI.Leijen as P
54import qualified Text.PrettyPrint.ANSI.Leijen as P
34
55
35import qualified Data.Index as Index
56import qualified Data.Index as Index
57+import qualified Elm.Package as Pkg
58+import qualified Elm.Version as V
59+import Json.Encode ((==>))
36import qualified Json.Encode as E
60import qualified Json.Encode as E
61+import qualified Json.String as Json
37
62
38
63
39
64
@@ -50,16 +75,21 @@ fromName name =
50 P.text (Name.toChars name)
75 P.text (Name.toChars name)
51
76
52
77
78+fromVersion :: V.Version -> P.Doc
79+fromVersion vsn =
80+ P.text (V.toChars vsn)
81+
82+
83+fromPackage :: Pkg.Name -> P.Doc
84+fromPackage pkg =
85+ P.text (Pkg.toChars pkg)
86+
87+
53fromInt :: Int -> P.Doc
88fromInt :: Int -> P.Doc
54fromInt n =
89fromInt n =
55 P.text (show n)
90 P.text (show n)
56
91
57
92
58−fromUtf8 :: Utf8.String -> P.Doc
59−fromUtf8 utf8 =
60− P.text (Utf8.toChars utf8)
61−
62−
63
93
64-- TO STRING
94-- TO STRING
65
95
@@ -111,12 +141,21 @@ commaSep conjunction addStyle names =
111
141
112
142
113
143
114−-- HINTS
144+-- NOTES
115
145
116
146
117toSimpleNote :: String -> P.Doc
147toSimpleNote :: String -> P.Doc
118toSimpleNote message =
148toSimpleNote message =
149+ toFancyNote (map P.text (words message))
150+
151+
152+toFancyNote :: [P.Doc] -> P.Doc
153+toFancyNote chunks =
119− P.fillSep ((P.underline "Note" <> ":") : map P.text (words message))
154+ P.fillSep (P.underline "Note" <> ":" : chunks)
155+
156+
157+
158+-- HINTS
120
159
121
160
122toSimpleHint :: String -> P.Doc
161toSimpleHint :: String -> P.Doc
@@ -133,32 +172,32 @@ toFancyHint chunks =
133-- LINKS
172-- LINKS
134
173
135
174
136−link :: P.Doc -> String -> String -> String -> P.Doc
175+link :: String -> String -> String -> String -> P.Doc
137link word before fileName after =
176link word before fileName after =
138 P.fillSep $
177 P.fillSep $
139− (P.underline word <> ":")
178+ (P.underline (P.text word) <> ":")
140 : map P.text (words before)
179 : map P.text (words before)
141 ++ P.text (makeLink fileName)
180 ++ P.text (makeLink fileName)
142 : map P.text (words after)
181 : map P.text (words after)
143
182
144
183
145−fancyLink :: P.Doc -> [P.Doc] -> String -> [P.Doc] -> P.Doc
184+fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
146fancyLink word before fileName after =
185fancyLink word before fileName after =
147 P.fillSep $
186 P.fillSep $
148− (P.underline word <> ":") : before ++ P.text (makeLink fileName) : after
187+ (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after
149
188
150
189
151−makeLink :: String -> String
190+makeLink :: [Char] -> [Char]
152makeLink fileName =
191makeLink fileName =
153− "<https://elm-lang.org/" <> error "TODO V.toString V.compiler" <> "/" <> fileName <> ">"
192+ "<https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName <> ">"
154
193
155
194
156−makeNakedLink :: String -> String
195+makeNakedLink :: [Char] -> [Char]
157makeNakedLink fileName =
196makeNakedLink fileName =
158− "https://elm-lang.org/" <> error "TODO V.toString V.compiler" <> "/" <> fileName
197+ "https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName
159
198
160
199
161−reflowLink :: String -> String -> String -> P.Doc
200+reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc
162reflowLink before fileName after =
201reflowLink before fileName after =
163 P.fillSep $
202 P.fillSep $
164 map P.text (words before)
203 map P.text (words before)
@@ -267,10 +306,8 @@ data Color
267 | WHITE
306 | WHITE
268
307
269
308
270−toJsonHelp :: Style -> [a] -> P.SimpleDoc -> [E.Value]
309+toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value]
271toJsonHelp style revChunks simpleDoc =
310toJsonHelp style revChunks simpleDoc =
272− error "TODO generate json on errors" style revChunks simpleDoc sgrToStyle encodeColor
273−{-
274 case simpleDoc of
311 case simpleDoc of
275 P.SFail ->
312 P.SFail ->
276 error $
313 error $
@@ -281,23 +318,18 @@ toJsonHelp style revChunks simpleDoc =
281 [ encodeChunks style revChunks ]
318 [ encodeChunks style revChunks ]
282
319
283 P.SChar char rest ->
320 P.SChar char rest ->
284− toJsonHelp style (TB.singleton char : revChunks) rest
321+ toJsonHelp style ([char] : revChunks) rest
285
322
286 P.SText _ string rest ->
323 P.SText _ string rest ->
287− toJsonHelp style (TB.fromString string : revChunks) rest
324+ toJsonHelp style (string : revChunks) rest
288
325
289 P.SLine indent rest ->
326 P.SLine indent rest ->
290− toJsonHelp style (spaces indent : "\n" : revChunks) rest
327+ toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest
291
328
292 P.SSGR sgrs rest ->
329 P.SSGR sgrs rest ->
293 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
330 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
294
331
295
332
296−spaces :: Int -> TB.Builder
297−spaces n =
298− TB.fromText (Text.replicate n " ")
299−-}
300−
301sgrToStyle :: [Ansi.SGR] -> Style -> Style
333sgrToStyle :: [Ansi.SGR] -> Style -> Style
302sgrToStyle sgrs style@(Style bold underline color) =
334sgrToStyle sgrs style@(Style bold underline color) =
303 case sgrs of
335 case sgrs of
@@ -358,28 +390,28 @@ toColor layer intensity color =
358 Ansi.White -> pick White WHITE
390 Ansi.White -> pick White WHITE
359 Ansi.Black -> pick Black BLACK
391 Ansi.Black -> pick Black BLACK
360
392
361−{-
393+
362−encodeChunks :: Style -> [TB.Builder] -> E.Value
394+encodeChunks :: Style -> [String] -> E.Value
363encodeChunks (Style bold underline color) revChunks =
395encodeChunks (Style bold underline color) revChunks =
364 let
396 let
365− !str = Utf8.concat (reverse revChunks)
397+ chars = concat (reverse revChunks)
366 in
398 in
367 case color of
399 case color of
368 Nothing | not bold && not underline ->
400 Nothing | not bold && not underline ->
369− E.string str
401+ E.chars chars
370
402
371 _ ->
403 _ ->
372 E.object
404 E.object
373− [ ("bold", E.bool bold)
405+ [ "bold" ==> E.bool bold
374− , ("underline", E.bool underline)
406+ , "underline" ==> E.bool underline
375− , ("color", maybe E.null encodeColor color)
407+ , "color" ==> maybe E.null encodeColor color
376− , ("string", E.string str)
408+ , "string" ==> E.chars chars
377 ]
409 ]
378−-}
410+
379
411
380encodeColor :: Color -> E.Value
412encodeColor :: Color -> E.Value
381encodeColor color =
413encodeColor color =
382− E.string $
414+ E.string $ Json.fromChars $
383 case color of
415 case color of
384 Red -> "red"
416 Red -> "red"
385 RED -> "RED"
417 RED -> "RED"
compiler/src/Reporting/Error.hs+32−26
@@ -10,10 +10,9 @@ 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
14import qualified Data.NonEmptyList as NE
13import qualified Data.NonEmptyList as NE
15import qualified Data.OneOrMore as OneOrMore
14import qualified Data.OneOrMore as OneOrMore
16−import qualified Data.Utf8 as Utf8
15+import qualified System.FilePath as FP
17
16
18import qualified Elm.ModuleName as ModuleName
17import qualified Elm.ModuleName as ModuleName
19import qualified File
18import qualified File
@@ -22,6 +21,7 @@ import Json.Encode ((==>))
22import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
23import qualified Reporting.Doc as D
22import qualified Reporting.Doc as D
24import qualified Reporting.Error.Canonicalize as Canonicalize
23import 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− , _path :: FilePath
42+ , _absolutePath :: FilePath
43− , _time :: File.Time
43+ , _modificationTime :: File.Time
44 , _source :: B.ByteString
44 , _source :: B.ByteString
45 , _error :: Error
45 , _error :: Error
46 }
46 }
@@ -57,6 +57,7 @@ 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
60
61
61
62
62
63
@@ -84,32 +85,34 @@ toReports source err =
84 BadPatterns errs ->
85 BadPatterns errs ->
85 fmap (Pattern.toReport source) errs
86 fmap (Pattern.toReport source) errs
86
87
88+ BadDocs docsErr ->
89+ Docs.toReports source docsErr
90+
87
91
88
92
89-- TO DOC
93-- TO DOC
90
94
91
95
92−toDoc :: Module -> [Module] -> D.Doc
96+toDoc :: FilePath -> Module -> [Module] -> D.Doc
93−toDoc err errs =
97+toDoc root err errs =
94 let
98 let
95− timeCompare m1 m2 = compare (_time m1) (_time m2)
96− (NE.List m ms) = NE.sortBy timeCompare (NE.List err errs)
99+ (NE.List m ms) = NE.sortBy _modificationTime (NE.List err errs)
97 in
100 in
98− D.vcat (toDocHelp m ms)
101+ D.vcat (toDocHelp root m ms)
99
102
100
103
101−toDocHelp :: Module -> [Module] -> [D.Doc]
104+toDocHelp :: FilePath -> Module -> [Module] -> [D.Doc]
102−toDocHelp module1 modules =
105+toDocHelp root module1 modules =
103 case modules of
106 case modules of
104 [] ->
107 [] ->
105− [moduleToDoc module1
108+ [moduleToDoc root module1
106 ,""
109 ,""
107 ]
110 ]
108
111
109 module2 : otherModules ->
112 module2 : otherModules ->
110− moduleToDoc module1
113+ moduleToDoc root module1
111 : toSeparator module1 module2
114 : toSeparator module1 module2
112− : toDocHelp module2 otherModules
115+ : toDocHelp root module2 otherModules
113
116
114
117
115toSeparator :: Module -> Module -> D.Doc
118toSeparator :: Module -> Module -> D.Doc
@@ -131,19 +134,22 @@ toSeparator beforeModule afterModule =
131-- MODULE TO DOC
134-- MODULE TO DOC
132
135
133
136
134−moduleToDoc :: Module -> D.Doc
137+moduleToDoc :: FilePath -> Module -> D.Doc
135−moduleToDoc (Module _ path _ source err) =
138+moduleToDoc root (Module _ absolutePath _ source err) =
136 let
139 let
137 reports =
140 reports =
138 toReports (Code.toSource source) err
141 toReports (Code.toSource source) err
142+
143+ relativePath =
144+ FP.makeRelative root absolutePath
139 in
145 in
140− D.vcat $ map (reportToDoc path) (NE.toList reports)
146+ D.vcat $ map (reportToDoc relativePath) (NE.toList reports)
141
147
142
148
143reportToDoc :: FilePath -> Report.Report -> D.Doc
149reportToDoc :: FilePath -> Report.Report -> D.Doc
144−reportToDoc path (Report.Report title _ _ message) =
150+reportToDoc relativePath (Report.Report title _ _ message) =
145 D.vcat
151 D.vcat
146− [ toMessageBar title path
152+ [ toMessageBar title relativePath
147 , ""
153 , ""
148 , message
154 , message
149 , ""
155 , ""
@@ -173,8 +179,8 @@ toJson (Module name path _ source err) =
173 toReports (Code.toSource source) err
179 toReports (Code.toSource source) err
174 in
180 in
175 E.object
181 E.object
176− [ "path" ==> E.string (Utf8.fromChars path)
182+ [ "path" ==> E.chars path
177− , "name" ==> E.string (Name.toUtf8 name)
183+ , "name" ==> E.name name
178 , "problems" ==> E.array (map reportToJson (NE.toList reports))
184 , "problems" ==> E.array (map reportToJson (NE.toList reports))
179 ]
185 ]
180
186
@@ -182,7 +188,7 @@ toJson (Module name path _ source err) =
182reportToJson :: Report.Report -> E.Value
188reportToJson :: Report.Report -> E.Value
183reportToJson (Report.Report title region _sgstns message) =
189reportToJson (Report.Report title region _sgstns message) =
184 E.object
190 E.object
185− [ "title" ==> E.string (Utf8.fromChars title)
191+ [ "title" ==> E.chars title
186 , "region" ==> encodeRegion region
192 , "region" ==> encodeRegion region
187 , "message" ==> D.encode message
193 , "message" ==> D.encode message
188 ]
194 ]
@@ -193,12 +199,12 @@ encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
193 E.object
199 E.object
194 [ "start" ==>
200 [ "start" ==>
195 E.object
201 E.object
196− [ ("line", E.int (fromIntegral sr))
202+ [ "line" ==> E.int (fromIntegral sr)
197− , ("column", E.int (fromIntegral sc))
203+ , "column" ==> E.int (fromIntegral sc)
198 ]
204 ]
199 , "end" ==>
205 , "end" ==>
200 E.object
206 E.object
201− [ ("line", E.int (fromIntegral er))
207+ [ "line" ==> E.int (fromIntegral er)
202− , ("column", E.int (fromIntegral ec))
208+ , "column" ==> E.int (fromIntegral ec)
203 ]
209 ]
204 ]
210 ]
compiler/src/Reporting/Error/Canonicalize.hs+41−40
@@ -14,8 +14,10 @@ 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
17import qualified Data.Map as Map
18import qualified Data.Map as Map
18import qualified Data.Name as Name
19import qualified Data.Name as Name
20+import qualified Data.OneOrMore as OneOrMore
19import qualified Data.Set as Set
21import qualified Data.Set as Set
20
22
21import qualified AST.Canonical as Can
23import qualified AST.Canonical as Can
@@ -37,10 +39,10 @@ import qualified Reporting.Suggest as Suggest
37
39
38data Error
40data Error
39 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
41 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
40− | AmbiguousVar A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
42+ | AmbiguousVar A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
41− | AmbiguousType A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
43+ | AmbiguousType A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
42− | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
44+ | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
43− | AmbiguousBinop A.Region Name.Name [ModuleName.Canonical]
45+ | AmbiguousBinop A.Region Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
44 | BadArity A.Region BadArityContext Name.Name Int Int
46 | BadArity A.Region BadArityContext Name.Name Int Int
45 | Binop A.Region Name.Name Name.Name
47 | Binop A.Region Name.Name Name.Name
46 | DuplicateDecl Name.Name A.Region A.Region
48 | DuplicateDecl Name.Name A.Region A.Region
@@ -164,17 +166,17 @@ toReport source err =
164 <> " be deleted? Maybe some parentheses are missing?"
166 <> " be deleted? Maybe some parentheses are missing?"
165 )
167 )
166
168
167− AmbiguousVar region maybePrefix name possibleHomes ->
169+ AmbiguousVar region maybePrefix name h hs ->
168− ambiguousName source region maybePrefix name possibleHomes "variable"
170+ ambiguousName source region maybePrefix name h hs "variable"
169
171
170− AmbiguousType region maybePrefix name possibleHomes ->
172+ AmbiguousType region maybePrefix name h hs ->
171− ambiguousName source region maybePrefix name possibleHomes "type"
173+ ambiguousName source region maybePrefix name h hs "type"
172
174
173− AmbiguousVariant region maybePrefix name possibleHomes ->
175+ AmbiguousVariant region maybePrefix name h hs ->
174− ambiguousName source region maybePrefix name possibleHomes "variant"
176+ ambiguousName source region maybePrefix name h hs "variant"
175
177
176− AmbiguousBinop region name possibleHomes ->
178+ AmbiguousBinop region name h hs ->
177− ambiguousName source region Nothing name possibleHomes "operator"
179+ ambiguousName source region Nothing name h hs "operator"
178
180
179 BadArity region badArityContext name expected actual ->
181 BadArity region badArityContext name expected actual ->
180 let
182 let
@@ -242,11 +244,11 @@ toReport source err =
242
244
243 DuplicateAliasArg typeName name r1 r2 ->
245 DuplicateAliasArg typeName name r1 r2 ->
244 nameClash source r1 r2 $
246 nameClash source r1 r2 $
245− "The `" <> Name.toChars typeName <> "` type alias has multilpe `" <> Name.toChars name <> "` type variables."
247+ "The `" <> Name.toChars typeName <> "` type alias has multiple `" <> Name.toChars name <> "` type variables."
246
248
247 DuplicateUnionArg typeName name r1 r2 ->
249 DuplicateUnionArg typeName name r1 r2 ->
248 nameClash source r1 r2 $
250 nameClash source r1 r2 $
249− "The `" <> Name.toChars typeName <> "` type has multilpe `" <> Name.toChars name <> "` type variables."
251+ "The `" <> Name.toChars typeName <> "` type has multiple `" <> Name.toChars name <> "` type variables."
250
252
251 DuplicatePattern context name r1 r2 ->
253 DuplicatePattern context name r1 r2 ->
252 nameClash source r1 r2 $
254 nameClash source r1 r2 $
@@ -274,7 +276,7 @@ toReport source err =
274 "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
276 "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
275 ,
277 ,
276 D.reflow $
278 D.reflow $
277− "But I cannot find a union type named `" ++ Name.toChars name ++ "` in this file!"
279+ "But I cannot find a custom type named `" ++ Name.toChars name ++ "` in this file!"
278 )
280 )
279
281
280 EffectFunctionNotFound region name ->
282 EffectFunctionNotFound region name ->
@@ -342,7 +344,7 @@ toReport source err =
342 Code.toSnippet source region Nothing
344 Code.toSnippet source region Nothing
343 (
345 (
344 D.reflow $
346 D.reflow $
345− "The (..) syntax is for exposing union type constructors. It cannot be used with a type alias like `"
347+ "The (..) syntax is for exposing variants of a custom type. It cannot be used with a type alias like `"
346 ++ Name.toChars name ++ "` though."
348 ++ Name.toChars name ++ "` though."
347 ,
349 ,
348 D.reflow $
350 D.reflow $
@@ -355,12 +357,12 @@ toReport source err =
355 (
357 (
356 D.reflow $
358 D.reflow $
357 "You are trying to import the `" <> Name.toChars ctor
359 "You are trying to import the `" <> Name.toChars ctor
358− <> "` type constructor by name:"
360+ <> "` variant by name:"
359 ,
361 ,
360 D.fillSep
362 D.fillSep
361 ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
363 ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
362 ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
364 ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
363− ,"all","its","constructors”","so","it","gives","you","access","to"
365+ ,"all","its","variants","so","it","gives","you","access","to"
364 , D.fromName ctor <> "."
366 , D.fromName ctor <> "."
365 ]
367 ]
366 )
368 )
@@ -386,13 +388,8 @@ toReport source err =
386 D.reflow $
388 D.reflow $
387 "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
389 "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
388 ,
390 ,
389− D.stack
391+ D.reflow $
390− [ "Remove the (..) and it should work."
392+ "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− ]
396 )
393 )
397
394
398 ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
395 ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
@@ -522,7 +519,7 @@ toReport source err =
522 <> "` as a function, but it is not available in pattern matching like this:"
519 <> "` as a function, but it is not available in pattern matching like this:"
523 ,
520 ,
524 D.reflow $
521 D.reflow $
525− "I recommend matching matching the record as a variable and unpacking it later."
522+ "I recommend matching the record as a variable and unpacking it later."
526 )
523 )
527
524
528 PortPayloadInvalid region portName _badType invalidPayload ->
525 PortPayloadInvalid region portName _badType invalidPayload ->
@@ -682,7 +679,7 @@ toReport source err =
682 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
679 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
683 ,
680 ,
684 D.stack
681 D.stack
685− [ makeTheory "Are you are trying to mutate a variable?" $
682+ [ makeTheory "Are you trying to mutate a variable?" $
686 "Elm does not have mutation, so when I see " ++ Name.toChars name
683 "Elm does not have mutation, so when I see " ++ Name.toChars name
687 ++ " defined in terms of " ++ Name.toChars name
684 ++ " defined in terms of " ++ Name.toChars name
688 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
685 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -728,7 +725,7 @@ toReport source err =
728 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
725 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
729 ,
726 ,
730 D.stack
727 D.stack
731− [ makeTheory "Are you are trying to mutate a variable?" $
728+ [ makeTheory "Are you trying to mutate a variable?" $
732 "Elm does not have mutation, so when I see " ++ Name.toChars name
729 "Elm does not have mutation, so when I see " ++ Name.toChars name
733 ++ " defined in terms of " ++ Name.toChars name
730 ++ " defined in terms of " ++ Name.toChars name
734 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
731 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -979,28 +976,32 @@ nameClash source r1 r2 messageThatEndsWithPunctuation =
979-- AMBIGUOUS NAME
976-- AMBIGUOUS NAME
980
977
981
978
982−ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> [ModuleName.Canonical] -> String -> Report.Report
979+ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> ModuleName.Canonical -> OneOrMore.OneOrMore ModuleName.Canonical -> String -> Report.Report
983−ambiguousName source region maybePrefix name possibleHomes thing =
980+ambiguousName source region maybePrefix name h hs 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)
990+ D.dullyellow (D.fromName home <> "." <> D.fromName name)
991−
992− bothOrAll =
993− if length possibleHomes == 2 then "both" else "all"
994 in
991 in
995 (
992 (
996− D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous."
993+ D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous:"
997 ,
994 ,
998 D.stack
995 D.stack
999 [ D.reflow $
996 [ D.reflow $
1000− "Check your imports. The following modules " ++ bothOrAll
997+ "This name is exposed by " ++ show (length possibleHomes) ++ " of your imports, so I am not\
1001− ++ " expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ":"
998+ \ sure which one to use:"
1002 , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
999 , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
1003− , D.reflowLink "Read" "imports" "to learn how to clarify which one you want."
1000+ , D.reflow $
1001+ "I recommend using qualified names for imported values. I also recommend having\
1002+ \ at most one `exposing (..)` per file to make name clashes like this less common\
1003+ \ in the long run."
1004+ , D.link "Note" "Check out" "imports" "for more info on the import syntax."
1004 ]
1005 ]
1005 )
1006 )
1006
1007
@@ -1008,9 +1009,9 @@ ambiguousName source region maybePrefix name possibleHomes thing =
1008 let
1009 let
1009 homeToYellowDoc (ModuleName.Canonical _ home) =
1010 homeToYellowDoc (ModuleName.Canonical _ home) =
1010 if prefix == home then
1011 if prefix == home then
1011− D.blue "import" <+> D.dullyellow (D.fromName home)
1012+ D.cyan "import" <+> D.fromName home
1012 else
1013 else
1013− D.blue "import" <+> D.dullyellow (D.fromName home) <+> D.blue "as" <+> D.dullyellow (D.fromName prefix)
1014+ D.cyan "import" <+> D.fromName home <+> D.cyan "as" <+> D.fromName prefix
1014
1015
1015 eitherOrAny =
1016 eitherOrAny =
1016 if length possibleHomes == 2 then "either" else "any"
1017 if length possibleHomes == 2 then "either" else "any"
compiler/src/Reporting/Error/Docs.hs+127−18
@@ -2,17 +2,24 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Docs
3module Reporting.Error.Docs
4 ( Error(..)
4 ( Error(..)
5− , toReport
5+ , SyntaxProblem(..)
6+ , NameProblem(..)
7+ , DefProblem(..)
8+ , toReports
6 )
9 )
7 where
10 where
8
11
9
12
10import qualified Data.Name as Name
13import qualified Data.Name as Name
14+import qualified Data.NonEmptyList as NE
11
15
16+import Parse.Primitives (Row, Col)
17+import Parse.Symbol (BadOperator(..))
12import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
13import Reporting.Doc ((<>))
19import Reporting.Doc ((<>))
14import qualified Reporting.Doc as D
20import qualified Reporting.Doc as D
15import qualified Reporting.Render.Code as Code
21import qualified Reporting.Render.Code as Code
22+import qualified Reporting.Error.Syntax as E
16import qualified Reporting.Report as Report
23import qualified Reporting.Report as Report
17
24
18
25
@@ -20,36 +27,56 @@ import qualified Reporting.Report as Report
20data Error
27data Error
21 = NoDocs A.Region
28 = NoDocs A.Region
22 | ImplicitExposing A.Region
29 | ImplicitExposing A.Region
30+ | SyntaxProblem SyntaxProblem
31+ | NameProblems (NE.List NameProblem)
32+ | DefProblems (NE.List DefProblem)
33+
34+
35+data SyntaxProblem
36+ = Op Row Col
37+ | OpBad BadOperator Row Col
38+ | Name Row Col
39+ | Space E.Space Row Col
40+ | Comma Row Col
41+ | BadEnd Row Col
42+
43+
44+data NameProblem
23− | Duplicate Name.Name A.Region A.Region
45+ = NameDuplicate Name.Name A.Region A.Region
24− | OnlyInDocs Name.Name A.Region
46+ | NameOnlyInDocs Name.Name A.Region
25− | OnlyInExports Name.Name A.Region
47+ | NameOnlyInExports Name.Name A.Region
48+
49+
50+data DefProblem
26− | NoComment Name.Name A.Region
51+ = NoComment Name.Name A.Region
27 | NoAnnotation Name.Name A.Region
52 | NoAnnotation Name.Name A.Region
28
53
29
54
30
55
31−-- TO REPORT
56+-- TO REPORTS
32
57
33
58
34−toReport :: Code.Source -> Error -> Report.Report
59+toReports :: Code.Source -> Error -> NE.List Report.Report
35−toReport source err =
60+toReports source err =
36 case err of
61 case err of
37 NoDocs region ->
62 NoDocs region ->
63+ NE.singleton $
38 Report.Report "NO DOCS" region [] $
64 Report.Report "NO DOCS" region [] $
39− D.stack
65+ Code.toSnippet source region Nothing
40− [
66+ (
41 D.reflow $
67 D.reflow $
42 "You must have a documentation comment between the module\
68 "You must have a documentation comment between the module\
43 \ declaration and the imports."
69 \ declaration and the imports."
44 ,
70 ,
45 D.reflow
71 D.reflow
46− "Learn more at <http://package.elm-lang.org/help/documentation-format>"
72+ "Learn more at <https://package.elm-lang.org/help/documentation-format>"
47− ]
73+ )
48
74
49 ImplicitExposing region ->
75 ImplicitExposing region ->
76+ NE.singleton $
50 Report.Report "IMPLICIT EXPOSING" region [] $
77 Report.Report "IMPLICIT EXPOSING" region [] $
51− D.stack
78+ Code.toSnippet source region Nothing
52− [
79+ (
53 D.reflow $
80 D.reflow $
54 "I need you to be explicit about what this module exposes:"
81 "I need you to be explicit about what this module exposes:"
55 ,
82 ,
@@ -59,9 +86,83 @@ toReport source err =
59 \ to be explicit about this is a way of adding another quality check before\
86 \ to be explicit about this is a way of adding another quality check before\
60 \ code gets published. So as you write out the public API, ask yourself if\
87 \ code gets published. So as you write out the public API, ask yourself if\
61 \ it will be easy to understand as people read the documentation!"
88 \ it will be easy to understand as people read the documentation!"
62− ]
89+ )
90+
91+ SyntaxProblem problem ->
92+ NE.singleton $
93+ toSyntaxProblemReport source problem
94+
95+ NameProblems problems ->
96+ fmap (toNameProblemReport source) problems
97+
98+ DefProblems problems ->
99+ fmap (toDefProblemReport source) problems
100+
101+
102+
103+-- SYNTAX PROBLEM
104+
63
105
106+toSyntaxProblemReport :: Code.Source -> SyntaxProblem -> Report.Report
107+toSyntaxProblemReport source problem =
108+ let
109+ toSyntaxReport row col details =
110+ let
111+ region = toRegion row col
112+ in
113+ Report.Report "PROBLEM IN DOCS" region [] $
114+ Code.toSnippet source region Nothing
115+ ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:"
116+ , D.stack $
117+ [ D.reflow details
118+ , D.toSimpleHint $
119+ "Read through <https://package.elm-lang.org/help/documentation-format> for\
120+ \ tips on how to write module documentation!"
121+ ]
122+ )
123+ in
124+ case problem of
125+ Op row col ->
126+ toSyntaxReport row col $
127+ "I am trying to parse an operator like (+) or (*) but something is going wrong."
128+
129+ OpBad _ row col ->
130+ toSyntaxReport row col $
131+ "I am trying to parse an operator like (+) or (*) but it looks like you are using\
132+ \ a reserved symbol in this case."
133+
134+ Name row col ->
135+ toSyntaxReport row col $
136+ "I was expecting to see the name of another exposed value from this module."
137+
138+ Space space row col ->
139+ E.toSpaceReport source space row col
140+
141+ Comma row col ->
142+ toSyntaxReport row col $
143+ "I was expecting to see a comma next."
144+
145+ BadEnd row col ->
146+ toSyntaxReport row col $
147+ "I am not really sure what I am getting stuck on though."
148+
149+
150+toRegion :: Row -> Col -> A.Region
151+toRegion row col =
152+ let
153+ pos = A.Position row col
154+ in
155+ A.Region pos pos
156+
157+
158+
159+-- NAME PROBLEM
160+
161+
162+toNameProblemReport :: Code.Source -> NameProblem -> Report.Report
163+toNameProblemReport source problem =
164+ case problem of
64− Duplicate name r1 r2 ->
165+ NameDuplicate name r1 r2 ->
65 Report.Report "DUPLICATE DOCS" r2 [] $
166 Report.Report "DUPLICATE DOCS" r2 [] $
66 Code.toPair source r1 r2
167 Code.toPair source r1 r2
67 (
168 (
@@ -81,7 +182,7 @@ toReport source err =
81 "Remove one of them!"
182 "Remove one of them!"
82 )
183 )
83
184
84− OnlyInDocs name region ->
185+ NameOnlyInDocs name region ->
85 Report.Report "DOCS MISTAKE" region [] $
186 Report.Report "DOCS MISTAKE" region [] $
86 Code.toSnippet source region Nothing
187 Code.toSnippet source region Nothing
87 (
188 (
@@ -94,7 +195,7 @@ toReport source err =
94 <> Name.toChars name <> "` and forgot to delete it here?"
195 <> Name.toChars name <> "` and forgot to delete it here?"
95 )
196 )
96
197
97− OnlyInExports name region ->
198+ NameOnlyInExports name region ->
98 Report.Report "DOCS MISTAKE" region [] $
199 Report.Report "DOCS MISTAKE" region [] $
99 Code.toSnippet source region Nothing
200 Code.toSnippet source region Nothing
100 (
201 (
@@ -110,6 +211,14 @@ toReport source err =
110 ]
211 ]
111 )
212 )
112
213
214+
215+
216+-- DEF PROBLEM
217+
218+
219+toDefProblemReport :: Code.Source -> DefProblem -> Report.Report
220+toDefProblemReport source problem =
221+ case problem of
113 NoComment name region ->
222 NoComment name region ->
114 Report.Report "NO DOCS" region [] $
223 Report.Report "NO DOCS" region [] $
115 Code.toSnippet source region Nothing
224 Code.toSnippet source region Nothing
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\" listend in your elm.json,\
59+ "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json,\
60 \ but I cannot find it! Maybe it is a typo for one of these names?"
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+281−269
@@ -1,332 +1,344 @@
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(..)
8− , toReport
4+ ( toReport
5+ , FailureToReport(..)
6+ , Context(..)
7+ , Reason(..)
9 )
8 )
10 where
9 where
11
10
12
11
13−import qualified Data.Utf8 as Utf8
12+import qualified Data.ByteString as BS
14−import Data.Word (Word16)
13+import qualified Data.ByteString.UTF8 as BS_UTF8
14+import qualified Data.NonEmptyList as NE
15
15
16−import qualified Reporting.Report as Report
16+import Json.Decode (Error(..), Problem(..), DecodeExpectation(..), ParseError(..), StringProblem(..))
17−
17+import qualified Reporting.Annotation as A
18−
18+import qualified Reporting.Doc as D
19−
19+import qualified Reporting.Exit.Help as Help
20−-- ERROR
20+import qualified Reporting.Render.Code as Code
21−
22−
23−data Error e
24− = DecodeProblem (Problem e)
25− | ParseProblem ParseError
26−
27−
28−
29−-- DECODE PROBLEMS
30−
31−
32−data Problem e
33− = Field Utf8.String (Problem e)
34− | Index Int (Problem e)
35− | OneOf (Problem e) [Problem e]
36− | Failure e
37− | Expecting DecodeExpectation
38−
39−
40−data DecodeExpectation
41− = TObject
42− | TArray
43− | TString
44− | TBool
45− | TInt
46− | TObjectWith Utf8.String
47− | TArrayPair Int
48−
49−
50−
51−-- PARSE ERROR
52−
53−
54−data ParseError
55− = PIndex Int ParseError Row Col
56− | PField Utf8.String ParseError Row Col
57− | ObjectStart Row Col
58− | ObjectMore Row Col
59− | ObjectEnd Row Col
60− | ArrayStart Row Col
61− | ArrayMore Row Col
62− | ArrayEnd Row Col
63− | StringStart Row Col
64− | StringEnd Row Col
65− | IntStart Row Col
66− | NoLeadingZeros Row Col
67− | NoFloats Row Col
68− | Bool Row Col
69− | Null Row Col
70− | Value Row Col
71− | Colon Row Col
72− | EndOfFile Row Col
73−
74−
75−type Row = Word16
76−type Col = Word16
77
21
78
22
79
23
80-- TO REPORT
24-- TO REPORT
81
25
82
26
83−toReport :: Error e -> Report.Report
27+toReport :: FilePath -> FailureToReport x -> Error x -> Reason -> Help.Report
84−toReport err =
28+toReport path ftr err reason =
85− error "TODO Reporting.Error.Json.toReport" err
29+ case err of
86−
30+ DecodeProblem bytes problem ->
87−
31+ problemToReport path ftr (Code.toSource bytes) CRoot problem reason
88−{-
89−
90−-- ERROR
91
32
33+ ParseProblem bytes parseError ->
34+ parseErrorToReport path (Code.toSource bytes) parseError reason
92
35
93−data Error e
94− = BadJson Syntax.Error
95− | BadContent (Json.Error e)
96
36
37+newtype Reason =
38+ ExplicitReason String
97
39
98
40
99−-- TO DOC
41+because :: Reason -> String -> String
42+because (ExplicitReason iNeedThings) problem =
43+ iNeedThings ++ " " ++ problem
100
44
101
45
102−toDoc :: String -> Code.Source -> (e -> [D.Doc]) -> Error e -> D.Doc
103−toDoc rootName source userErrorToDocs err =
104− case err of
105− BadJson syntaxError ->
106− case Syntax.toReport source syntaxError of
107− Report.Report _ _ _ doc ->
108− doc
109−
110− BadContent jsonError ->
111− case flatten jsonError of
112− [] ->
113− D.reflow
114− "I am not sure what is wrong with this JSON. Please create an <http://sscce.org>\
115− \ and share it at <https://github.com/elm/compiler/issues> so I can\
116− \ provide a helpful hint here!"
117−
118− [flatError] ->
119− flatErrorToDoc rootName [] userErrorToDocs flatError
120−
121− flatErrors ->
122− let
123− toNumberedDoc index flatErr =
124− D.dullcyan ("(" <> D.fromInt index <> ")") <+> flatErrorToDoc rootName [] userErrorToDocs flatErr
125− in
126− D.stack $
127− [ D.reflow $
128− "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"
129− ]
130− ++ zipWith toNumberedDoc [1..] flatErrors
131
46
47+-- PARSE ERROR TO REPORT
132
48
133
49
134−-- FLAT ERROR TO DOC
50+parseErrorToReport :: FilePath -> Code.Source -> ParseError -> Reason -> Help.Report
135−
51+parseErrorToReport path source parseError reason =
136−
52+ let
137−flatErrorToDoc :: String -> [D.Doc] -> (e -> [D.Doc]) -> FlatError e -> D.Doc
53+ toSnippet title row col (problem, details) =
138−flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =
139− case theories of
140− [] ->
141 let
54 let
142− explanation =
55+ pos = A.Position row col
143− case theory of
56+ surroundings = A.Region (A.Position (max 1 (row - 2)) 1) pos
144− Failure userError ->
57+ region = A.Region pos pos
145− userErrorToDocs userError
146−
147− Expecting tipe ->
148− ["I","was","expecting"] ++ anExpectedThing tipe
149 in
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
150− case accesses of
65+ case parseError of
151− [] ->
66+ Start row col ->
152− D.fillSep (starter ++ explanation)
67+ toSnippet "EXPECTING A VALUE" row col
153−
68+ (
154− _ ->
69+ "I was expecting to see a JSON value next:"
70+ ,
155 D.stack
71 D.stack
156− [ D.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]
72+ [ D.fillSep
157− , D.fillSep explanation
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!"
158 ]
80 ]
81+ )
159
82
160− _:_ ->
83+ ObjectField row col ->
161− let
84+ toSnippet "EXTRA COMMA" row col
162− introduction =
85+ (
163− case accesses of
86+ "I was partway through parsing a JSON object when I got stuck here:"
164− [] ->
87+ ,
165− ["I","am","having","trouble","with","the"]
166− ++ actualThing json
167− ++ ["here","because:"]
168−
169− _ ->
170− ["I","am","having","trouble","with","the"]
171− ++ actualThing json
172− ++ ["at",accessToDoc rootName accesses,"because:"]
173− in
174− D.stack
88+ D.stack
175− [ D.fillSep (starter ++ introduction)
89+ [ D.fillSep
176− , D.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)
90+ ["I","saw","a","comma","right","before","I","got","stuck","here,"
177− , D.reflow "I accept any of these things."
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
178− ]
99+ ]
100+ )
179
101
102+ ObjectColon row col ->
103+ toSnippet "EXPECTING COLON" row col
104+ (
105+ "I was partway through parsing a JSON object when I got stuck here:"
106+ ,
107+ D.stack
108+ [ D.reflow $ "I was expecting to see a colon next."
109+ , objectNote
110+ ]
111+ )
180
112
181−accessToDoc :: String -> [String] -> D.Doc
113+ ObjectEnd row col ->
182−accessToDoc rootName accesses =
114+ toSnippet "UNFINISHED OBJECT" row col
183− D.dullyellow (D.fromString (rootName ++ concat accesses))
115+ (
116+ "I was partway through parsing a JSON object when I got stuck here:"
117+ ,
118+ D.stack
119+ [ D.reflow $
120+ "I was expecting to see a comma or a closing curly brace next."
121+ , D.reflow $
122+ "Is a comma missing on the previous line? Is an array missing a closing square\
123+ \ bracket? It is often something tricky like that!"
124+ , objectNote
125+ ]
126+ )
184
127
128+ ArrayEnd row col ->
129+ toSnippet "UNFINISHED ARRAY" row col
130+ (
131+ "I was partway through parsing a JSON array when I got stuck here:"
132+ ,
133+ D.stack
134+ [ D.reflow $ "I was expecting to see a comma or a closing square bracket next."
135+ , D.reflow $
136+ "Is a comma missing on the previous line? It is often something like that!"
137+ ]
138+ )
139+
140+ StringProblem stringProblem row col ->
141+ case stringProblem of
142+ BadStringEnd ->
143+ toSnippet "ENDLESS STRING" row col
144+ (
145+ "I got to the end of the line without seeing the closing double quote:"
146+ ,
147+ D.fillSep $
148+ ["Strings","look","like",D.green "\"this\"","with","double"
149+ ,"quotes","on","each","end.","Is","the","closing","double"
150+ ,"quote","missing","in","your","code?"
151+ ]
152+ )
153+
154+ BadStringControlChar ->
155+ toSnippet "UNEXPECTED CONTROL CHARACTER" row col
156+ (
157+ "I ran into a control character unexpectedly:"
158+ ,
159+ D.reflow $
160+ "These are characters that represent tabs, backspaces, newlines, and\
161+ \ a bunch of other invisible characters. They all come before 20 in the\
162+ \ ASCII range, and they are disallowed by the JSON specificaiton. Maybe\
163+ \ a copy/paste added one of these invisible characters to your JSON?"
164+ )
165+
166+ BadStringEscapeChar ->
167+ toSnippet "UNKNOWN ESCAPE" row col
168+ (
169+ "Backslashes always start escaped characters, but I do not recognize this one:"
170+ ,
171+ D.stack
172+ [ D.reflow $
173+ "Valid escape characters include:"
174+ , D.dullyellow $ D.indent 4 $ D.vcat $
175+ ["\\\"","\\\\","\\/","\\b","\\f","\\n","\\r","\\t","\\u003D"]
176+ , D.reflow $
177+ "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?"
178+ ]
179+ )
180+
181+ BadStringEscapeHex ->
182+ toSnippet "BAD HEX ESCAPE" row col
183+ (
184+ "This is not a valid hex escape:"
185+ ,
186+ D.fillSep $
187+ ["Valid","hex","escapes","in","JSON","are","between"
188+ ,D.green "\\u0000","and",D.green "\\uFFFF"
189+ ,"and","always","have","exactly","four","digits."
190+ ]
191+ )
192+
193+ NoLeadingZeros row col ->
194+ toSnippet "BAD NUMBER" row col
195+ (
196+ "Numbers cannot start with zeros like this:"
197+ ,
198+ D.reflow $ "Try deleting the leading zeros?"
199+ )
200+
201+ NoFloats row col ->
202+ toSnippet "UNEXPECTED NUMBER" row col
203+ (
204+ "I got stuck while trying to parse this number:"
205+ ,
206+ D.reflow $
207+ "I do not accept floating point numbers like 3.1415 right now. That kind\
208+ \ of JSON value is not needed for any of the uses that Elm has for now."
209+ )
210+
211+ BadEnd row col ->
212+ toSnippet "JSON PROBLEM" row col
213+ (
214+ "I was partway through parsing some JSON when I got stuck here:"
215+ ,
216+ D.reflow $
217+ "I am not really sure what is wrong. This sometimes means there is extra\
218+ \ stuff after a valid JSON value?"
219+ )
220+
221+
222+objectNote :: D.Doc
223+objectNote =
224+ D.stack
225+ [ D.toSimpleNote $ "Here is an example of a valid JSON object for reference:"
226+ , D.vcat
227+ [ D.indent 4 $ "{"
228+ , D.indent 6 $ D.dullyellow "\"name\"" <> ": " <> D.dullyellow "\"Tom\"" <> ","
229+ , D.indent 6 $ D.dullyellow "\"age\"" <> ": " <> D.dullyellow "42"
230+ , D.indent 4 $ "}"
231+ ]
232+ , D.reflow $
233+ "Notice that (1) the field names are in double quotes and (2) there is no\
234+ \ trailing comma after the last entry. Both are strict requirements in JSON!"
235+ ]
185
236
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"]
196
237
197
238
198−anExpectedThing :: Json.Type -> [D.Doc]
239+-- PROBLEM TO REPORT
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− ]
211
240
212
241
213−toBullet :: [D.Doc] -> (e -> [D.Doc]) -> Theory e -> D.Doc
242+data Context
214−toBullet intro userErrorToDocs theory =
243+ = CRoot
215− D.indent 4 $ D.fillSep $ (++) intro $
244+ | CField BS.ByteString Context
216− case theory of
245+ | CIndex Int Context
217− Failure userError ->
218− userErrorToDocs userError
219
246
220− Expecting tipe ->
221− ["I","was","expecting"] ++ anExpectedThing tipe
222
247
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
223
253
254+ Index index prob ->
255+ problemToReport path ftr source (CIndex index context) prob reason
224
256
225−-- TO FLAT ERRORS
257+ OneOf p ps ->
258+ -- NOTE: only displays the deepest problem. This works well for the kind
259+ -- of JSON used by Elm, but probably would not work well in general.
260+ let
261+ (NE.List prob _) = NE.sortBy (negate . getMaxDepth) (NE.List p ps)
262+ in
263+ problemToReport path ftr source context prob reason
226
264
265+ Failure region x ->
266+ _failureToReport ftr path source context region x
227
267
228−data FlatError e =
268+ Expecting region expectation ->
229− FlatError [String] E.Value (Theory e) [Theory e]
269+ expectationToReport path source context region expectation reason
230
270
231
271
232−data Theory e
272+getMaxDepth :: Problem x -> Int
273+getMaxDepth problem =
274+ case problem of
275+ Field _ prob -> 1 + getMaxDepth prob
276+ Index _ prob -> 1 + getMaxDepth prob
277+ OneOf p ps -> maximum (getMaxDepth p : map getMaxDepth ps)
233− = Failure e
278+ Failure _ _ -> 0
234− | Expecting Json.Type
279+ Expecting _ _ -> 0
235
280
236
281
237−flatten :: Json.Error e -> [FlatError e]
282+newtype FailureToReport x =
238−flatten jsonError =
283+ FailureToReport { _failureToReport :: FilePath -> Code.Source -> Context -> A.Region -> x -> Help.Report }
239− let
240− depth (FlatError accesses _ _ _) =
241− length accesses
242− in
243− List.sortOn depth $ flattenTree (toErrorTree jsonError)
244
284
245
285
246−flattenTree :: ErrorTree e -> [FlatError e]
286+expectationToReport :: FilePath -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Reason -> Help.Report
247−flattenTree (ErrorTree theories subTrees) =
287+expectationToReport path source context (A.Region start end) expectation reason =
248 let
288 let
249− addAccess access (FlatError accesses json t ts) =
289+ (A.Position sr _) = start
250− FlatError (access:accesses) json t ts
290+ (A.Position er _) = end
251
291
252− toFlats (name, tree) =
292+ region =
253− map (addAccess name) (flattenTree tree)
293+ if sr == er then region else A.Region start start
254−
255− subErrors =
256− concatMap toFlats (Map.toList subTrees)
257− in
258− case theories of
259− [] ->
260− subErrors
261
294
262− (json, theory) : rest ->
295+ introduction =
263− FlatError [] json theory (map snd rest) : subErrors
296+ case context of
297+ CRoot ->
298+ "I ran into some trouble here:"
264
299
300+ CField field _ ->
301+ "I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:"
265
302
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:"
266
306
267−-- TO ERROR TREE
307+ CIndex index _ ->
308+ "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:"
268
309
269−
310+ toSnippet title aThing =
270−data ErrorTree e =
311+ Help.jsonReport title (Just path) $
271− ErrorTree
312+ Code.toSnippet source region Nothing
272− { _theories :: [(E.Value, Theory e)]
313+ ( D.reflow (because reason introduction)
273− , _subErrors :: Map.Map String (ErrorTree e)
314+ , D.fillSep $ ["I","was","expecting","to","run","into"] ++ aThing
274− }
315+ )
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))
311 in
316 in
312− Map.alter subAdd name subErrors
317+ case expectation of
318+ TObject ->
319+ toSnippet "EXPECTING OBJECT" ["an", D.green "OBJECT" <> "."]
313
320
321+ TArray ->
322+ toSnippet "EXPECTING ARRAY" ["an", D.green "ARRAY" <> "."]
314
323
315−fieldToName :: Text.Text -> String
324+ TString ->
316−fieldToName field =
325+ toSnippet "EXPECTING STRING" ["a", D.green "STRING" <> "."]
317− case Text.unpack field of
318− [] ->
319− "['']"
320
326
321− string@(char : rest) ->
327+ TBool ->
322− if Char.isAlpha char && all Char.isAlphaNum rest then
328+ toSnippet "EXPECTING BOOL" ["a", D.green "BOOLEAN" <> "."]
323− '.' : string
324− else
325− "['" ++ string ++ "']"
326
329
330+ TInt ->
331+ toSnippet "EXPECTING INT" ["an", D.green "INT" <> "."]
327
332
328−indexToName :: Int -> String
333+ TObjectWith field ->
329−indexToName index =
334+ toSnippet "MISSING FIELD"
330− "[" ++ show index ++ "]"
335+ ["an",D.green "OBJECT","with","a"
336+ ,D.green ("\"" <> D.fromChars (BS_UTF8.toString field) <> "\"")
337+ ,"field."
338+ ]
331
339
332−-}
340+ TArrayPair len ->
341+ toSnippet "EXPECTING PAIR"
342+ ["an",D.green "ARRAY","with",D.green "TWO","entries."
343+ ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
344+ ]
compiler/src/Reporting/Error/Pattern.hs+5−4
@@ -8,6 +8,7 @@ module Reporting.Error.Pattern
8
8
9import qualified Data.List as List
9import qualified Data.List as List
10
10
11+import qualified Elm.String as ES
11import qualified Nitpick.PatternMatches as P
12import qualified Nitpick.PatternMatches as P
12import Reporting.Doc ((<>))
13import Reporting.Doc ((<>))
13import qualified Reporting.Doc as D
14import qualified Reporting.Doc as D
@@ -40,7 +41,7 @@ toReport source err =
40 Report.Report "UNSAFE PATTERN" region [] $
41 Report.Report "UNSAFE PATTERN" region [] $
41 Code.toSnippet source region Nothing
42 Code.toSnippet source region Nothing
42 (
43 (
43− "This pattern does not cover all possiblities:"
44+ "This pattern does not cover all possibilities:"
44 ,
45 ,
45 D.stack
46 D.stack
46 [ "Other possibilities include:"
47 [ "Other possibilities include:"
@@ -63,7 +64,7 @@ toReport source err =
63 , unhandledPatternsToDocBlock unhandled
64 , unhandledPatternsToDocBlock unhandled
64 , D.reflow $
65 , D.reflow $
65 "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\
66− \ `let` to deconstruct values only if there is ONE possiblity.\
67+ \ `let` to deconstruct values only if there is ONE possibility.\
67 \ Switch to a `case` expression to account for all possibilities."
68 \ Switch to a `case` expression to account for all possibilities."
68 , D.toSimpleHint $
69 , D.toSimpleHint $
69 "Are you calling a function that definitely returns values\
70 "Are you calling a function that definitely returns values\
@@ -117,10 +118,10 @@ patternToDoc context pattern =
117 NonList (P.Literal literal) ->
118 NonList (P.Literal literal) ->
118 case literal of
119 case literal of
119 P.Chr chr ->
120 P.Chr chr ->
120− "'" <> D.fromUtf8 chr <> "'"
121+ "'" <> D.fromChars (ES.toChars chr) <> "'"
121
122
122 P.Str str ->
123 P.Str str ->
123− "\"" <> D.fromUtf8 str <> "\""
124+ "\"" <> D.fromChars (ES.toChars str) <> "\""
124
125
125 P.Int int ->
126 P.Int int ->
126 D.fromInt int
127 D.fromInt int
compiler/src/Reporting/Error/Syntax.hs+1028−452
@@ -2,6 +2,7 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Syntax
3module Reporting.Error.Syntax
4 ( Error(..)
4 ( Error(..)
5+ , toReport
5 --
6 --
6 , Module(..)
7 , Module(..)
7 , Exposing(..)
8 , Exposing(..)
@@ -39,7 +40,7 @@ module Reporting.Error.Syntax
39 , Number(..)
40 , Number(..)
40 --
41 --
41 , Space(..)
42 , Space(..)
42− , toReport
43+ , toSpaceReport
43 )
44 )
44 where
45 where
45
46
@@ -68,6 +69,9 @@ data Error
68 | ModuleNameMismatch ModuleName.Raw (A.Located ModuleName.Raw)
69 | ModuleNameMismatch ModuleName.Raw (A.Located ModuleName.Raw)
69 | UnexpectedPort A.Region
70 | UnexpectedPort A.Region
70 | NoPorts A.Region
71 | NoPorts A.Region
72+ | NoPortsInPackage (A.Located Name.Name)
73+ | NoPortModulesInPackage A.Region
74+ | NoEffectsOutsideKernel A.Region
71 | ParseError Module
75 | ParseError Module
72
76
73
77
@@ -77,7 +81,7 @@ data Error
77
81
78data Module
82data Module
79 = ModuleSpace Space Row Col
83 = ModuleSpace Space Row Col
80− | ModuleEndOfFile Row Col
84+ | ModuleBadEnd Row Col
81 --
85 --
82 | ModuleProblem Row Col
86 | ModuleProblem Row Col
83 | ModuleName Row Col
87 | ModuleName Row Col
@@ -516,7 +520,7 @@ toReport source err =
516 ,
520 ,
517 D.stack
521 D.stack
518 [ D.reflow $
522 [ D.reflow $
519− "I need it to match the file path, so I was expecting it to see `"
523+ "I need it to match the file path, so I was expecting to see `"
520 ++ ModuleName.toChars expectedName
524 ++ ModuleName.toChars expectedName
521 ++ "` here. Make the following change, and you should be all set!"
525 ++ "` here. Make the following change, and you should be all set!"
522 , D.indent 4 $
526 , D.indent 4 $
@@ -560,75 +564,94 @@ toReport source err =
560 ]
564 ]
561 )
565 )
562
566
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+
563 ParseError modul ->
619 ParseError modul ->
564 toParseErrorReport source modul
620 toParseErrorReport source modul
565
621
566
622
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+
567toParseErrorReport :: Code.Source -> Module -> Report.Report
645toParseErrorReport :: Code.Source -> Module -> Report.Report
568toParseErrorReport source modul =
646toParseErrorReport source modul =
569 case modul of
647 case modul of
570 ModuleSpace space row col ->
648 ModuleSpace space row col ->
571 toSpaceReport source space row col
649 toSpaceReport source space row col
572
650
573− ModuleEndOfFile row col ->
651+ ModuleBadEnd row col ->
574− case Code.whatIsNext source row col of
652+ if col == 1
575− Code.Keyword keyword ->
653+ then toDeclStartReport source row col
576− let
654+ else toWeirdEndReport source row col
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− )
632
655
633 ModuleProblem row col ->
656 ModuleProblem row col ->
634 let
657 let
@@ -774,15 +797,15 @@ toParseErrorReport source modul =
774 [ D.reflow $
797 [ D.reflow $
775 "I am not sure what is going on, but I recommend starting an Elm\
798 "I am not sure what is going on, but I recommend starting an Elm\
776 \ file with the following lines:"
799 \ file with the following lines:"
777− , D.vcat
800+ , D.indent 4 $ D.vcat $
778 [ D.fillSep [D.cyan "import","Html"]
801 [ D.fillSep [D.cyan "import","Html"]
779 , ""
802 , ""
780− , D.fillSep [D.green "main","="]
803+ , "main ="
781− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
804+ , " Html.text " <> D.dullyellow "\"Hello!\""
782 ]
805 ]
783 , D.reflow $
806 , D.reflow $
784− "You should be able to copy those lines directly into your file. Check out\
807+ "You should be able to copy those lines directly into your file. Check out the\
785− \ some of the examples on https://elm-lang.org for more help getting started!"
808+ \ examples at <https://elm-lang.org/examples> for more help getting started!"
786 , D.toSimpleNote $
809 , D.toSimpleNote $
787 "This can also happen when something is indented too much!"
810 "This can also happen when something is indented too much!"
788 ]
811 ]
@@ -807,11 +830,12 @@ toParseErrorReport source modul =
807 , D.indent 4 $ D.vcat $
830 , D.indent 4 $ D.vcat $
808 [ D.fillSep [D.cyan "import","Dict"]
831 [ D.fillSep [D.cyan "import","Dict"]
809 , D.fillSep [D.cyan "import","Maybe"]
832 , D.fillSep [D.cyan "import","Maybe"]
810− , D.fillSep [D.cyan "import","Html.Attributes"]
833+ , D.fillSep [D.cyan "import","Html.Attributes",D.cyan "as","A"]
811− , D.fillSep [D.cyan "import","Json.Decode"]
834+ , D.fillSep [D.cyan "import","Json.Decode",D.cyan "exposing","(..)"]
812 ]
835 ]
813 , D.reflow $
836 , D.reflow $
814 "Notice that the module names all start with capital letters. That is required!"
837 "Notice that the module names all start with capital letters. That is required!"
838+ , D.reflowLink "Read" "imports" "to learn more."
815 ]
839 ]
816 )
840 )
817
841
@@ -822,7 +846,7 @@ toParseErrorReport source modul =
822 let
846 let
823 region = toRegion row col
847 region = toRegion row col
824 in
848 in
825− Report.Report "EXECTING IMPORT ALIAS" region [] $
849+ Report.Report "EXPECTING IMPORT ALIAS" region [] $
826 Code.toSnippet source region Nothing
850 Code.toSnippet source region Nothing
827 (
851 (
828 D.reflow $
852 D.reflow $
@@ -838,6 +862,7 @@ toParseErrorReport source modul =
838 ]
862 ]
839 , D.reflow $
863 , D.reflow $
840 "Notice that the alias always starts with a capital letter. That is required!"
864 "Notice that the alias always starts with a capital letter. That is required!"
865+ , D.reflowLink "Read" "imports" "to learn more."
841 ]
866 ]
842 )
867 )
843
868
@@ -900,6 +925,192 @@ toParseErrorReport source modul =
900
925
901
926
902
927
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+
903-- IMPORTS
1114-- IMPORTS
904
1115
905
1116
@@ -925,6 +1136,7 @@ toImportReport source row col =
925 ]
1136 ]
926 , D.reflow $
1137 , D.reflow $
927 "You are probably trying to import a different module, but try to make it look like one of these examples!"
1138 "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."
928 ]
1140 ]
929 )
1141 )
930
1142
@@ -1231,106 +1443,7 @@ toDeclarationsReport :: Code.Source -> Decl -> Report.Report
1231toDeclarationsReport source decl =
1443toDeclarationsReport source decl =
1232 case decl of
1444 case decl of
1233 DeclStart row col ->
1445 DeclStart row col ->
1234− case Code.whatIsNext source row col of
1446+ toDeclStartReport source row col
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− )
1334
1447
1335 DeclSpace space row col ->
1448 DeclSpace space row col ->
1336 toSpaceReport source space row col
1449 toSpaceReport source space row col
@@ -1360,6 +1473,165 @@ toDeclarationsReport source decl =
1360 )
1473 )
1361
1474
1362
1475
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+
1363
1635
1364-- PORT
1636-- PORT
1365
1637
@@ -1486,7 +1758,7 @@ toPortReport source port_ startRow startCol =
1486 [ D.reflow $
1758 [ D.reflow $
1487 "I was expecting to see a type next. Here are examples of outgoing and\
1759 "I was expecting to see a type next. Here are examples of outgoing and\
1488 \ incoming ports for reference:"
1760 \ incoming ports for reference:"
1489− , D.vcat
1761+ , D.indent 4 $ D.vcat $
1490 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1762 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1491 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1763 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1492 ]
1764 ]
@@ -1505,7 +1777,7 @@ portNote =
1505 D.stack
1777 D.stack
1506 [ D.toSimpleNote $
1778 [ D.toSimpleNote $
1507 "Here are some example `port` declarations for reference:"
1779 "Here are some example `port` declarations for reference:"
1508− , D.vcat
1780+ , D.indent 4 $ D.vcat $
1509 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1781 [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
1510 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1782 , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
1511 ]
1783 ]
@@ -1635,7 +1907,7 @@ toTypeAliasReport source typeAlias startRow startCol =
1635 ,
1907 ,
1636 D.stack
1908 D.stack
1637 [ D.reflow $
1909 [ D.reflow $
1638− "I was expecting to see a type variable or an an equals sign next."
1910+ "I was expecting to see a type variable or an equals sign next."
1639 , typeAliasNote
1911 , typeAliasNote
1640 ]
1912 ]
1641 )
1913 )
@@ -1656,7 +1928,7 @@ toTypeAliasReport source typeAlias startRow startCol =
1656 ,
1928 ,
1657 D.stack
1929 D.stack
1658 [ D.reflow $
1930 [ D.reflow $
1659− "I was expecting to see a type variable or an an equals sign next."
1931+ "I was expecting to see a type variable or an equals sign next."
1660 , typeAliasNote
1932 , typeAliasNote
1661 ]
1933 ]
1662 )
1934 )
@@ -1688,8 +1960,8 @@ typeAliasNote =
1688 [ D.toSimpleNote $
1960 [ D.toSimpleNote $
1689 "Here is an example of a valid `type alias` for reference:"
1961 "Here is an example of a valid `type alias` for reference:"
1690 , D.vcat $
1962 , D.vcat $
1691− [ D.indent 0 $ D.fillSep [D.cyan "type",D.cyan "alias",D.green "Person","="]
1963+ [ D.indent 4 $ D.fillSep [D.cyan "type",D.cyan "alias","Person","="]
1692− , D.indent 2 $ D.vcat $
1964+ , D.indent 6 $ D.vcat $
1693 ["{ name : String"
1965 ["{ name : String"
1694 ,", age : Int"
1966 ,", age : Int"
1695 ,", height : Float"
1967 ,", height : Float"
@@ -1763,7 +2035,7 @@ toCustomTypeReport source customType startRow startCol =
1763 ,
2035 ,
1764 D.stack
2036 D.stack
1765 [ D.reflow $
2037 [ D.reflow $
1766− "I was expecting to see a type variable or an an equals sign next."
2038+ "I was expecting to see a type variable or an equals sign next."
1767 , customTypeNote
2039 , customTypeNote
1768 ]
2040 ]
1769 )
2041 )
@@ -1823,7 +2095,7 @@ toCustomTypeReport source customType startRow startCol =
1823 ,
2095 ,
1824 D.stack
2096 D.stack
1825 [ D.reflow $
2097 [ D.reflow $
1826− "I was expecting to see a type variable or an an equals sign next."
2098+ "I was expecting to see a type variable or an equals sign next."
1827 , customTypeNote
2099 , customTypeNote
1828 ]
2100 ]
1829 )
2101 )
@@ -1889,10 +2161,10 @@ customTypeNote =
1889 [ D.toSimpleNote $
2161 [ D.toSimpleNote $
1890 "Here is an example of a valid `type` declaration for reference:"
2162 "Here is an example of a valid `type` declaration for reference:"
1891 , D.vcat $
2163 , D.vcat $
1892− [ D.indent 0 $ D.fillSep [D.cyan "type",D.green "Status"]
2164+ [ D.indent 4 $ D.fillSep [D.cyan "type","Status"]
1893− , D.indent 2 $ D.fillSep ["=","Failure"]
2165+ , D.indent 6 $ D.fillSep ["=","Failure"]
1894− , D.indent 2 $ D.fillSep ["|","Waiting"]
2166+ , D.indent 6 $ D.fillSep ["|","Waiting"]
1895− , D.indent 2 $ D.fillSep ["|","Success","String"]
2167+ , D.indent 6 $ D.fillSep ["|","Success","String"]
1896 ]
2168 ]
1897 , D.reflow $
2169 , D.reflow $
1898 "This defines a new `Status` type with three variants. This could be useful if\
2170 "This defines a new `Status` type with three variants. This could be useful if\
@@ -1923,11 +2195,55 @@ toDeclDefReport source name declDef startRow startCol =
1923 Report.Report "RESERVED WORD" region [] $
2195 Report.Report "RESERVED WORD" region [] $
1924 Code.toSnippet source surroundings (Just region)
2196 Code.toSnippet source surroundings (Just region)
1925 (
2197 (
1926− D.reflow $
2198+ D.fillSep
1927− "It looks like you are trying to use `" ++ keyword ++ "` as an argument:"
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+ ]
1928 ,
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)
2229+ (
1929 D.reflow $
2230 D.reflow $
1930− "This is a reserved word! Try using some other name?"
2231+ "I was not expecting to see an arrow here:"
2232+ ,
2233+ D.stack
2234+ [ D.fillSep
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+ ]
1931 )
2247 )
1932
2248
1933 Code.Operator op ->
2249 Code.Operator op ->
@@ -1945,10 +2261,10 @@ toDeclDefReport source name declDef startRow startCol =
1945 [ D.reflow $
2261 [ D.reflow $
1946 "I am not sure what is going wrong exactly, so here is a valid\
2262 "I am not sure what is going wrong exactly, so here is a valid\
1947 \ definition (with an optional type annotation) for reference:"
2263 \ definition (with an optional type annotation) for reference:"
1948− , D.vcat
2264+ , D.indent 4 $ D.vcat $
1949− [ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
2265+ [ "greet : String -> String"
1950− , D.fillSep [D.green "add","x","y","="]
2266+ , "greet name ="
1951− , D.fillSep [" ","x","+","y"]
2267+ , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
1952 ]
2268 ]
1953 , D.reflow $
2269 , D.reflow $
1954 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
2270 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
@@ -1970,10 +2286,10 @@ toDeclDefReport source name declDef startRow startCol =
1970 [ D.reflow $
2286 [ D.reflow $
1971 "I am not sure what is going wrong exactly, so here is a valid\
2287 "I am not sure what is going wrong exactly, so here is a valid\
1972 \ definition (with an optional type annotation) for reference:"
2288 \ definition (with an optional type annotation) for reference:"
1973− , D.vcat
2289+ , D.indent 4 $ D.vcat $
1974− [ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
2290+ [ "greet : String -> String"
1975− , D.fillSep [D.green "add","x","y","="]
2291+ , "greet name ="
1976− , D.fillSep [" ","x","+","y"]
2292+ , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
1977 ]
2293 ]
1978 , D.reflow $
2294 , D.reflow $
1979 "Try to use that format!"
2295 "Try to use that format!"
@@ -2088,10 +2404,10 @@ declDefNote =
2088 D.stack
2404 D.stack
2089 [ D.reflow $
2405 [ D.reflow $
2090 "Here is a valid definition (with a type annotation) for reference:"
2406 "Here is a valid definition (with a type annotation) for reference:"
2091− , D.vcat
2407+ , D.indent 4 $ D.vcat $
2092− [ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
2408+ [ "greet : String -> String"
2093− , D.fillSep [D.green "add","x","y","="]
2409+ , "greet name ="
2094− , D.fillSep [" ","x","+","y"]
2410+ , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
2095 ]
2411 ]
2096 , D.reflow $
2412 , D.reflow $
2097 "The top line (called a \"type annotation\") is optional. You can leave it off\
2413 "The top line (called a \"type annotation\") is optional. You can leave it off\
@@ -2203,25 +2519,40 @@ toExprReport source context expr startRow startCol =
2203 )
2519 )
2204
2520
2205 OperatorRight op row col ->
2521 OperatorRight op row col ->
2522+ let
2523+ surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
2206− let region = toRegion row col in
2524+ region = toRegion row col
2525+ isMath = elem op ["-","+","*","/","^"]
2526+ in
2207 Report.Report "MISSING EXPRESSION" region [] $
2527 Report.Report "MISSING EXPRESSION" region [] $
2208− Code.toSnippet source region Nothing
2528+ Code.toSnippet source surroundings (Just region)
2209 (
2529 (
2210 D.reflow $
2530 D.reflow $
2211− "I was expecting to see an expression after this " ++ Name.toChars op ++ " operator:"
2531+ "I just saw a " ++ Name.toChars op ++ " "
2532+ ++ (if isMath then "sign" else "operator")
2533+ ++ ", so I am getting stuck here:"
2212 ,
2534 ,
2213− D.stack
2535+ if isMath then
2214− [ D.fillSep $
2536+ D.fillSep
2215− ["You","can","just","put","anything","for","now,","like"
2537+ ["I","was","expecting","to","see","an","expression","next."
2216− ,D.dullyellow "42","or",D.dullyellow"\"hello\"" <> "."
2538+ ,"Something","like",D.dullyellow "42","or",D.dullyellow "1000"
2217− ,"Once","there","is","something","there,","I","can","probably"
2539+ ,"that","makes","sense","with","a",D.fromName op,"sign."
2218− ,"give","a","more","specific","hint!"
2540+ ]
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."
2219− ]
2546+ ]
2220− , D.toSimpleNote $
2547+ else if op == "|>" then
2221− "This can also happen if run into reserved words like `let` or `as` unexpectedly.\
2548+ D.reflow $
2222− \ Or if I run into operators in unexpected spots. Point is, there are a\
2549+ "I was expecting to see a function next."
2223− \ couple ways I can get confused and give sort of weird advice!"
2550+ else if op == "<|" then
2224− ]
2551+ D.reflow $
2552+ "I was expecting to see an argument next."
2553+ else
2554+ D.reflow $
2555+ "I was expecting to see an expression next."
2225 )
2556 )
2226
2557
2227 OperatorReserved operator row col ->
2558 OperatorReserved operator row col ->
@@ -2242,7 +2573,6 @@ toExprReport source context expr startRow startCol =
2242 InNode NElse r c _ -> (r, c, "an `if` expression")
2573 InNode NElse r c _ -> (r, c, "an `if` expression")
2243 InNode NCase r c _ -> (r, c, "a `case` expression")
2574 InNode NCase r c _ -> (r, c, "a `case` expression")
2244 InNode NBranch r c _ -> (r, c, "a `case` expression")
2575 InNode NBranch r c _ -> (r, c, "a `case` expression")
2245− -- TODO check if this is actually the best way to get error messages here
2246
2576
2247 surroundings = A.Region (A.Position contextRow contextCol) (A.Position row col)
2577 surroundings = A.Region (A.Position contextRow contextCol) (A.Position row col)
2248 region = toRegion row col
2578 region = toRegion row col
@@ -2261,7 +2591,7 @@ toExprReport source context expr startRow startCol =
2261 ,"give","a","more","specific","hint!"
2591 ,"give","a","more","specific","hint!"
2262 ]
2592 ]
2263 , D.toSimpleNote $
2593 , D.toSimpleNote $
2264− "This can also happen if run into reserved words like `let` or `as` unexpectedly.\
2594+ "This can also happen if I run into reserved words like `let` or `as` unexpectedly.\
2265 \ Or if I run into operators in unexpected spots. Point is, there are a\
2595 \ Or if I run into operators in unexpected spots. Point is, there are a\
2266 \ couple ways I can get confused and give sort of weird advice!"
2596 \ couple ways I can get confused and give sort of weird advice!"
2267 ]
2597 ]
@@ -2407,7 +2737,19 @@ toStringReport source string row col =
2407 ,"quotes","on","each","end.","Is","the","closing","double"
2737 ,"quotes","on","each","end.","Is","the","closing","double"
2408 ,"quote","missing","in","your","code?"
2738 ,"quote","missing","in","your","code?"
2409 ]
2739 ]
2740+ , D.toSimpleNote $
2410− , D.link "Note" "Read" "TODO" "if you want a string that spans multiple lines."
2741+ "For a string that spans multiple lines, you can use the multi-line string\
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+ ]
2411 ]
2753 ]
2412 )
2754 )
2413
2755
@@ -2423,7 +2765,18 @@ toStringReport source string row col =
2423 ,
2765 ,
2424 D.stack
2766 D.stack
2425 [ D.reflow "Add a \"\"\" somewhere after this to end the string."
2767 [ D.reflow "Add a \"\"\" somewhere after this to end the string."
2426− , D.link "Hint" "Read" "TODO" "for more information on strings and multi-line strings."
2768+ , D.toSimpleNote $
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+ ]
2427 ]
2780 ]
2428 )
2781 )
2429
2782
@@ -2656,33 +3009,41 @@ toOperatorReport source context operator row col =
2656 in
3009 in
2657 Report.Report "UNEXPECTED ARROW" region [] $
3010 Report.Report "UNEXPECTED ARROW" region [] $
2658 Code.toSnippet source region Nothing $
3011 Code.toSnippet source region Nothing $
2659− if isWithin NBranch context then
3012+ if isWithin NCase context then
2660 (
3013 (
2661 D.reflow $
3014 D.reflow $
2662− "I was not expecting to see an arrow here:"
3015+ "I am parsing a `case` expression right now, but this arrow is confusing me:"
2663 ,
3016 ,
2664 D.stack
3017 D.stack
2665− [
3018+ [ D.reflow "Maybe the `of` keyword is missing on a previous line?"
2666− D.reflow $
3019+ , noteForCaseError
2667− "I think I am parsing a `case` expression right now, so it makes sense to\
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?"
2675 ]
3020 ]
2676 )
3021 )
2677
3022
2678− else
3023+ else if isWithin NBranch context then
2679 (
3024 (
2680 D.reflow $
3025 D.reflow $
2681− "I was not expecting an arrow here:"
3026+ "I am parsing a `case` expression right now, but this arrow is confusing me:"
2682 ,
3027 ,
3028+ D.stack
3029+ [ 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?"
3031+ , noteForCaseIndentError
3032+ ]
3033+ )
3034+
3035+ else
3036+ (
2683 D.reflow $
3037 D.reflow $
3038+ "I was partway through parsing an expression when I got stuck on this arrow:"
3039+ ,
3040+ D.stack
2684− "Arrows should only appear in `case` expressions and anonymous functions. Maybe\
3041+ [ "Arrows should only appear in `case` expressions and anonymous functions.\n\
2685− \ you want > or >= instead?"
3042+ \Maybe it was supposed to be a > sign 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+ ]
2686 )
3047 )
2687
3048
2688 BadEquals ->
3049 BadEquals ->
@@ -2809,7 +3170,7 @@ toLetReport source context let_ startRow startCol =
2809 , D.toSimpleNote $
3170 , D.toSimpleNote $
2810 "This can also happen if you are trying to define another value within the `let` but\
3171 "This can also happen if you are trying to define another value within the `let` but\
2811 \ it is not indented enough. Make sure each definition has exactly the same amount of\
3172 \ it is not indented enough. Make sure each definition has exactly the same amount of\
2812− \ spaces before it. The should line up exactly!"
3173+ \ spaces before it. They should line up exactly!"
2813 ]
3174 ]
2814 )
3175 )
2815
3176
@@ -2879,8 +3240,8 @@ toUnfinishLetReport source row col startRow startCol message =
2879 [ message
3240 [ message
2880 , D.toSimpleNote $
3241 , D.toSimpleNote $
2881 "Here is an example with a valid `let` expression for reference:"
3242 "Here is an example with a valid `let` expression for reference:"
2882− , D.vcat $
3243+ , D.indent 4 $ D.vcat $
2883− [ D.indent 0 $ D.fillSep [D.green "viewPerson","person","="]
3244+ [ D.indent 0 $ D.fillSep ["viewPerson","person","="]
2884 , D.indent 2 $ D.fillSep [D.cyan "let"]
3245 , D.indent 2 $ D.fillSep [D.cyan "let"]
2885 , D.indent 4 $ D.fillSep ["fullName","="]
3246 , D.indent 4 $ D.fillSep ["fullName","="]
2886 , D.indent 6 $ D.fillSep ["person.firstName","++",D.dullyellow "\" \"","++","person.lastName"]
3247 , D.indent 6 $ D.fillSep ["person.firstName","++",D.dullyellow "\" \"","++","person.lastName"]
@@ -2957,11 +3318,55 @@ toLetDefReport source name def startRow startCol =
2957 Report.Report "RESERVED WORD" region [] $
3318 Report.Report "RESERVED WORD" region [] $
2958 Code.toSnippet source surroundings (Just region)
3319 Code.toSnippet source surroundings (Just region)
2959 (
3320 (
2960− D.reflow $
3321+ D.fillSep
2961− "It looks like you are trying to use `" ++ keyword ++ "` as an argument:"
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+ ]
2962 ,
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)
3352+ (
2963 D.reflow $
3353 D.reflow $
2964− "This is a reserved word! Try using some other name?"
3354+ "I was not expecting to see an arrow here:"
3355+ ,
3356+ D.stack
3357+ [ D.fillSep
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+ ]
2965 )
3370 )
2966
3371
2967 Code.Operator op ->
3372 Code.Operator op ->
@@ -2979,10 +3384,10 @@ toLetDefReport source name def startRow startCol =
2979 [ D.reflow $
3384 [ D.reflow $
2980 "I am not sure what is going wrong exactly, so here is a valid\
3385 "I am not sure what is going wrong exactly, so here is a valid\
2981 \ definition (with an optional type annotation) for reference:"
3386 \ definition (with an optional type annotation) for reference:"
2982− , D.vcat
3387+ , D.indent 4 $ D.vcat $
2983− [ D.indent 4 $ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
3388+ [ "greet : String -> String"
2984− , D.indent 4 $ D.fillSep [D.green "add","x","y","="]
3389+ , "greet name ="
2985− , D.indent 6 $ D.fillSep ["x","+","y"]
3390+ , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
2986 ]
3391 ]
2987 , D.reflow $
3392 , D.reflow $
2988 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
3393 "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
@@ -3004,10 +3409,10 @@ toLetDefReport source name def startRow startCol =
3004 [ D.reflow $
3409 [ D.reflow $
3005 "I am not sure what is going wrong exactly, so here is a valid\
3410 "I am not sure what is going wrong exactly, so here is a valid\
3006 \ definition (with an optional type annotation) for reference:"
3411 \ definition (with an optional type annotation) for reference:"
3007− , D.vcat
3412+ , D.indent 4 $ D.vcat $
3008− [ D.indent 4 $ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
3413+ [ "greet : String -> String"
3009− , D.indent 4 $ D.fillSep [D.green "add","x","y","="]
3414+ , "greet name ="
3010− , D.indent 4 $ D.fillSep ["x","+","y"]
3415+ , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
3011 ]
3416 ]
3012 , D.reflow $
3417 , D.reflow $
3013 "Try to use that format!"
3418 "Try to use that format!"
@@ -3097,10 +3502,10 @@ defNote =
3097 D.stack
3502 D.stack
3098 [ D.reflow $
3503 [ D.reflow $
3099 "Here is a valid definition (with a type annotation) for reference:"
3504 "Here is a valid definition (with a type annotation) for reference:"
3100− , D.vcat
3505+ , D.indent 4 $ D.vcat $
3101− [ D.indent 4 $ D.fillSep [D.green "add",":","Int","->","Int","->","Int"]
3506+ [ "greet : String -> String"
3102− , D.indent 4 $ D.fillSep [D.green "add","x","y","="]
3507+ , "greet name ="
3103− , D.indent 6 $ D.fillSep ["x","+","y"]
3508+ , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
3104 ]
3509 ]
3105 , D.reflow $
3510 , D.reflow $
3106 "The top line (called a \"type annotation\") is optional. You can leave it off\
3511 "The top line (called a \"type annotation\") is optional. You can leave it off\
@@ -3263,9 +3668,10 @@ toCaseReport source context case_ startRow startCol =
3263 D.reflow $
3668 D.reflow $
3264 "I am partway through parsing a `case` expression, but I got stuck here:"
3669 "I am partway through parsing a `case` expression, but I got stuck here:"
3265 ,
3670 ,
3266− addNoteForCaseIndentError $
3671+ D.stack
3267− D.reflow $
3268− "I was expecting to see an arrow next."
3672+ [ D.reflow "I was expecting to see an arrow next."
3673+ , noteForCaseIndentError
3674+ ]
3269 )
3675 )
3270
3676
3271 CaseExpr expr row col ->
3677 CaseExpr expr row col ->
@@ -3319,28 +3725,33 @@ toUnfinishCaseReport source row col startRow startCol message =
3319 ,
3725 ,
3320 D.stack
3726 D.stack
3321 [ message
3727 [ message
3322− , D.toSimpleNote $
3728+ , noteForCaseError
3323− "Here is an example of a valid `case` expression for reference."
3324− , D.vcat $
3325− [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
3326− , D.indent 6 $ D.fillSep [D.blue "Just","width","->"]
3327− , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"]
3328− , ""
3329− , D.indent 6 $ D.fillSep [D.blue "Nothing","->"]
3330− , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3331− ]
3332− , D.reflow $
3333− "Notice the indentation. Each pattern is aligned, and each branch is indented\
3334− \ a bit more than the corresponding pattern. That is important!"
3335 ]
3729 ]
3336 )
3730 )
3337
3731
3338
3732
3339−addNoteForCaseIndentError :: D.Doc -> D.Doc
3733+noteForCaseError :: D.Doc
3340−addNoteForCaseIndentError message =
3734+noteForCaseError =
3341− D.stack $
3735+ D.stack
3342− message
3736+ [ D.toSimpleNote $
3343− :
3737+ "Here is an example of a valid `case` expression for reference."
3738+ , D.vcat $
3739+ [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
3740+ , D.indent 6 $ D.fillSep [D.blue "Just","width","->"]
3741+ , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"]
3742+ , ""
3743+ , D.indent 6 $ D.fillSep [D.blue "Nothing","->"]
3744+ , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3745+ ]
3746+ , D.reflow $
3747+ "Notice the indentation. Each pattern is aligned, and each branch is indented\
3748+ \ a bit more than the corresponding pattern. That is important!"
3749+ ]
3750+
3751+
3752+noteForCaseIndentError :: D.Doc
3753+noteForCaseIndentError =
3754+ D.stack
3344 [ D.toSimpleNote $
3755 [ D.toSimpleNote $
3345 "Sometimes I get confused by indentation, so try to make your `case` look\
3756 "Sometimes I get confused by indentation, so try to make your `case` look\
3346 \ something like this:"
3757 \ something like this:"
@@ -3353,8 +3764,9 @@ addNoteForCaseIndentError message =
3353 , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3764 , D.indent 8 $ D.fillSep [D.dullyellow "400"]
3354 ]
3765 ]
3355 , D.reflow $
3766 , D.reflow $
3356− "Notice the indentation! Each pattern is aligned, and each branch is indented\
3767+ "Notice the indentation! Patterns are aligned with each other. Same indentation.\
3768+ \ The expressions after each arrow are all indented a bit more than the patterns.\
3357− \ a bit more than the corresponding pattern. That is important!"
3769+ \ That is important!"
3358 ]
3770 ]
3359
3771
3360
3772
@@ -3506,23 +3918,43 @@ toIfReport source context if_ startRow startCol =
3506 )
3918 )
3507
3919
3508 IfIndentElse row col ->
3920 IfIndentElse row col ->
3921+ case Code.nextLineStartsWithKeyword "else" source row of
3922+ Just (elseRow, elseCol) ->
3509− let
3923+ 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
3510− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3941+ surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3511− region = toRegion row col
3942+ region = toRegion row col
3512− in
3943+ in
3513− Report.Report "UNFINISHED IF" region [] $
3944+ Report.Report "UNFINISHED IF" region [] $
3514− Code.toSnippet source surroundings (Just region)
3945+ Code.toSnippet source surroundings (Just region)
3515− (
3946+ (
3516− D.reflow $
3947+ D.reflow $
3517− "I was expecting to see an `else` branch after this:"
3948+ "I was expecting to see an `else` branch after this:"
3518− ,
3949+ ,
3519− D.stack
3950+ D.stack
3520− [ D.reflow $
3951+ [ D.fillSep
3521− "I know what to do when the condition is `True`, but not when it is `False`."
3952+ ["I","know","what","to","do","when","the","condition","is","True,"
3522− , D.fillSep
3953+ ,"but","what","happens","when","it","is","False?"
3523− ["Add","an",D.cyan "else","branch","to","handle","that","scenario!"]
3954+ ,"Add","an",D.cyan "else","branch","to","handle","that","scenario!"
3955+ ]
3524− ]
3956+ ]
3525− )
3957+ )
3526
3958
3527
3959
3528
3960
@@ -3555,15 +3987,22 @@ toRecordReport source context record startRow startCol =
3555 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3987 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3556 region = toRegion row col
3988 region = toRegion row col
3557 in
3989 in
3558− Report.Report "UNFINISHED RECORD" region [] $
3990+ Report.Report "PROBLEM IN RECORD" region [] $
3559 Code.toSnippet source surroundings (Just region)
3991 Code.toSnippet source surroundings (Just region)
3560 (
3992 (
3561 D.reflow $
3993 D.reflow $
3562 "I just started parsing a record, but I got stuck here:"
3994 "I just started parsing a record, but I got stuck here:"
3563 ,
3995 ,
3996+ D.stack
3564− D.fillSep
3997+ [ D.fillSep
3565− ["Records","look","like",D.dullyellow "{ x = 3, y = 4 },"
3566− ,"so","I","was","expecting","to","see","a","field","name","next."
3998+ ["I","was","expecting","to","see","a","record","field","defined","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
3567 ]
4006 ]
3568 )
4007 )
3569
4008
@@ -3572,7 +4011,7 @@ toRecordReport source context record startRow startCol =
3572 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4011 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3573 region = toRegion row col
4012 region = toRegion row col
3574 in
4013 in
3575− Report.Report "UNFINISHED RECORD" region [] $
4014+ Report.Report "PROBLEM IN RECORD" region [] $
3576 Code.toSnippet source surroundings (Just region)
4015 Code.toSnippet source surroundings (Just region)
3577 (
4016 (
3578 D.reflow $
4017 D.reflow $
@@ -3607,22 +4046,67 @@ toRecordReport source context record startRow startCol =
3607 \ that is a reserved word. Try using a different name!"
4046 \ that is a reserved word. Try using a different name!"
3608 )
4047 )
3609
4048
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+
3610 _ ->
4088 _ ->
3611 let
4089 let
3612 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4090 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3613 region = toRegion row col
4091 region = toRegion row col
3614 in
4092 in
3615− Report.Report "UNFINISHED RECORD" region [] $
4093+ Report.Report "PROBLEM IN RECORD" region [] $
3616 Code.toSnippet source surroundings (Just region)
4094 Code.toSnippet source surroundings (Just region)
3617 (
4095 (
3618 D.reflow $
4096 D.reflow $
3619− "I am partway through parsing a record, but I got stuck after that last comma:"
4097+ "I am partway through parsing a record, but I got stuck here:"
3620 ,
4098 ,
3621− addNoteForRecordError $
4099+ D.stack
3622− D.reflow $
4100+ [ D.fillSep
3623− "Trailing commas are not allowed in records, so I was expecting to see another\
4101+ ["I","was","expecting","to","see","another","record","field","defined","next,"
3624− \ record field defined next. If you are done defining the record, the fix may\
4102+ ,"so","I","am","looking","for","a","name","like"
3625− \ be to delete that last comma?"
4103+ ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
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+ ]
3626 )
4110 )
3627
4111
3628 RecordEquals row col ->
4112 RecordEquals row col ->
@@ -3630,17 +4114,19 @@ toRecordReport source context record startRow startCol =
3630 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4114 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3631 region = toRegion row col
4115 region = toRegion row col
3632 in
4116 in
3633− Report.Report "UNFINISHED RECORD" region [] $
4117+ Report.Report "PROBLEM IN RECORD" region [] $
3634 Code.toSnippet source surroundings (Just region)
4118 Code.toSnippet source surroundings (Just region)
3635 (
4119 (
3636 D.reflow $
4120 D.reflow $
3637 "I am partway through parsing a record, but I got stuck here:"
4121 "I am partway through parsing a record, but I got stuck here:"
3638 ,
4122 ,
3639− addNoteForRecordError $
4123+ D.stack
3640− D.fillSep $
4124+ [ D.fillSep $
3641− ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
4125+ ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
3642− ,"an","equals","sign","next.","So","try","putting","an",D.green "=","sign","here?"
4126+ ,"an","equals","sign","next.","So","try","putting","an",D.green "=","sign","here?"
4127+ ]
4128+ , noteForRecordError
3643− ]
4129+ ]
3644 )
4130 )
3645
4131
3646 RecordExpr expr row col ->
4132 RecordExpr expr row col ->
@@ -3660,29 +4146,54 @@ toRecordReport source context record startRow startCol =
3660 D.reflow $
4146 D.reflow $
3661 "I just saw the opening curly brace of a record, but then I got stuck here:"
4147 "I just saw the opening curly brace of a record, but then I got stuck here:"
3662 ,
4148 ,
3663− addNoteForRecordIndentError $
4149+ D.stack
3664− D.fillSep $
4150+ [ D.fillSep $
3665− ["I","am","expecting","a","record","like",D.dullyellow "{ x = 3, y = 4 }","here."
4151+ ["I","am","expecting","a","record","like",D.dullyellow "{ x = 3, y = 4 }","here."
3666− ,"Try","defining","some","fields","of","your","own?"
4152+ ,"Try","defining","some","fields","of","your","own?"
4153+ ]
4154+ , noteForRecordIndentError
3667− ]
4155+ ]
3668 )
4156 )
3669
4157
3670 RecordIndentEnd row col ->
4158 RecordIndentEnd row col ->
4159+ case Code.nextLineStartsWithCloseCurly source row of
4160+ Just (curlyRow, curlyCol) ->
3671− let
4161+ 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
3672− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4180+ surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
3673− region = toRegion row col
4181+ region = toRegion row col
3674− in
4182+ in
3675− Report.Report "UNFINISHED RECORD" region [] $
4183+ Report.Report "UNFINISHED RECORD" region [] $
3676− Code.toSnippet source surroundings (Just region)
4184+ Code.toSnippet source surroundings (Just region)
3677− (
4185+ (
3678− D.reflow $
4186+ D.reflow $
4187+ "I was partway through parsing a record, but I got stuck here:"
4188+ ,
4189+ D.stack
4190+ [ D.fillSep $
3679− "I was expecting to see a closing curly brace next:"
4191+ ["I","was","expecting","to","see","a","closing","curly","brace","next."
3680− ,
3681− addNoteForRecordIndentError $
3682− D.fillSep $
3683− ["Try","putting","an",D.green "}","and","see","if","that","helps?"
4192+ ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?"
4193+ ]
4194+ , noteForRecordIndentError
3684− ]
4195+ ]
3685− )
4196+ )
3686
4197
3687 RecordIndentField row col ->
4198 RecordIndentField row col ->
3688 let
4199 let
@@ -3695,11 +4206,13 @@ toRecordReport source context record startRow startCol =
3695 D.reflow $
4206 D.reflow $
3696 "I am partway through parsing a record, but I got stuck after that last comma:"
4207 "I am partway through parsing a record, but I got stuck after that last comma:"
3697 ,
4208 ,
3698− addNoteForRecordError $
4209+ D.stack
3699− D.reflow $
4210+ [ D.reflow $
3700− "Trailing commas are not allowed in records, so the fix may be to\
4211+ "Trailing commas are not allowed in records, so the fix may be to\
3701− \ delete that last comma? Or maybe you were in the middle of defining\
4212+ \ delete that last comma? Or maybe you were in the middle of defining\
3702− \ an additional field?"
4213+ \ an additional field?"
4214+ , noteForRecordError
4215+ ]
3703 )
4216 )
3704
4217
3705 RecordIndentEquals row col ->
4218 RecordIndentEquals row col ->
@@ -3714,10 +4227,12 @@ toRecordReport source context record startRow startCol =
3714 "I am partway through parsing a record. I just saw a record\
4227 "I am partway through parsing a record. I just saw a record\
3715 \ field, so I was expecting to see an equals sign next:"
4228 \ field, so I was expecting to see an equals sign next:"
3716 ,
4229 ,
3717− addNoteForRecordIndentError $
4230+ D.stack
3718− D.fillSep $
4231+ [ D.fillSep $
3719− ["Try","putting","an",D.green "=","followed","by","an","expression?"
4232+ ["Try","putting","an",D.green "=","followed","by","an","expression?"
4233+ ]
4234+ , noteForRecordIndentError
3720− ]
4235+ ]
3721 )
4236 )
3722
4237
3723 RecordIndentExpr row col ->
4238 RecordIndentExpr row col ->
@@ -3731,52 +4246,48 @@ toRecordReport source context record startRow startCol =
3731 D.reflow $
4246 D.reflow $
3732 "I am partway through parsing a record, and I was expecting to run into an expression next:"
4247 "I am partway through parsing a record, and I was expecting to run into an expression next:"
3733 ,
4248 ,
3734− addNoteForRecordIndentError $
4249+ D.stack
3735− D.fillSep $
4250+ [ D.fillSep $
3736− ["Try","putting","something","like"
4251+ ["Try","putting","something","like"
3737− ,D.dullyellow "42","or",D.dullyellow"\"hello\"","for","now?"
4252+ ,D.dullyellow "42","or",D.dullyellow"\"hello\"","for","now?"
4253+ ]
4254+ , noteForRecordIndentError
3738− ]
4255+ ]
3739 )
4256 )
3740
4257
3741
4258
3742−addNoteForRecordError :: D.Doc -> D.Doc
4259+noteForRecordError :: D.Doc
3743−addNoteForRecordError normalRecommendation =
4260+noteForRecordError =
3744 D.stack $
4261 D.stack $
3745− normalRecommendation
3746− :
3747 [ D.toSimpleNote
4262 [ D.toSimpleNote
3748 "If you are trying to define a record across multiple lines, I recommend using this format:"
4263 "If you are trying to define a record across multiple lines, I recommend using this format:"
3749 , D.indent 4 $ D.vcat $
4264 , D.indent 4 $ D.vcat $
3750− [ "{ name = \"Alice\""
4265+ [ "{ name = " <> D.dullyellow "\"Alice\""
3751− , ", age = 42"
4266+ , ", age = " <> D.dullyellow "42"
3752− , ", height = 1.75"
4267+ , ", height = " <> D.dullyellow "1.75"
3753 , "}"
4268 , "}"
3754 ]
4269 ]
3755 , D.reflow $
4270 , D.reflow $
3756− "Notice that each line starts with some indentation. Usually two or four spaces. I\
4271+ "Notice that each line starts with some indentation. Usually two or four spaces.\
3757− \ know this style can be jarring for people coming from C-like syntax, but folks generally\
4272+ \ This is the stylistic convention in the Elm ecosystem."
3758− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
3759 ]
4273 ]
3760
4274
3761
4275
3762−addNoteForRecordIndentError :: D.Doc -> D.Doc
4276+noteForRecordIndentError :: D.Doc
3763−addNoteForRecordIndentError normalRecommendation =
4277+noteForRecordIndentError =
3764− D.stack $
4278+ D.stack
3765− normalRecommendation
3766− :
3767 [ D.toSimpleNote
4279 [ D.toSimpleNote
3768 "I may be confused by indentation. For example, if you are trying to define\
4280 "I may be confused by indentation. For example, if you are trying to define\
3769 \ a record across multiple lines, I recommend using this format:"
4281 \ a record across multiple lines, I recommend using this format:"
3770 , D.indent 4 $ D.vcat $
4282 , D.indent 4 $ D.vcat $
3771− [ "{ name = \"Alice\""
4283+ [ "{ name = " <> D.dullyellow "\"Alice\""
3772− , ", age = 42"
4284+ , ", age = " <> D.dullyellow "42"
3773− , ", height = 1.75"
4285+ , ", height = " <> D.dullyellow "1.75"
3774 , "}"
4286 , "}"
3775 ]
4287 ]
3776 , D.reflow $
4288 , D.reflow $
3777− "Notice that each line starts with some indentation. Usually two or four spaces. I\
4289+ "Notice that each line starts with some indentation. Usually two or four spaces.\
3778− \ know this style can be jarring for people coming from C-like syntax, but folks generally\
4290+ \ This is the stylistic convention in the Elm ecosystem!"
3779− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
3780 ]
4291 ]
3781
4292
3782
4293
@@ -3965,15 +4476,14 @@ toListReport source context list startRow startCol =
3965 , D.toSimpleNote
4476 , D.toSimpleNote
3966 "I recommend using the following format for lists that span multiple lines:"
4477 "I recommend using the following format for lists that span multiple lines:"
3967 , D.indent 4 $ D.vcat $
4478 , D.indent 4 $ D.vcat $
3968− [ "[ \"Alice\""
4479+ [ "[ " <> D.dullyellow "\"Alice\""
3969− , ", \"Bob\""
4480+ , ", " <> D.dullyellow "\"Bob\""
3970− , ", \"Chuck\""
4481+ , ", " <> D.dullyellow "\"Chuck\""
3971 , "]"
4482 , "]"
3972 ]
4483 ]
3973 , D.reflow $
4484 , D.reflow $
3974− "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4485+ "Notice that each line starts with some indentation. Usually two or four spaces.\
3975− \ This style can be jarring for people coming from C-like syntax, but folks generally\
4486+ \ This is the stylistic convention in the Elm ecosystem."
3976− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
3977 ]
4487 ]
3978 )
4488 )
3979
4489
@@ -4026,15 +4536,14 @@ toListReport source context list startRow startCol =
4026 "I may be confused by indentation. For example, if you are trying to define\
4536 "I may be confused by indentation. For example, if you are trying to define\
4027 \ a list across multiple lines, I recommend using this format:"
4537 \ a list across multiple lines, I recommend using this format:"
4028 , D.indent 4 $ D.vcat $
4538 , D.indent 4 $ D.vcat $
4029− [ "[ \"Alice\""
4539+ [ "[ " <> D.dullyellow "\"Alice\""
4030− , ", \"Bob\""
4540+ , ", " <> D.dullyellow "\"Bob\""
4031− , ", \"Chuck\""
4541+ , ", " <> D.dullyellow "\"Chuck\""
4032 , "]"
4542 , "]"
4033 ]
4543 ]
4034 , D.reflow $
4544 , D.reflow $
4035− "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4545+ "Notice that each line starts with some indentation. Usually two or four spaces.\
4036− \ This style can be jarring for people coming from C-like syntax, but folks generally\
4546+ \ This is the stylistic convention in the Elm ecosystem."
4037− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4038 ]
4547 ]
4039 )
4548 )
4040
4549
@@ -4058,15 +4567,14 @@ toListReport source context list startRow startCol =
4058 "I may be confused by indentation. For example, if you are trying to define\
4567 "I may be confused by indentation. For example, if you are trying to define\
4059 \ a list across multiple lines, I recommend using this format:"
4568 \ a list across multiple lines, I recommend using this format:"
4060 , D.indent 4 $ D.vcat $
4569 , D.indent 4 $ D.vcat $
4061− [ "[ \"Alice\""
4570+ [ "[ " <> D.dullyellow "\"Alice\""
4062− , ", \"Bob\""
4571+ , ", " <> D.dullyellow "\"Bob\""
4063− , ", \"Chuck\""
4572+ , ", " <> D.dullyellow "\"Chuck\""
4064 , "]"
4573 , "]"
4065 ]
4574 ]
4066 , D.reflow $
4575 , D.reflow $
4067− "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4576+ "Notice that each line starts with some indentation. Usually two or four spaces.\
4068− \ This style can be jarring for people coming from C-like syntax, but folks generally\
4577+ \ This is the stylistic convention in the Elm ecosystem."
4069− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4070 ]
4578 ]
4071 )
4579 )
4072
4580
@@ -4087,15 +4595,14 @@ toListReport source context list startRow startCol =
4087 , D.toSimpleNote
4595 , D.toSimpleNote
4088 "I recommend using the following format for lists that span multiple lines:"
4596 "I recommend using the following format for lists that span multiple lines:"
4089 , D.indent 4 $ D.vcat $
4597 , D.indent 4 $ D.vcat $
4090− [ "[ \"Alice\""
4598+ [ "[ " <> D.dullyellow "\"Alice\""
4091− , ", \"Bob\""
4599+ , ", " <> D.dullyellow "\"Bob\""
4092− , ", \"Chuck\""
4600+ , ", " <> D.dullyellow "\"Chuck\""
4093 , "]"
4601 , "]"
4094 ]
4602 ]
4095 , D.reflow $
4603 , D.reflow $
4096− "Notice that nothing comes directly after a newline. Each line starts with some spaces.\
4604+ "Notice that each line starts with some indentation. Usually two or four spaces.\
4097− \ This style can be jarring for people coming from C-like syntax, but folks generally\
4605+ \ This is the stylistic convention in the Elm ecosystem."
4098− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
4099 ]
4606 ]
4100 )
4607 )
4101
4608
@@ -4344,7 +4851,7 @@ toPatternReport source context pattern startRow startCol =
4344 ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")"
4851 ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")"
4345 ,"so","you","can","refer","to","individual","parts","of","the","tuple","with"
4852 ,"so","you","can","refer","to","individual","parts","of","the","tuple","with"
4346 ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole"
4853 ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole"
4347− ,"thing","with",D.dullyellow "point."
4854+ ,"thing","with",D.dullyellow "point" <> "."
4348 ]
4855 ]
4349 , D.reflow $
4856 , D.reflow $
4350 "So I was expecting to see a variable name after the `as` keyword here. Sometimes\
4857 "So I was expecting to see a variable name after the `as` keyword here. Sometimes\
@@ -4536,7 +5043,7 @@ toPTupleReport source context tuple startRow startCol =
4536 "I just saw an open parenthesis, but I got stuck here:"
5043 "I just saw an open parenthesis, but I got stuck here:"
4537 ,
5044 ,
4538 D.fillSep
5045 D.fillSep
4539− ["I","was","expecting","so","see","a","pattern","next."
5046+ ["I","was","expecting","to","see","a","pattern","next."
4540 ,"Maybe","it","will","end","up","being","something"
5047 ,"Maybe","it","will","end","up","being","something"
4541 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
5048 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
4542 ]
5049 ]
@@ -4645,7 +5152,7 @@ toPTupleReport source context tuple startRow startCol =
4645 "I just saw an open parenthesis, but then I got stuck here:"
5152 "I just saw an open parenthesis, but then I got stuck here:"
4646 ,
5153 ,
4647 D.fillSep
5154 D.fillSep
4648− ["I","was","expecting","so","see","a","pattern","next."
5155+ ["I","was","expecting","to","see","a","pattern","next."
4649 ,"Maybe","it","will","end","up","being","something"
5156 ,"Maybe","it","will","end","up","being","something"
4650 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
5157 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
4651 ]
5158 ]
@@ -4664,7 +5171,7 @@ toPTupleReport source context tuple startRow startCol =
4664 ,
5171 ,
4665 D.stack
5172 D.stack
4666 [ D.fillSep
5173 [ D.fillSep
4667− ["I","was","expecting","so","see","a","pattern","next."
5174+ ["I","was","expecting","to","see","a","pattern","next."
4668 ,"I","am","expecting","the","final","result","to","be","something"
5175 ,"I","am","expecting","the","final","result","to","be","something"
4669 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "."
5176 ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "."
4670 ]
5177 ]
@@ -4968,22 +5475,64 @@ toTRecordReport source context record startRow startCol =
4968 \ that is a reserved word. Try using a different name!"
5475 \ that is a reserved word. Try using a different name!"
4969 )
5476 )
4970
5477
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+
4971 _ ->
5517 _ ->
4972 let
5518 let
4973 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5519 surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
4974 region = toRegion row col
5520 region = toRegion row col
4975 in
5521 in
4976− Report.Report "UNFINISHED RECORD TYPE" region [] $
5522+ Report.Report "PROBLEM IN RECORD TYPE" region [] $
4977 Code.toSnippet source surroundings (Just region)
5523 Code.toSnippet source surroundings (Just region)
4978 (
5524 (
4979 D.reflow $
5525 D.reflow $
4980− "I am partway through parsing a record type, but I got stuck after that last comma:"
5526+ "I am partway through parsing a record type, but I got stuck here:"
4981 ,
5527 ,
4982− addNoteForRecordTypeError $
5528+ D.stack
4983− D.reflow $
5529+ [ D.fillSep
4984− "Trailing commas are not allowed in records, so I was expecting to see another\
5530+ ["I","was","expecting","to","see","another","record","field","defined","next,"
4985− \ record field defined next. If you are done defining the record, the fix may\
5531+ ,"so","I","am","looking","for","a","name","like"
4986− \ be to delete that last comma?"
5532+ ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
5533+ ]
5534+ , noteForRecordTypeError
5535+ ]
4987 )
5536 )
4988
5537
4989 TRecordColon row col ->
5538 TRecordColon row col ->
@@ -4997,11 +5546,13 @@ toTRecordReport source context record startRow startCol =
4997 D.reflow $
5546 D.reflow $
4998 "I am partway through parsing a record type, but I got stuck here:"
5547 "I am partway through parsing a record type, but I got stuck here:"
4999 ,
5548 ,
5000− addNoteForRecordTypeError $
5549+ D.stack
5001− D.fillSep $
5550+ [ D.fillSep $
5002− ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
5551+ ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
5003− ,"a","colon","next.","So","try","putting","an",D.green ":","sign","here?"
5552+ ,"a","colon","next.","So","try","putting","an",D.green ":","sign","here?"
5553+ ]
5554+ , noteForRecordTypeError
5004− ]
5555+ ]
5005 )
5556 )
5006
5557
5007 TRecordType tipe row col ->
5558 TRecordType tipe row col ->
@@ -5021,29 +5572,54 @@ toTRecordReport source context record startRow startCol =
5021 D.reflow $
5572 D.reflow $
5022 "I just saw the opening curly brace of a record type, but then I got stuck here:"
5573 "I just saw the opening curly brace of a record type, but then I got stuck here:"
5023 ,
5574 ,
5024− addNoteForRecordTypeIndentError $
5575+ D.stack
5025− D.fillSep $
5576+ [ D.fillSep $
5026− ["I","am","expecting","a","record","like",D.dullyellow "{ name : String, age : Int }","here."
5577+ ["I","am","expecting","a","record","like",D.dullyellow "{ name : String, age : Int }","here."
5027− ,"Try","defining","some","fields","of","your","own?"
5578+ ,"Try","defining","some","fields","of","your","own?"
5579+ ]
5580+ , noteForRecordTypeIndentError
5028− ]
5581+ ]
5029 )
5582 )
5030
5583
5031 TRecordIndentEnd row col ->
5584 TRecordIndentEnd row col ->
5585+ case Code.nextLineStartsWithCloseCurly source row of
5586+ Just (curlyRow, curlyCol) ->
5032− let
5587+ 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
5033− surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5606+ surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
5034− region = toRegion row col
5607+ region = toRegion row col
5035− in
5608+ in
5036− Report.Report "UNFINISHED RECORD TYPE" region [] $
5609+ Report.Report "UNFINISHED RECORD TYPE" region [] $
5037− Code.toSnippet source surroundings (Just region)
5610+ Code.toSnippet source surroundings (Just region)
5038− (
5611+ (
5039− D.reflow $
5612+ D.reflow $
5613+ "I was partway through parsing a record type, but I got stuck here:"
5614+ ,
5615+ D.stack
5616+ [ D.fillSep $
5040− "I was expecting to see a closing curly brace next:"
5617+ ["I","was","expecting","to","see","a","closing","curly","brace","next."
5041− ,
5042− addNoteForRecordTypeIndentError $
5043− D.fillSep $
5044− ["Try","putting","an",D.green "}","and","see","if","that","helps?"
5618+ ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?"
5619+ ]
5620+ , noteForRecordTypeIndentError
5045− ]
5621+ ]
5046− )
5622+ )
5047
5623
5048 TRecordIndentField row col ->
5624 TRecordIndentField row col ->
5049 let
5625 let
@@ -5056,11 +5632,13 @@ toTRecordReport source context record startRow startCol =
5056 D.reflow $
5632 D.reflow $
5057 "I am partway through parsing a record type, but I got stuck after that last comma:"
5633 "I am partway through parsing a record type, but I got stuck after that last comma:"
5058 ,
5634 ,
5059− addNoteForRecordTypeIndentError $
5635+ D.stack
5060− D.reflow $
5636+ [ D.reflow $
5061− "Trailing commas are not allowed in record types, so the fix may be to\
5637+ "Trailing commas are not allowed in record types, so the fix may be to\
5062− \ delete that last comma? Or maybe you were in the middle of defining\
5638+ \ delete that last comma? Or maybe you were in the middle of defining\
5063− \ an additional field?"
5639+ \ an additional field?"
5640+ , noteForRecordTypeIndentError
5641+ ]
5064 )
5642 )
5065
5643
5066 TRecordIndentColon row col ->
5644 TRecordIndentColon row col ->
@@ -5075,10 +5653,12 @@ toTRecordReport source context record startRow startCol =
5075 "I am partway through parsing a record type. I just saw a record\
5653 "I am partway through parsing a record type. I just saw a record\
5076 \ field, so I was expecting to see a colon next:"
5654 \ field, so I was expecting to see a colon next:"
5077 ,
5655 ,
5078− addNoteForRecordTypeIndentError $
5656+ D.stack
5079− D.fillSep $
5657+ [ D.fillSep $
5080− ["Try","putting","an",D.green ":","followed","by","a","type?"
5658+ ["Try","putting","an",D.green ":","followed","by","a","type?"
5659+ ]
5660+ , noteForRecordTypeIndentError
5081− ]
5661+ ]
5082 )
5662 )
5083
5663
5084 TRecordIndentType row col ->
5664 TRecordIndentType row col ->
@@ -5092,19 +5672,19 @@ toTRecordReport source context record startRow startCol =
5092 D.reflow $
5672 D.reflow $
5093 "I am partway through parsing a record type, and I was expecting to run into a type next:"
5673 "I am partway through parsing a record type, and I was expecting to run into a type next:"
5094 ,
5674 ,
5095− addNoteForRecordTypeIndentError $
5675+ D.stack
5096− D.fillSep $
5676+ [ D.fillSep $
5097− ["Try","putting","something","like"
5677+ ["Try","putting","something","like"
5098− ,D.dullyellow "Int","or",D.dullyellow "String","for","now?"
5678+ ,D.dullyellow "Int","or",D.dullyellow "String","for","now?"
5679+ ]
5680+ , noteForRecordTypeIndentError
5099− ]
5681+ ]
5100 )
5682 )
5101
5683
5102
5684
5103−addNoteForRecordTypeError :: D.Doc -> D.Doc
5685+noteForRecordTypeError :: D.Doc
5104−addNoteForRecordTypeError normalRecommendation =
5686+noteForRecordTypeError =
5105 D.stack $
5687 D.stack $
5106− normalRecommendation
5107− :
5108 [ D.toSimpleNote
5688 [ D.toSimpleNote
5109 "If you are trying to define a record type across multiple lines, I recommend using this format:"
5689 "If you are trying to define a record type across multiple lines, I recommend using this format:"
5110 , D.indent 4 $ D.vcat $
5690 , D.indent 4 $ D.vcat $
@@ -5114,17 +5694,14 @@ addNoteForRecordTypeError normalRecommendation =
5114 , "}"
5694 , "}"
5115 ]
5695 ]
5116 , D.reflow $
5696 , D.reflow $
5117− "Notice that each line starts with some indentation. Usually two or four spaces. I\
5697+ "Notice that each line starts with some indentation. Usually two or four spaces.\
5118− \ know this style can be jarring for people coming from C-like syntax, but folks generally\
5698+ \ This is the stylistic convention in the Elm ecosystem."
5119− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
5120 ]
5699 ]
5121
5700
5122
5701
5123−addNoteForRecordTypeIndentError :: D.Doc -> D.Doc
5702+noteForRecordTypeIndentError :: D.Doc
5124−addNoteForRecordTypeIndentError normalRecommendation =
5703+noteForRecordTypeIndentError =
5125 D.stack $
5704 D.stack $
5126− normalRecommendation
5127− :
5128 [ D.toSimpleNote
5705 [ D.toSimpleNote
5129 "I may be confused by indentation. For example, if you are trying to define\
5706 "I may be confused by indentation. For example, if you are trying to define\
5130 \ a record type across multiple lines, I recommend using this format:"
5707 \ a record type across multiple lines, I recommend using this format:"
@@ -5135,9 +5712,8 @@ addNoteForRecordTypeIndentError normalRecommendation =
5135 , "}"
5712 , "}"
5136 ]
5713 ]
5137 , D.reflow $
5714 , D.reflow $
5138− "Notice that each line starts with some indentation. Usually two or four spaces. I\
5715+ "Notice that each line starts with some indentation. Usually two or four spaces.\
5139− \ know this style can be jarring for people coming from C-like syntax, but folks generally\
5716+ \ This is the stylistic convention in the Elm ecosystem."
5140− \ report that they are used to it (and often prefer it!) after a week or two of using Elm."
5141 ]
5717 ]
5142
5718
5143
5719
@@ -5189,7 +5765,7 @@ toTTupleReport source context tuple startRow startCol =
5189 Code.toSnippet source surroundings (Just region)
5765 Code.toSnippet source surroundings (Just region)
5190 (
5766 (
5191 D.reflow $
5767 D.reflow $
5192− "I was expecting to see a closing parentheses next, but I got stuck here:"
5768+ "I was expecting to see a closing parenthesis next, but I got stuck here:"
5193 ,
5769 ,
5194 D.stack
5770 D.stack
5195 [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"]
5771 [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"]
compiler/src/Reporting/Error/Type.hs+44−23
@@ -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− "union-types"
234+ "custom-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.toSimpleHint $
256+ [ D.link "Hint"
257− "Everything in the list needs to be the same type of value.\
257+ "Everything in a list must be the same type of value. This way, we never\
258− \ This way you never run into unexpected values partway through.\
258+ \ run into unexpected values partway through a List.map, List.foldl, etc. Read"
259− \ To mix different types in a single list, create a \"union type\" as\
259+ "custom-types"
260− \ described in: <http://guide.elm-lang.org/types/union_types.html>"
260+ "to learn how to “mix” types."
261 ]
261 ]
262 )
262 )
263
263
@@ -431,13 +431,14 @@ problemToHint problem =
431 ]
431 ]
432 ]
432 ]
433
433
434− T.AnythingToList ->
434+ T.ArityMismatch x y ->
435− [ D.toSimpleHint "Did you forget to add [] around it?"
435+ [ D.toSimpleHint $
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."
436 ]
440 ]
437
441
438− T.MissingArgs _ -> []
439− T.ReturnMismatch -> []
440−
441 T.BadFlexSuper direction super _ tipe ->
442 T.BadFlexSuper direction super _ tipe ->
442 case tipe of
443 case tipe of
443 T.Lambda _ _ _ -> badFlexSuper direction super tipe
444 T.Lambda _ _ _ -> badFlexSuper direction super tipe
@@ -558,11 +559,31 @@ badFlexSuper :: T.Direction -> T.Super -> T.Type -> [D.Doc]
558badFlexSuper direction super tipe =
559badFlexSuper direction super tipe =
559 case super of
560 case super of
560 T.Comparable ->
561 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\
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 $
561− [ D.toSimpleHint "Only ints, floats, chars, strings, lists, and tuples are comparable."
581+ "I only know how to compare ints, floats, chars, strings, lists of\
582+ \ comparable values, and tuples of comparable values."
562− ]
583+ ]
563
584
564 T.Appendable ->
585 T.Appendable ->
565− [ D.toSimpleHint "Only strings and lists are appendable."
586+ [ D.toSimpleHint "I only know how to append strings and lists."
566 ]
587 ]
567
588
568 T.CompAppend ->
589 T.CompAppend ->
@@ -689,11 +710,11 @@ toExprReport source localizer exprRegion category tipe expected =
689 , "The " <> ith <> " element of this list does not match all the previous elements:"
710 , "The " <> ith <> " element of this list does not match all the previous elements:"
690 , "The " <> ith <> " element is"
711 , "The " <> ith <> " element is"
691 , "But all the previous elements in the list are:"
712 , "But all the previous elements in the list are:"
692− , [ D.toSimpleHint $
713+ , [ D.link "Hint"
693− "Everything in the list needs to be the same type of value.\
714+ "Everything in a list must be the same type of value. This way, we never\
694− \ This way you never run into unexpected values partway through.\
715+ \ run into unexpected values partway through a List.map, List.foldl, etc. Read"
695− \ To mix different types in a single list, create a \"union type\" as\
716+ "custom-types"
696− \ described in: <http://guide.elm-lang.org/types/union_types.html>"
717+ "to learn how to “mix” types."
697 ]
718 ]
698 )
719 )
699
720
@@ -740,7 +761,7 @@ toExprReport source localizer exprRegion category tipe expected =
740 , [ D.link "Hint"
761 , [ D.link "Hint"
741 "All branches in an `if` must produce the same type of values. This way, no\
762 "All branches in an `if` must produce the same type of values. This way, no\
742 \ matter which branch we take, the result is always a consistent shape. Read"
763 \ matter which branch we take, the result is always a consistent shape. Read"
743− "union-types"
764+ "custom-types"
744 "to learn how to “mix” types."
765 "to learn how to “mix” types."
745 ]
766 ]
746 )
767 )
@@ -755,7 +776,7 @@ toExprReport source localizer exprRegion category tipe expected =
755 , [ D.link "Hint"
776 , [ D.link "Hint"
756 "All branches in a `case` must produce the same type of values. This way, no\
777 "All branches in a `case` must produce the same type of values. This way, no\
757 \ matter which branch we take, the result is always a consistent shape. Read"
778 \ matter which branch we take, the result is always a consistent shape. Read"
758− "union-types"
779+ "custom-types"
759 "to learn how to “mix” types."
780 "to learn how to “mix” types."
760 ]
781 ]
761 )
782 )
@@ -1072,7 +1093,7 @@ opRightToDocs localizer category op tipe expected =
1072 ( D.reflow $ "I cannot send this through the (<|) pipe:"
1093 ( D.reflow $ "I cannot send this through the (<|) pipe:"
1073 , typeComparison localizer tipe expected
1094 , typeComparison localizer tipe expected
1074 "The argument is:"
1095 "The argument is:"
1075− "But (<|) is piping it a function that expects:"
1096+ "But (<|) is piping it to a function that expects:"
1076 []
1097 []
1077 )
1098 )
1078
1099
@@ -1083,7 +1104,7 @@ opRightToDocs localizer category op tipe expected =
1083 ( D.reflow $ "This function cannot handle the argument sent through the (|>) pipe:"
1104 ( D.reflow $ "This function cannot handle the argument sent through the (|>) pipe:"
1084 , typeComparison localizer argType expectedArgType
1105 , typeComparison localizer argType expectedArgType
1085 "The argument is:"
1106 "The argument is:"
1086− "But (|>) is piping it a function that expects:"
1107+ "But (|>) is piping it to a function that expects:"
1087 []
1108 []
1088 )
1109 )
1089
1110
compiler/src/Reporting/Render/Code.hs+67−26
@@ -7,6 +7,8 @@ module Reporting.Render.Code
7 , toPair
7 , toPair
8 , Next(..)
8 , Next(..)
9 , whatIsNext
9 , whatIsNext
10+ , nextLineStartsWithKeyword
11+ , nextLineStartsWithCloseCurly
10 )
12 )
11 where
13 where
12
14
@@ -120,7 +122,7 @@ makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end
120 spaces = replicate (fromIntegral c1 + width + 1) ' '
122 spaces = replicate (fromIntegral c1 + width + 1) ' '
121 zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^'
123 zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^'
122 in
124 in
123− Just (D.fromChars spaces <> D.dullred (D.fromChars zigzag))
125+ Just (D.fromChars spaces <> D.red (D.fromChars zigzag))
124
126
125
127
126drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc
128drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc
@@ -146,7 +148,7 @@ addLineNumber addZigZag width start end n line =
146
148
147 spacer =
149 spacer =
148 if addZigZag && start <= n && n <= end then
150 if addZigZag && start <= n && n <= end then
149− D.dullred ">"
151+ D.red ">"
150 else
152 else
151 " "
153 " "
152 in
154 in
@@ -181,8 +183,8 @@ renderPair source@(Source sourceLines) region1 region2 =
181 OneLine $
183 OneLine $
182 D.vcat
184 D.vcat
183 [ D.fromChars lineNumber <> "| " <> D.fromChars line
185 [ D.fromChars lineNumber <> "| " <> D.fromChars line
184− , D.fromChars spaces1 <> D.dullred (D.fromChars zigzag1) <>
186+ , D.fromChars spaces1 <> D.red (D.fromChars zigzag1) <>
185− D.fromChars spaces2 <> D.dullred (D.fromChars zigzag2)
187+ D.fromChars spaces2 <> D.red (D.fromChars zigzag2)
186 ]
188 ]
187
189
188 else
190 else
@@ -199,35 +201,46 @@ data Next
199 = Keyword [Char]
201 = Keyword [Char]
200 | Operator [Char]
202 | Operator [Char]
201 | Close [Char] Char
203 | Close [Char] Char
204+ | Upper Char [Char]
205+ | Lower Char [Char]
202− | Other
206+ | Other (Maybe Char)
203
207
204
208
205whatIsNext :: Source -> Row -> Col -> Next
209whatIsNext :: Source -> Row -> Col -> Next
206whatIsNext (Source sourceLines) row col =
210whatIsNext (Source sourceLines) row col =
207 case List.lookup row sourceLines of
211 case List.lookup row sourceLines of
208 Nothing ->
212 Nothing ->
209− Other
213+ Other Nothing
210
214
211 Just line ->
215 Just line ->
212− let
213− chars = drop (fromIntegral col - 1) line
216+ case drop (fromIntegral col - 1) line of
214− keywords = map Name.toChars (Set.toList reservedWords)
217+ [] ->
215− in
216− case List.find (startsWithKeyword chars) keywords of
217− Just keyword ->
218− Keyword keyword
219−
220− Nothing ->
218+ Other Nothing
221− case chars of
219+
222− [] ->
220+ c:cs
223− Other
221+ | Char.isUpper c -> Upper c (takeWhile isInner cs)
224−
222+ | Char.isLower c -> detectKeywords c cs
225− c:cs
226− | isSymbol c -> Operator (c : takeWhile isSymbol cs)
223+ | isSymbol c -> Operator (c : takeWhile isSymbol cs)
227− | c == ')' -> Close "parenthesis" ')'
224+ | c == ')' -> Close "parenthesis" ')'
228− | c == ']' -> Close "square bracket" ']'
225+ | c == ']' -> Close "square bracket" ']'
229− | c == '}' -> Close "curly brace" '}'
226+ | c == '}' -> Close "curly brace" '}'
230− | otherwise -> Other
227+ | otherwise -> Other (Just c)
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 == '_'
231
244
232
245
233isSymbol :: Char -> Bool
246isSymbol :: Char -> Bool
@@ -244,4 +257,32 @@ startsWithKeyword restOfLine keyword =
244 True
257 True
245
258
246 c:_ ->
259 c:_ ->
247− not (Char.isAlphaNum c || c == '_')
260+ not (isInner 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+5−25
@@ -7,8 +7,6 @@ module Reporting.Render.Type.Localizer
7 , empty
7 , empty
8 , fromNames
8 , fromNames
9 , fromModule
9 , fromModule
10− , replEmpty
11− , replAdd
12 )
10 )
13 where
11 where
14
12
@@ -18,7 +16,6 @@ import qualified Data.Name as Name
18import qualified Data.Set as Set
16import qualified Data.Set as Set
19
17
20import qualified AST.Source as Src
18import qualified AST.Source as Src
21−import qualified Elm.Compiler.Imports as Imports
22import qualified Elm.ModuleName as ModuleName
19import qualified Elm.ModuleName as ModuleName
23import Reporting.Doc ((<>))
20import Reporting.Doc ((<>))
24import qualified Reporting.Doc as D
21import qualified Reporting.Doc as D
@@ -115,26 +112,9 @@ toExposing exposing =
115 Only (foldr addType Set.empty exposedList)
112 Only (foldr addType Set.empty exposedList)
116
113
117
114
118−addType :: A.Located Src.Exposed -> Set.Set Name.Name -> Set.Set Name.Name
115+addType :: Src.Exposed -> Set.Set Name.Name -> Set.Set Name.Name
119−addType (A.At _ exposed) types =
116+addType exposed types =
120 case exposed of
117 case exposed of
121− Src.Lower _ -> types
118+ Src.Lower _ -> types
122− Src.Upper name _ -> Set.insert name types
119+ Src.Upper (A.At _ name) _ -> Set.insert name types
123− Src.Operator _ -> types
120+ 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+10
@@ -117,3 +117,13 @@ instance Monad (Result i w e) where
117 Result kb -> kb i1 w1 bad good
117 Result kb -> kb i1 w1 bad good
118 in
118 in
119 ka i w bad good1
119 ka i w bad good1
120+
121+ (>>) (Result ka) (Result kb) =
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+14−123
@@ -175,9 +175,7 @@ data Problem
175 | StringToFloat
175 | StringToFloat
176 | AnythingToBool
176 | AnythingToBool
177 | AnythingFromMaybe
177 | AnythingFromMaybe
178− | AnythingToList
178+ | ArityMismatch Int Int
179− | MissingArgs Int
180− | ReturnMismatch
181 | BadFlexSuper Direction Super Name.Name Type
179 | BadFlexSuper Direction Super Name.Name Type
182 | BadRigidVar Name.Name Type
180 | BadRigidVar Name.Name Type
183 | BadRigidSuper Super Name.Name Type
181 | BadRigidSuper Super Name.Name Type
@@ -255,7 +253,11 @@ toDiff localizer ctx tipe1 tipe2 =
255 <*> toDiff localizer RT.Func b y
253 <*> toDiff localizer RT.Func b y
256 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
254 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
257 else
255 else
258− diffLambda localizer ctx a b cs x y zs
256+ let f = toDoc localizer RT.Func in
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)))
259
261
260 (Tuple a b Nothing, Tuple x y Nothing) ->
262 (Tuple a b Nothing, Tuple x y Nothing) ->
261 RT.tuple
263 RT.tuple
@@ -298,7 +300,7 @@ toDiff localizer ctx tipe1 tipe2 =
298 different
300 different
299 (toDoc localizer ctx t1)
301 (toDoc localizer ctx t1)
300 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
302 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
301− (Bag.one AnythingToList)
303+ Bag.empty
302
304
303 (Alias home1 name1 args1 t1, t2) ->
305 (Alias home1 name1 args1 t1, t2) ->
304 case diffAliasedRecord localizer t1 t2 of
306 case diffAliasedRecord localizer t1 t2 of
@@ -447,6 +449,13 @@ isSuper super tipe =
447 Appendable -> isString h n || isList h n
449 Appendable -> isString h n || isList h n
448 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
450 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
449
451
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+
450 _ ->
459 _ ->
451 False
460 False
452
461
@@ -477,124 +486,6 @@ diffAliasedRecord localizer t1 t2 =
477
486
478
487
479
488
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−
598-- RECORD DIFFS
489-- RECORD DIFFS
599
490
600
491
compiler/src/Type/Solve.hs+7
@@ -427,6 +427,13 @@ 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+--
430typeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Type -> IO Variable
437typeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Type -> IO Variable
431typeToVar rank pools aliasDict tipe =
438typeToVar rank pools aliasDict tipe =
432 let go = typeToVar rank pools aliasDict in
439 let go = typeToVar rank pools aliasDict in
compiler/src/Type/Unify.hs+12−10
@@ -103,6 +103,13 @@ instance Monad Unify where
103 in
103 in
104 ka vars ok1 err
104 ka vars ok1 err
105
105
106+ (>>) (Unify ka) (Unify kb) =
107+ Unify $ \vars ok err ->
108+ let
109+ ok1 vars1 _ = kb vars1 ok err
110+ in
111+ ka vars ok1 err
112+
106
113
107register :: IO Variable -> Unify Variable
114register :: IO Variable -> Unify Variable
108register mkVar =
115register mkVar =
@@ -212,8 +219,6 @@ unifyFlex context content otherContent =
212 Error ->
219 Error ->
213 merge context Error
220 merge context Error
214
221
215− -- TODO see if wildcarding makes a noticable perf difference
216−
217 FlexVar maybeName ->
222 FlexVar maybeName ->
218 merge context $
223 merge context $
219 case maybeName of
224 case maybeName of
@@ -386,13 +391,13 @@ unifyFlexSuperStructure context super flatType =
386
391
387 Comparable ->
392 Comparable ->
388 do comparableOccursCheck context
393 do comparableOccursCheck context
389− merge context (Structure flatType)
390 unifyComparableRecursive variable
394 unifyComparableRecursive variable
395+ merge context (Structure flatType)
391
396
392 CompAppend ->
397 CompAppend ->
393 do comparableOccursCheck context
398 do comparableOccursCheck context
394− merge context (Structure flatType)
395 unifyComparableRecursive variable
399 unifyComparableRecursive variable
400+ merge context (Structure flatType)
396
401
397 Tuple1 a b maybeC ->
402 Tuple1 a b maybeC ->
398 case super of
403 case super of
@@ -404,15 +409,12 @@ unifyFlexSuperStructure context super flatType =
404
409
405 Comparable ->
410 Comparable ->
406 do comparableOccursCheck context
411 do comparableOccursCheck context
407− merge context (Structure flatType)
408 unifyComparableRecursive a
412 unifyComparableRecursive a
409 unifyComparableRecursive b
413 unifyComparableRecursive b
410 case maybeC of
414 case maybeC of
411− Nothing ->
415+ Nothing -> return ()
412− return ()
413−
414− Just c ->
415− unifyComparableRecursive c
416+ Just c -> unifyComparableRecursive c
417+ merge context (Structure flatType)
416
418
417 CompAppend ->
419 CompAppend ->
418 mismatch
420 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.0",
11+ "elm-version": "0.19.1",
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.0"` for most people!
51+The exact version of Elm this builds with. Should be `"0.19.1"` 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, 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, and BSD-3-Clause is a good default. But you can see the full list of options [here](https://spdx.org/licenses/).
53
53
54<br>
54<br>
55
55
upgrade-docs/0.16.md → docs/upgrade-instructions/0.16.mdrenamed

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

docs/upgrade-instructions/0.19.1.mdnew file+60
@@ -0,0 +1,60 @@
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 (..)`
upgrade-docs/earlier.md → docs/upgrade-instructions/earlier.mdrenamed

The content is the same.

elm.cabal+31−12
@@ -38,11 +38,14 @@ 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
41+ ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg -A128m"
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/
42
44
43 Hs-Source-Dirs:
45 Hs-Source-Dirs:
44 compiler/src
46 compiler/src
45 builder/src
47 builder/src
48+ terminal/impl
46 terminal/src
49 terminal/src
47
50
48 other-extensions:
51 other-extensions:
@@ -52,24 +55,38 @@ Executable elm
52 Main.hs
55 Main.hs
53
56
54 other-modules:
57 other-modules:
55− Develop.StaticFiles
58+ Bump
56− Develop.StaticFiles.Build
59+ Develop
60+ Diff
61+ Init
62+ Install
57 Make
63 Make
64+ Publish
65+ Repl
58
66
59 -- terminal args
67 -- terminal args
60− Terminal.Args
68+ Terminal
61− Terminal.Args.Chomp
69+ Terminal.Chomp
62− Terminal.Args.Error
70+ Terminal.Error
63− Terminal.Args.Helpers
71+ Terminal.Helpers
64− Terminal.Args.Internal
72+ Terminal.Internal
73+
74+ -- from terminal/
75+ Develop.Generate.Help
76+ Develop.Generate.Index
77+ Develop.StaticFiles
78+ Develop.StaticFiles.Build
65
79
66 -- from builder/
80 -- from builder/
67 Build
81 Build
82+ BackgroundWriter
68− Deps.Registry
83+ Deps.Bump
69 Deps.Diff
84 Deps.Diff
85+ Deps.Registry
70 Deps.Solver
86 Deps.Solver
71 Deps.Website
87 Deps.Website
72 File
88 File
89+ Generate
73 Http
90 Http
74 Reporting
91 Reporting
75 Reporting.Exit
92 Reporting.Exit
@@ -86,12 +103,14 @@ Executable elm
86 Elm.Compiler.Type.Extract
103 Elm.Compiler.Type.Extract
87 Elm.Constraint
104 Elm.Constraint
88 Elm.Docs
105 Elm.Docs
106+ Elm.Float
89 Elm.Interface
107 Elm.Interface
90 Elm.Kernel
108 Elm.Kernel
91 Elm.Licenses
109 Elm.Licenses
92 Elm.Magnitude
110 Elm.Magnitude
93 Elm.ModuleName
111 Elm.ModuleName
94 Elm.Package
112 Elm.Package
113+ Elm.String
95 Elm.Version
114 Elm.Version
96
115
97 -- data structures
116 -- data structures
@@ -106,6 +125,7 @@ Executable elm
106 -- json
125 -- json
107 Json.Decode
126 Json.Decode
108 Json.Encode
127 Json.Encode
128+ Json.String
109
129
110 -- from compiler/
130 -- from compiler/
111 AST.Canonical
131 AST.Canonical
@@ -145,12 +165,11 @@ Executable elm
145 Parse.Module
165 Parse.Module
146 Parse.Number
166 Parse.Number
147 Parse.Pattern
167 Parse.Pattern
148− Parse.Repl
149 Parse.Shader
168 Parse.Shader
150 Parse.Space
169 Parse.Space
170+ Parse.String
151 Parse.Symbol
171 Parse.Symbol
152 Parse.Type
172 Parse.Type
153− Parse.Utf8
154 Parse.Variable
173 Parse.Variable
155 Parse.Primitives
174 Parse.Primitives
156 Reporting.Annotation
175 Reporting.Annotation
@@ -212,7 +231,7 @@ Executable elm
212 snap-core,
231 snap-core,
213 snap-server,
232 snap-server,
214 template-haskell,
233 template-haskell,
215− time,
234+ time >= 1.9.1,
216 unordered-containers,
235 unordered-containers,
217 utf8-string,
236 utf8-string,
218 vector,
237 vector,
hints/bad-recursion.mdnew file+133
@@ -0,0 +1,133 @@
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.mdnew file+98
@@ -0,0 +1,98 @@
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.mdnew file+85
@@ -0,0 +1,85 @@
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.mdnew file+50
@@ -0,0 +1,50 @@
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.mdnew file+184
@@ -0,0 +1,184 @@
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.mdnew file+126
@@ -0,0 +1,126 @@
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.mdnew file+42
@@ -0,0 +1,42 @@
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.mdnew file+55
@@ -0,0 +1,55 @@
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.mdnew file+139
@@ -0,0 +1,139 @@
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.mdnew file+59
@@ -0,0 +1,59 @@
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.mdnew file+32
@@ -0,0 +1,32 @@
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.mdnew file+162
@@ -0,0 +1,162 @@
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.mdnew file+73
@@ -0,0 +1,73 @@
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.mdnew file+70
@@ -0,0 +1,70 @@
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.mdnew file+19
@@ -0,0 +1,19 @@
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.mdnew file+60
@@ -0,0 +1,60 @@
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.mdnew file+32
@@ -0,0 +1,32 @@
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/Dockerfilenew file+39
@@ -0,0 +1,39 @@
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.mdnew file+93
@@ -0,0 +1,93 @@
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+5−3
@@ -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 Platform</title>
3+ <title>Elm</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 Platform requires Mac OS X 10.6 or later.';
13+ my.result.message = 'This version of Elm 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,13 +18,15 @@ function pm_volume_check() {
18}
18}
19
19
20</script>
20</script>
21+ <!--
21 <background file="background.png" alignment="bottomleft" scaling="none" mime-type="image/png"/>
22 <background file="background.png" alignment="bottomleft" scaling="none" mime-type="image/png"/>
23+ -->
22 <welcome mime-type="text/rtf" file="welcome.rtf" />
24 <welcome mime-type="text/rtf" file="welcome.rtf" />
23 <conclusion mime-type="text/rtf" file="conclusion.rtf" />
25 <conclusion mime-type="text/rtf" file="conclusion.rtf" />
24 <choices-outline>
26 <choices-outline>
25 <line choice="choice2"/>
27 <line choice="choice2"/>
26 </choices-outline>
28 </choices-outline>
27− <choice id="choice2" title="Elm Platform ">
29+ <choice id="choice2" title="Elm">
28 <pkg-ref id="org.elm-lang.binaries.pkg"/>
30 <pkg-ref id="org.elm-lang.binaries.pkg"/>
29 </choice>
31 </choice>
30 <pkg-ref id="org.elm-lang.binaries.pkg" installKBytes="19444" version="1" auth="Root">binaries.pkg</pkg-ref>
32 <pkg-ref id="org.elm-lang.binaries.pkg" installKBytes="19444" version="1" auth="Root">binaries.pkg</pkg-ref>
installers/mac/README.mdnew file+93
@@ -0,0 +1,93 @@
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.pngdeleted

Binary file not shown.

installers/mac/Resources/en.lproj/conclusion.rtf+13−6
@@ -1,9 +1,16 @@
1−{\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400
1+{\rtf1\ansi\ansicpg1252\cocoartf2509
2−{\fonttbl\f0\fswiss\fcharset0 Helvetica;}
2+\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;}
3{\colortbl;\red255\green255\blue255;}
3{\colortbl;\red255\green255\blue255;}
4+{\*\expandedcolortbl;;}
4−\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0
5+\paperw11900\paperh16840\margl1440\margr1440\vieww11180\viewh8400\viewkind0
5−\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural
6+\pard\tx720\tx1440\tx2160\tx2880\tx3600\tx4320\tx5040\tx5760\tx6480\tx7200\tx7920\tx8640\pardirnatural\partightenfactor0
6
7
7−\f0\fs26 \cf0 A bunch of useful programs were just placed in /usr/local/bin/\
8+\f0\fs28 \cf0 Try opening the terminal and running commands like:\
8\
9\
10+
11+\f1 elm init\
12+elm make src/Main.elm --optimize\
13+elm repl
14+\f0 \
15+\
9−Check out {\field{\*\fldinst HYPERLINK "http://elm-lang.org/Get-Started.elm"}{\fldrslt this tutorial}} to learn how to use them!}
16+Check out {\field{\*\fldinst{HYPERLINK "https://guide.elm-lang.org/"}}{\fldrslt this tutorial}} for more advice!}
installers/mac/Resources/en.lproj/welcome.rtf+9−4
@@ -1,7 +1,12 @@
1−{\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400
1+{\rtf1\ansi\ansicpg1252\cocoartf2509
2−{\fonttbl\f0\fswiss\fcharset0 Helvetica;}
2+\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;}
3{\colortbl;\red255\green255\blue255;}
3{\colortbl;\red255\green255\blue255;}
4+{\*\expandedcolortbl;;}
4\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0
5\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0
5−\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural
6+\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural\partightenfactor0
6
7
7−\f0\fs28 \cf0 This package will install Elm on your machine.}
8+\f0\fs28 \cf0 Thank you for trying out Elm!\
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://elm-lang.org'
3+open 'http://guide.elm-lang.org'
installers/mac/make-installer.sh+30−3
@@ -29,7 +29,8 @@ 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>" \
32− --identifier org.elm-lang.binaries.pkg \
33+ --identifier org.elm-lang.binary \
33 --install-location $usr_binaries \
34 --install-location $usr_binaries \
34 --scripts $pkg_scripts \
35 --scripts $pkg_scripts \
35 --filter 'Scripts.*' \
36 --filter 'Scripts.*' \
@@ -39,16 +40,42 @@ pkgbuild \
39
40
40#### BUNDLE ASSETS ####
41#### BUNDLE ASSETS ####
41
42
42−rm -f Elm.pkg
43+rm -f installer-for-mac.pkg
43
44
44productbuild \
45productbuild \
46+ --sign "Developer ID Installer: <NAME>" \
47+ --identifier org.elm-lang.installer \
45 --distribution Distribution.xml \
48 --distribution Distribution.xml \
46 --package-path . \
49 --package-path . \
47 --resources Resources \
50 --resources Resources \
48− Elm.pkg
51+ installer-for-mac.pkg
49
52
50
53
51#### CLEAN UP ####
54#### CLEAN UP ####
52
55
53rm binaries.pkg
56rm binaries.pkg
54rm -rf $pkg_root
57rm -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+29−141
@@ -1,171 +1,59 @@
1−# Publishing a new release
1+# Publishing
2
2
3−A new version of Elm came out. Huzzah! Here's how to update the `npm` installer.
3+Here's how to update the `npm` installer.
4
4
5−## 1. Create tarballs of binaries
6
5
7−You can find a list of what binaries we'll need to tar up in `index.js`.
6+## 1. GitHub Release
8
7
9−For example:
8+Create a [GitHub Release](https://github.com/elm/compiler/releases) with the following files:
10
9
11−```javascript
10+1. `binary-for-mac-64-bit.gz`
12−var root =
11+2. `binary-for-windows-64-bit.gz`
13− "https://github.com/elm/compiler/releases/download/" +
12+3. `binary-for-linux-64-bit.gz`
14− binVersion +
15− "/binaries-for-";
16
13
17−module.exports = binwrap({
14+Create each of these by running the `elm` executable for each platform through `gzip elm`.
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:
29
15
30−1. `binaries-for-mac.tar.gz`
31−2. `binaries-for-windows.tar.gz`
32−3. `binaries-for-linux.tar.gz`
33
16
34−Each of these tarballs should have **only the Elm binary** inside them - no
17+## 2. Try a beta release
35−directories!
36
18
37−So create them by making a directory, putting all the binaries in it, `cd`-ing
19+In `package.json`, bump the version to `"0.19.2-beta"`.
38−into that directory, and then running something like this:
39
20
40−```shell
21+```bash
41−$ tar cvzf binaries-for-linux.tar.gz elm
22+npm publish --tag beta
42```
23```
43
24
44−Make sure each tarball contains all the binaries listed in that `binaries:` list
25+To test that it works, run these commands:
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:
80
26
81−```shell
27+```bash
82−$ git tag 0.19.0
28+npm dist-tags ls elm
83−$ git push origin 0.19.0
29+npm install elm@beta --ignore-scripts
84```
30```
85
31
86−Now this tag should exist on GitHub, allowing us to upload binaries to it.
32+The `latest` tag should not be changed, and there should be an additional `beta` tag.
87
33
88−## 5. Upload binaries
34+Try this on Windows, Linux, and Mac.
89
35
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.
94
36
95−Upload the tarballs you created in step 1.
37+## 3. Publish final release
96
38
97−## 6. Publish beta release
39+Remove the `-beta` suffix from the version in `package.json`. Then run:
98
40
99−Run this to publish the beta release. The `--tag beta` is **crucial** here.
41+```bash
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
105−$ npm publish --tag beta
42+npm publish
106```
43```
107
44
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−```
114
45
115−If you messed this up, and the `latest` tag now points to the beta you just
46+## 4. Tag the `latest-0.19.1` version
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.
119
47
120−## 7. Verify beta installer
48+Many compiler releases have needed multiple `npm` publications. Maybe something does not work on Windows or some dependency becomes insecure. Normal `npm` problems.
121
49
122−Make an empty directory and run `npm init` inside it.
50+The convention for each Elm release is to create a tag the latest one.
123
51
124−Then run this:
52+```bash
125−
53+npm dist-tag add elm@0.19.1-3 latest-0.19.1
126−```shell
127−$ npm install elm@beta --ignore-scripts
128```
54```
129
55
130−This should succeed with an exit code of `0`.
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.
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`
163
57
164−You're done! Now whenever anyone does `npm install -g elm` they'll get the
58+You can read more about dist-tags [here](https://docs.npmjs.com/cli/dist-tag).
165−version you just uploaded.
166
59
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+30−23
@@ -1,38 +1,45 @@
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)
1+# Elm Installer
2−===============
3
2
4−Install the [Elm Platform](https://github.com/elm-lang/elm-platform) via [`npm`](https://www.npmjs.com).
3+[Elm](https://elm-lang.org) is a functional programming language that compiles to JavaScript.
5
4
6−## Installing
5+Head over to [The Official Guide](https://guide.elm-lang.org/) to start learning Elm!
7
6
8−Run this to get the binaries:
9
7
10−```
8+<br/>
11−$ npm install -g elm
12−```
13
9
14−## Installing behind a proxy server
10+## What is this package for?
15
11
16−If you are behind a proxy server, set the environment variable "HTTPS_PROXY".
12+**Normal installs** ❌
17
13
18−```
14+Use the instructions [here](https://guide.elm-lang.org/install/elm.html) instead.
19−$ export HTTPS_PROXY=$YourProxyServer$
15+
20−$ npm install -g elm
16+**Multiple versions** ✅
21−```
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+
29+
30+<br/>
31+
32+## Install Locally
22
33
23−Or on Windows:
34+The following command should download the latest Elm 0.19.1 binary:
24
35
25```
36```
26−$ set HTTPS_PROXY=$YourProxyServer$
37+npm install elm@latest-0.19.1
27−$ npm install -g elm
28```
38```
29
39
30−## Troubleshooting
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.
31
41
32−1. [Troubleshooting npm](https://github.com/npm/npm/wiki/Troubleshooting)
42+Use `npm install elm@latest-0.19.0` or `npm install elm@latest-0.18.0` for earlier versions.
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.
35
43
36−## Getting Started
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.
37
45
38−Once everything has installed successfully, head over to the [Get Started](http://elm-lang.org/Get-Started.elm) page!
installers/npm/bin/elm+42−16
@@ -1,28 +1,54 @@
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 download = require('../download.js');
4+var path = require('path');
5var fs = require('fs');
5var fs = require('fs');
6
6
7
7
8−// Some npm users enable --ignore-scripts (a good security measure)
8+// Some npm users enable --ignore-scripts (a good security measure) so
9+// they do not run the post-install hook and install.js does not run.
10+// Instead they will run this script.
9//
11//
10−// They do not run the post-install hook, so install.js does not run.
12+// On Mac and Linux, we download the elm executable into the exact same
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.
11//
16//
12−// This file pretends to be the downloaded binary. It then downloads
17+// On Windows, we must download a file named elm.exe for it to run properly.
13−// the real binary over itself. So in that case, the first run would
18+// Instead of symlinks, npm creates two files:
14−// also make an HTTPS request to fetch the real binary.
19+//
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.
15
26
16
27
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+}
17
45
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]);
21
46
22−download(pathToThisFile, function() {
47+function runCommand()
23− // Need double quotes and { shell: true } when there are spaces in the path on windows:
48+{
24− // https://github.com/nodejs/node/issues/7367#issuecomment-229721296
49+ // Need double quotes and { shell: true } when there are spaces in the path on windows:
25− child_process
50+ // https://github.com/nodejs/node/issues/7367#issuecomment-229721296
26− .spawn('"' + pathToThisFile + '"', process.argv.slice(2), { stdio: 'inherit', shell: true })
51+ child_process
27− .on('exit', process.exit);
52+ .spawn('"' + binaryPath + '"', process.argv.slice(2), { stdio: 'inherit', shell: true })
28−});
53+ .on('exit', process.exit);
54+}
installers/npm/download.js+68−67
@@ -1,7 +1,7 @@
1var fs = require('fs');
1var fs = require('fs');
2var package = require('./package.json');
2var package = require('./package.json');
3−var URL = require('url').URL;
3+var path = require('path');
4−var https = require('https');
4+var request = require('request');
5var zlib = require('zlib');
5var zlib = require('zlib');
6
6
7
7
@@ -12,87 +12,72 @@ 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(destinationPath, callback)
15+module.exports = function(callback)
16{
16{
17+ // figure out URL of binary
17 var version = package.version.replace(/^(\d+\.\d+\.\d+).*$/, '$1'); // turn '1.2.3-alpha' into '1.2.3'
18 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];
20
19
21− download(
20+ var platform = {
22− process.platform === 'win32' ? destinationPath + '.exe' : destinationPath,
21+ darwin_x64: 'mac-64-bit',
23− 'https://github.com/elm/compiler/releases/download/' + version + '/binary-for-' + os + '-' + arch + '.gz',
22+ darwin_arm64: 'mac-64-bit',
24− callback
23+ win32_x64: 'windows-64-bit',
25− );
24+ linux_x64: 'linux-64-bit'
26−};
25+ }[process.platform + '_' + process.arch];
27
26
27+ verifyPlatform(version, platform);
28
28
29+ var url = 'https://github.com/elm/compiler/releases/download/' + version + '/binary-for-' + platform + '.gz';
29
30
30−// DOWNLOAD
31+ reportDownload(version, url);
31
32
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' : '');
32
35
33−function download(destinationPath, url, callback)
36+ // set up handler for request failure
34−{
37+ function reportDownloadFailure(error)
35− requestWithRedirects(url, 10,
38+ {
36− function(error) {
39+ exitFailure(url,'Something went wrong while fetching the following URL:\n\n' + url + '\n\nIt is saying:\n\n' + error);
37− exitFailure(url, 'I ran into trouble while fetching ' + url + '\n\n' + error);
40+ }
38− },
41+
39− function(response) {
42+ // set up decompression pipe
40− if (response.statusCode == 404)
43+ var gunzip = zlib.createGunzip().on('error', function(error) {
41− {
44+ exitFailure(url, 'I ran into trouble decompressing the downloaded binary. It is saying:\n\n' + error);
42− exitFailure(url, 'I got a "404 Not Found" trying to download from the following URL:\n'
45+ });
43− + url
46+
44− + '\n\nThis may mean you are trying to install on an unsupported platform. (e.g. some 32-bit systems?)'
47+ // set up file write pipe
45− );
48+ var write = fs.createWriteStream(binaryPath, {
46− }
49+ encoding: 'binary',
47−
50+ mode: 0o755
48− response.on('error', function() {
51+ }).on('finish', callback).on('error', function(error) {
49− exitFailure(url, 'Something went wrong while receiving the following URL:\n\n' + url);
52+ exitFailure(url, 'I had some trouble writing file to disk. It is saying:\n\n' + error);
50− });
53+ });
51−
54+
52− var gunzip = zlib.createGunzip().on('error', function(error) {
55+ // put it all together
53− exitFailure(url, 'I ran into trouble decompressing the downloaded binary. It is saying:\n\n' + error);
56+ request(url).on('error', reportDownloadFailure).pipe(gunzip).pipe(write);
54− });
55− var write = fs.createWriteStream(destinationPath, {
56− encoding: 'binary',
57− mode: 0o755
58− }).on('finish', callback).on('error', function(error) {
59− exitFailure(url, 'I had some trouble writing file to disk. It is saying:\n\n' + error);
60− });
61−
62− response.pipe(gunzip).pipe(write);
63− }
64− );
65}
57}
66
58
67
59
68
60
69−// HANDLE REDIRECTS
61+// VERIFY PLATFORM
70
62
71
63
72−function requestWithRedirects(url, maxRedirects, failure, success)
64+function verifyPlatform(version, platform)
73{
65{
74− var req = https.request(url);
66+ if (platform) return;
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− });
92−
93− req.on('error', failure);
94
67
95− req.end();
68+ var situation = process.platform + '_' + process.arch;
69+ console.error(
70+ '-- ERROR -----------------------------------------------------------------------\n\n'
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);
96}
81}
97
82
98
83
@@ -111,3 +96,19 @@ function exitFailure(url, message)
111 );
96 );
112 process.exit(1);
97 process.exit(1);
113}
98}
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+1−7
@@ -1,10 +1,4 @@
1
1
2var download = require('./download.js');
2var download = require('./download.js');
3−var package = require('./package.json');
4−var path = require('path');
5
3
6−
4+download(function() {});
7−// get slashes right for Windows
8−var targetPath = path.resolve(__dirname, Object.values(package.bin)[0]);
9−
10−download(targetPath, function() {});
installers/npm/package.json+6−7
@@ -1,6 +1,6 @@
1{
1{
2 "name": "elm",
2 "name": "elm",
3− "version": "0.19.0-no-deps",
3+ "version": "0.19.1-5",
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": "Richard Feldman",
14+ "name": "Evan Czaplicki",
15− "email": "richard.t.feldman@gmail.com",
15+ "email": "evan@elm-lang.org",
16− "url": "https://github.com/rtfeldman"
16+ "url": "https://github.com/evancz"
17 },
17 },
18 "engines": {
18 "engines": {
19 "node": ">=7.0.0"
19 "node": ">=7.0.0"
@@ -35,9 +35,8 @@
35 "install",
35 "install",
36 "installer"
36 "installer"
37 ],
37 ],
38− "bin": {
38+ "bin": { "elm": "bin/elm" },
39− "elm": "bin/elm"
40− },
41 "dependencies": {
39 "dependencies": {
40+ "request": "^2.88.0"
42 }
41 }
43}
42}
installers/npm/troubleshooting.mdnew file+76
@@ -0,0 +1,76 @@
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" "http://elm-lang.org/get-started"
78+ ExecShell "open" "https://guide.elm-lang.org"
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+18−3
@@ -1,9 +1,24 @@
1−# Building Windows installer
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
2
17
3You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed.
18You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed.
4
19
5Once everything is installed, run something like this command:
20Once everything is installed, run something like this command:
6
21
7− make_installer.cmd 0.19
22+ make_installer.cmd 0.19.0
8
23
9−It will build an installer called `Elm-0.19-setup.exe`.
24+It will build an installer called `Elm-0.19.0-setup.exe`.
installers/win/file.icodeleted

Binary file not shown.

installers/win/inst.dat+1−2
@@ -2,6 +2,5 @@ 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"
6File "updatepath.vbs"
5File "updatepath.vbs"
7−File "removefrompath.vbs"
6+File "removefrompath.vbs"
installers/win/logo.ico

Binary file not shown.

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

Binary file not shown.

reactor/assets/waiting.gifdeleted

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.0",
6+ "elm-version": "0.19.1",
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+20−15
@@ -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 "project" (D.nullable Project.decoder))
67+ (D.field "outline" (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 (viewDependency exactDeps) info.depsDirect
222+ List.map viewVersion info.depsDirect
223
223
224 Project.Package info ->
224 Project.Package info ->
225− List.map (viewDependency exactDeps) info.deps
225+ List.map (viewConstraint 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 (viewDependency exactDeps) info.testDepsDirect
240+ List.map viewVersion info.testDepsDirect
241
241
242 Project.Package info ->
242 Project.Package info ->
243− List.map (viewDependency exactDeps) info.testDeps
243+ List.map (viewConstraint exactDeps) info.testDeps
244 in
244 in
245 Skeleton.box
245 Skeleton.box
246 { title = "Test Dependencies"
246 { title = "Test Dependencies"
@@ -249,9 +249,22 @@ viewTestDeps exactDeps project =
249 }
249 }
250
250
251
251
252−viewDependency : ExactDeps -> (Package.Name, vsn) -> List (Html msg)
252+viewVersion : (Package.Name, Version.Version) -> List (Html msg)
253−viewDependency exactDeps (pkg, _) =
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)
263+viewConstraint exactDeps (pkg, _) =
254 case Dict.get (Package.toString pkg) exactDeps of
264 case Dict.get (Package.toString pkg) exactDeps of
265+ Just vsn ->
266+ viewVersion (pkg, vsn)
267+
255 Nothing ->
268 Nothing ->
256 [ div [ style "float" "left" ]
269 [ div [ style "float" "left" ]
257 [ Icon.package
270 [ Icon.package
@@ -260,14 +273,6 @@ viewDependency exactDeps (pkg, _) =
260 , div [ style "float" "right" ] [ text "???" ]
273 , div [ style "float" "right" ] [ text "???" ]
261 ]
274 ]
262
275
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−
271
276
272toPackageUrl : Package.Name -> Version.Version -> String
277toPackageUrl : Package.Name -> Version.Version -> String
273toPackageUrl name version =
278toPackageUrl 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.mdnew file+29
@@ -0,0 +1,29 @@
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/Terminal/Args.hs → terminal/impl/Terminal.hsrenamed+33−27
@@ -1,8 +1,7 @@
1−module Terminal.Args
1+module Terminal
2− ( simple
2+ ( app
3− , Interface(..)
3+ , Command(..)
4 , Summary(..)
4 , Summary(..)
5− , complex
6 , Flags, noFlags, flags, (|--)
5 , Flags, noFlags, flags, (|--)
7 , Flag, flag, onOff
6 , Flag, flag, onOff
8 , Parser(..)
7 , Parser(..)
@@ -20,23 +19,25 @@ import qualified System.Environment as Env
20import qualified System.Exit as Exit
19import qualified System.Exit as Exit
21import qualified System.FilePath as FP
20import qualified System.FilePath as FP
22import System.FilePath ((</>))
21import 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.Args.Internal
28+import Terminal.Internal
29−import qualified Terminal.Args.Chomp as Chomp
29+import qualified Terminal.Chomp as Chomp
30−import qualified Terminal.Args.Error as Error
30+import qualified Terminal.Error as Error
31
31
32
32
33
33
34−-- GET
34+-- COMMAND
35
35
36
36
37−simple :: String -> P.Doc -> Args args -> Flags flags -> (args -> flags -> IO ()) -> IO ()
37+_command :: String -> P.Doc -> Args args -> Flags flags -> (args -> flags -> IO ()) -> IO ()
38−simple details example args_ flags_ callback =
38+_command details example args_ flags_ callback =
39− do argStrings <- Env.getArgs
39+ do setLocaleEncoding utf8
40+ argStrings <- Env.getArgs
40 case argStrings of
41 case argStrings of
41 ["--version"] ->
42 ["--version"] ->
42 do hPutStrLn stdout (V.toChars V.compiler)
43 do hPutStrLn stdout (V.toChars V.compiler)
@@ -55,33 +56,38 @@ simple details example args_ flags_ callback =
55 Error.exitWithError err
56 Error.exitWithError err
56
57
57
58
58−complex :: P.Doc -> P.Doc -> [Interface] -> IO ()
59+
59−complex intro outro interfaces =
60+-- APP
60− do argStrings <- Env.getArgs
61+
62+
63+app :: P.Doc -> P.Doc -> [Command] -> IO ()
64+app intro outro commands =
65+ do setLocaleEncoding utf8
66+ argStrings <- Env.getArgs
61 case argStrings of
67 case argStrings of
62 [] ->
68 [] ->
63− Error.exitWithOverview intro outro interfaces
69+ Error.exitWithOverview intro outro commands
64
70
65 ["--help"] ->
71 ["--help"] ->
66− Error.exitWithOverview intro outro interfaces
72+ Error.exitWithOverview intro outro commands
67
73
68 ["--version"] ->
74 ["--version"] ->
69 do hPutStrLn stdout (V.toChars V.compiler)
75 do hPutStrLn stdout (V.toChars V.compiler)
70 Exit.exitSuccess
76 Exit.exitSuccess
71
77
72 command : chunks ->
78 command : chunks ->
73− do case List.find (\iface -> toName iface == command) interfaces of
79+ do case List.find (\cmd -> toName cmd == command) commands of
74 Nothing ->
80 Nothing ->
75− Error.exitWithUnknown command (map toName interfaces)
81+ Error.exitWithUnknown command (map toName commands)
76
82
77− Just (Interface _ _ details example args_ flags_ callback) ->
83+ Just (Command _ _ details example args_ flags_ callback) ->
78 if elem "--help" chunks then
84 if elem "--help" chunks then
79 Error.exitWithHelp (Just command) details example args_ flags_
85 Error.exitWithHelp (Just command) details example args_ flags_
80
86
81 else
87 else
82 case snd $ Chomp.chomp Nothing chunks args_ flags_ of
88 case snd $ Chomp.chomp Nothing chunks args_ flags_ of
83− Right (argsValue, flagValue) ->
89+ Right (argsValue, flagsValue) ->
84− callback argsValue flagValue
90+ callback argsValue flagsValue
85
91
86 Left err ->
92 Left err ->
87 Error.exitWithError err
93 Error.exitWithError err
@@ -156,21 +162,21 @@ findIndex index point chunks =
156 findIndex (index + 1) point cs
162 findIndex (index + 1) point cs
157
163
158
164
159−_complexSuggest :: [Interface] -> Int -> [String] -> IO [String]
165+_complexSuggest :: [Command] -> Int -> [String] -> IO [String]
160−_complexSuggest interfaces index strings =
166+_complexSuggest commands index strings =
161 case strings of
167 case strings of
162 [] ->
168 [] ->
163− return (map toName interfaces)
169+ return (map toName commands)
164
170
165 command : chunks ->
171 command : chunks ->
166 if index == 1 then
172 if index == 1 then
167− return (filter (List.isPrefixOf command) (map toName interfaces))
173+ return (filter (List.isPrefixOf command) (map toName commands))
168 else
174 else
169− case List.find (\iface -> toName iface == command) interfaces of
175+ case List.find (\cmd -> toName cmd == command) commands of
170 Nothing ->
176 Nothing ->
171 return []
177 return []
172
178
173− Just (Interface _ _ _ _ args_ flags_ _) ->
179+ Just (Command _ _ _ _ args_ flags_ _) ->
174 fst $ Chomp.chomp (Just (index-1)) chunks args_ flags_
180 fst $ Chomp.chomp (Just (index-1)) chunks args_ flags_
175
181
176
182
terminal/src/Terminal/Args/Chomp.hs → terminal/impl/Terminal/Chomp.hsrenamed+4−5
@@ -1,6 +1,5 @@
1−{-# LANGUAGE GADTs #-}
1+{-# LANGUAGE GADTs, Rank2Types #-}
2−{-# LANGUAGE Rank2Types #-}
2+module Terminal.Chomp
3−module Terminal.Args.Chomp
4 ( chomp
3 ( chomp
5 )
4 )
6 where
5 where
@@ -8,8 +7,8 @@ module Terminal.Args.Chomp
8
7
9import qualified Data.List as List
8import qualified Data.List as List
10
9
11−import Terminal.Args.Error
10+import Terminal.Error
12−import Terminal.Args.Internal
11+import Terminal.Internal
13
12
14
13
15
14
terminal/src/Terminal/Args/Error.hs → terminal/impl/Terminal/Error.hsrenamed+28−18
@@ -1,6 +1,5 @@
1−{-# LANGUAGE GADTs #-}
1+{-# LANGUAGE GADTs, OverloadedStrings #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+module Terminal.Error
3−module Terminal.Args.Error
4 ( Error(..)
3 ( Error(..)
5 , ArgError(..)
4 , ArgError(..)
6 , FlagError(..)
5 , FlagError(..)
@@ -24,7 +23,7 @@ import System.IO (hPutStrLn, stderr)
24import qualified Text.PrettyPrint.ANSI.Leijen as P
23import qualified Text.PrettyPrint.ANSI.Leijen as P
25
24
26import Reporting.Suggest as Suggest
25import Reporting.Suggest as Suggest
27−import Terminal.Args.Internal
26+import Terminal.Internal
28
27
29
28
30
29
@@ -187,22 +186,22 @@ flagsToDocs flags docs =
187-- OVERVIEW
186-- OVERVIEW
188
187
189
188
190−exitWithOverview :: P.Doc -> P.Doc -> [Interface] -> IO a
189+exitWithOverview :: P.Doc -> P.Doc -> [Command] -> IO a
191−exitWithOverview intro outro interfaces =
190+exitWithOverview intro outro commands =
192 do exeName <- getExeName
191 do exeName <- getExeName
193 exitSuccess
192 exitSuccess
194 [ intro
193 [ intro
195 , "The most common commands are:"
194 , "The most common commands are:"
196− , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) interfaces
195+ , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) commands
197 , "There are a bunch of other commands as well though. Here is a full list:"
196 , "There are a bunch of other commands as well though. Here is a full list:"
198− , P.indent 4 $ P.dullcyan $ toCommandList exeName interfaces
197+ , P.indent 4 $ P.dullcyan $ toCommandList exeName commands
199 , "Adding the --help flag gives a bunch of additional details about each one."
198 , "Adding the --help flag gives a bunch of additional details about each one."
200 , outro
199 , outro
201 ]
200 ]
202
201
203
202
204−toSummary :: String -> Interface -> Maybe P.Doc
203+toSummary :: String -> Command -> Maybe P.Doc
205−toSummary exeName (Interface name summary _ _ (Args args) _ _) =
204+toSummary exeName (Command name summary _ _ (Args args) _ _) =
206 case summary of
205 case summary of
207 Uncommon ->
206 Uncommon ->
208 Nothing
207 Nothing
@@ -215,10 +214,10 @@ toSummary exeName (Interface name summary _ _ (Args args) _ _) =
215 ]
214 ]
216
215
217
216
218−toCommandList :: String -> [Interface] -> P.Doc
217+toCommandList :: String -> [Command] -> P.Doc
219−toCommandList exeName interfaces =
218+toCommandList exeName commands =
220 let
219 let
221− names = map toName interfaces
220+ names = map toName commands
222 width = maximum (map length names)
221 width = maximum (map length names)
223
222
224 toExample name =
223 toExample name =
@@ -272,13 +271,24 @@ exitWithError err =
272 BadArgs argErrors ->
271 BadArgs argErrors ->
273 case argErrors of
272 case argErrors of
274 [] ->
273 [] ->
275− error "TODO no possible args"
274+ return
275+ [ reflow $ "I was not expecting any arguments for this command."
276+ , reflow $ "Try removing them?"
277+ ]
276
278
277 [(_args, argError)] ->
279 [(_args, argError)] ->
278 argErrorToDocs argError
280 argErrorToDocs argError
279
281
280 _:_:_ ->
282 _:_:_ ->
281− error "TODO show possible arg configurations"
283+ argErrorToDocs $ head $ List.sortOn toArgErrorRank (map snd argErrors)
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
282
292
283
293
284toGreen :: String -> P.Doc
294toGreen :: String -> P.Doc
@@ -318,10 +328,10 @@ argErrorToDocs argError =
318 return
328 return
319 [ "I am having trouble with this argument:"
329 [ "I am having trouble with this argument:"
320 , P.indent 4 $ toRed string
330 , P.indent 4 $ toRed string
321− , P.fillSep
331+ , P.fillSep $
322 ["It","is","supposed","to","be","a"
332 ["It","is","supposed","to","be","a"
323− ,toYellow (toToken tipe),"value,","like","this:"
333+ ,toYellow (toToken tipe),"value,","like"
324− ]
334+ ] ++ if length examples == 1 then ["this:"] else ["one","of","these:"]
325 , P.indent 4 $ P.green $ P.vcat $ map P.text examples
335 , P.indent 4 $ P.green $ P.vcat $ map P.text examples
326 ]
336 ]
327
337
terminal/src/Terminal/Args/Helpers.hs → terminal/impl/Terminal/Helpers.hsrenamed+41−19
@@ -1,5 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2−module Terminal.Args.Helpers
2+module Terminal.Helpers
3 ( version
3 ( version
4 , elmFile
4 , elmFile
5 , package
5 , package
@@ -7,13 +7,20 @@ module Terminal.Args.Helpers
7 where
7 where
8
8
9
9
10+import qualified Data.ByteString.UTF8 as BS_UTF8
10import qualified Data.Char as Char
11import qualified Data.Char as Char
12+import qualified Data.List as List
13+import qualified Data.Map as Map
11import qualified Data.Utf8 as Utf8
14import qualified Data.Utf8 as Utf8
12import qualified System.FilePath as FP
15import qualified System.FilePath as FP
13
16
14−import Terminal.Args (Parser(..))
17+import Terminal (Parser(..))
18+import qualified Deps.Registry as Registry
15import qualified Elm.Package as Pkg
19import qualified Elm.Package as Pkg
16import qualified Elm.Version as V
20import qualified Elm.Version as V
21+import qualified Parse.Primitives as P
22+import qualified Stuff
23+import qualified Reporting.Suggest as Suggest
17
24
18
25
19
26
@@ -33,7 +40,9 @@ version =
33
40
34parseVersion :: String -> Maybe V.Version
41parseVersion :: String -> Maybe V.Version
35parseVersion chars =
42parseVersion chars =
36− V.fromString (Utf8.fromChars chars)
43+ case P.fromByteString V.parser (,) (BS_UTF8.fromString chars) of
44+ Right vsn -> Just vsn
45+ Left _ -> Nothing
37
46
38
47
39suggestVersion :: String -> IO [String]
48suggestVersion :: String -> IO [String]
@@ -102,25 +111,38 @@ package =
102
111
103
112
104parsePackage :: String -> Maybe Pkg.Name
113parsePackage :: String -> Maybe Pkg.Name
105−parsePackage string =
114+parsePackage chars =
106− either (const Nothing) Just $
115+ case P.fromByteString Pkg.parser (,) (BS_UTF8.fromString chars) of
107− Pkg.fromString (Utf8.fromChars string)
116+ Right pkg -> Just pkg
117+ Left _ -> Nothing
108
118
109
119
110suggestPackages :: String -> IO [String]
120suggestPackages :: String -> IO [String]
111−suggestPackages _ =
121+suggestPackages given =
112− return []
122+ do cache <- Stuff.getPackageCache
123+ maybeRegistry <- Registry.read cache
124+ 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)
113
132
114
133
115examplePackages :: String -> IO [String]
134examplePackages :: String -> IO [String]
116−examplePackages string =
135+examplePackages given =
117− case Pkg.fromString (Utf8.fromChars string) of
136+ do cache <- Stuff.getPackageCache
118− Left _ ->
137+ maybeRegistry <- Registry.read cache
119− return (error "TODO need to make suggestions")
138+ return $
120−
139+ case maybeRegistry of
121− _ ->
140+ Nothing ->
122− return
141+ [ "elm/json"
123− [ "elm/http"
142+ , "elm/http"
124− , "elm/json"
143+ , "elm/random"
125− , "elm-community/random-extra"
144+ ]
126− ]
145+
146+ Just (Registry.Registry _ versions) ->
147+ map Pkg.toChars $ take 4 $
148+ Suggest.sort given Pkg.toChars (Map.keys versions)
terminal/src/Terminal/Args/Internal.hs → terminal/impl/Terminal/Internal.hsrenamed+8−8
@@ -1,6 +1,6 @@
1{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2−module Terminal.Args.Internal
2+module Terminal.Internal
3− ( Interface(..)
3+ ( Command(..)
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−-- INTERFACE
20+-- COMMAND
21
21
22
22
23−data Interface where
23+data Command where
24− Interface
24+ Command
25 :: String
25 :: String
26 -> Summary
26 -> Summary
27 -> String
27 -> String
@@ -29,11 +29,11 @@ data Interface where
29 -> Args args
29 -> Args args
30 -> Flags flags
30 -> Flags flags
31 -> (args -> flags -> IO ())
31 -> (args -> flags -> IO ())
32− -> Interface
32+ -> Command
33
33
34
34
35−toName :: Interface -> String
35+toName :: Command -> String
36−toName (Interface name _ _ _ _ _ _) =
36+toName (Command name _ _ _ _ _ _) =
37 name
37 name
38
38
39
39
terminal/src/Bump.hs+158−8
@@ -1,10 +1,31 @@
1−module Bump (run) where
1+{-# LANGUAGE OverloadedStrings #-}
2+module Bump
3+ ( run
4+ )
5+ where
2
6
3
7
4−import qualified Elm.Bump as Bump
8+import qualified Data.List as List
5−import qualified Elm.Project as Project
9+import qualified Data.NonEmptyList as NE
10+
11+import qualified BackgroundWriter as BW
12+import qualified Build
13+import qualified Deps.Bump as Bump
14+import qualified Deps.Diff as Diff
15+import qualified Deps.Registry as Registry
16+import qualified Elm.Details as Details
17+import qualified Elm.Docs as Docs
18+import qualified Elm.Magnitude as M
19+import qualified Elm.Outline as Outline
20+import qualified Elm.Version as V
21+import qualified Http
22+import Reporting.Doc ((<>), (<+>))
23+import qualified Reporting
24+import qualified Reporting.Doc as D
25+import qualified Reporting.Exit as Exit
26+import qualified Reporting.Exit.Help as Help
6import qualified Reporting.Task as Task
27import qualified Reporting.Task as Task
7−import qualified Reporting.Progress.Terminal as Terminal
28+import qualified Stuff
8
29
9
30
10
31
@@ -13,7 +34,136 @@ import qualified Reporting.Progress.Terminal as Terminal
13
34
14run :: () -> () -> IO ()
35run :: () -> () -> IO ()
15run () () =
36run () () =
16− do reporter <- Terminal.create
37+ Reporting.attempt Exit.bumpToReport $
17− Task.run reporter $
38+ Task.run (bump =<< getEnv)
18− do summary <- Project.getRoot
39+
19− Bump.bump summary
40+
41+
42+-- ENV
43+
44+
45+data Env =
46+ Env
47+ { _root :: FilePath
48+ , _cache :: Stuff.PackageCache
49+ , _manager :: Http.Manager
50+ , _registry :: Registry.Registry
51+ , _outline :: Outline.PkgOutline
52+ }
53+
54+
55+getEnv :: Task.Task Exit.Bump Env
56+getEnv =
57+ do maybeRoot <- Task.io $ Stuff.findRoot
58+ case maybeRoot of
59+ Nothing ->
60+ Task.throw Exit.BumpNoOutline
61+
62+ Just root ->
63+ do cache <- Task.io $ Stuff.getPackageCache
64+ manager <- Task.io $ Http.getManager
65+ registry <- Task.eio Exit.BumpMustHaveLatestRegistry $ Registry.latest manager cache
66+ outline <- Task.eio Exit.BumpBadOutline $ Outline.read root
67+ case outline of
68+ Outline.App _ ->
69+ Task.throw Exit.BumpApplication
70+
71+ Outline.Pkg pkgOutline ->
72+ return $ Env root cache manager registry pkgOutline
73+
74+
75+
76+-- BUMP
77+
78+
79+bump :: Env -> Task.Task Exit.Bump ()
80+bump env@(Env root _ _ registry outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
81+ case Registry.getVersions pkg registry of
82+ Just knownVersions ->
83+ let
84+ bumpableVersions =
85+ map (\(old, _, _) -> old) (Bump.getPossibilities knownVersions)
86+ in
87+ if elem vsn bumpableVersions
88+ then suggestVersion env
89+ else
90+ Task.throw $ Exit.BumpUnexpectedVersion vsn $
91+ map head (List.group (List.sort bumpableVersions))
92+
93+ Nothing ->
94+ Task.io $ checkNewPackage root outline
95+
96+
97+
98+-- CHECK NEW PACKAGE
99+
100+
101+checkNewPackage :: FilePath -> Outline.PkgOutline -> IO ()
102+checkNewPackage root outline@(Outline.PkgOutline _ _ _ version _ _ _ _) =
103+ do putStrLn Exit.newPackageOverview
104+ if version == V.one
105+ then
106+ putStrLn "The version number in elm.json is correct so you are all set!"
107+ else
108+ changeVersion root outline V.one $
109+ "It looks like the version in elm.json has been changed though!\n\
110+ \Would you like me to change it back to "
111+ <> D.fromVersion V.one <> "? [Y/n] "
112+
113+
114+
115+-- SUGGEST VERSION
116+
117+
118+suggestVersion :: Env -> Task.Task Exit.Bump ()
119+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+ newDocs <- generateDocs root outline
122+ let changes = Diff.diff oldDocs newDocs
123+ let newVersion = Diff.bump changes vsn
124+ Task.io $ changeVersion root outline newVersion $
125+ let
126+ old = D.fromVersion vsn
127+ new = D.fromVersion newVersion
128+ mag = D.fromChars $ M.toChars (Diff.toMagnitude changes)
129+ in
130+ "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
131+ <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
132+ <> "\n"
133+ <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
134+
135+
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+
152+-- CHANGE VERSION
153+
154+
155+changeVersion :: FilePath -> Outline.PkgOutline -> V.Version -> D.Doc -> IO ()
156+changeVersion root outline targetVersion question =
157+ do approved <- Reporting.ask question
158+ if not approved
159+ then
160+ putStrLn "Okay, I did not change anything!"
161+
162+ else
163+ do Outline.write root $ Outline.Pkg $
164+ outline { Outline._pkg_version = targetVersion }
165+
166+ Help.toStdout $
167+ "Version changed to "
168+ <> D.green (D.fromVersion targetVersion)
169+ <> "!\n"
terminal/src/Develop.hs+70−77
@@ -7,27 +7,31 @@ 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)
12import Control.Monad.Trans (MonadIO(liftIO))
11import Control.Monad.Trans (MonadIO(liftIO))
13import qualified Data.ByteString.Builder as B
12import qualified Data.ByteString.Builder as B
14import qualified Data.ByteString as BS
13import qualified Data.ByteString as BS
15import qualified Data.HashMap.Strict as HashMap
14import qualified Data.HashMap.Strict as HashMap
16import Data.Monoid ((<>))
15import 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
19+import Snap.Core hiding (path)
20import Snap.Http.Server
20import Snap.Http.Server
21import Snap.Util.FileServe
21import Snap.Util.FileServe
22
22
23−import qualified Elm.Project as Project
23+import qualified BackgroundWriter as BW
24−import qualified Develop.Generate.Help as Generate
24+import qualified Build
25+import qualified Elm.Details as Details
26+import qualified Develop.Generate.Help as Help
25import qualified Develop.Generate.Index as Index
27import qualified Develop.Generate.Index as Index
26import qualified Develop.StaticFiles as StaticFiles
28import qualified Develop.StaticFiles as StaticFiles
27−import qualified Generate.Output as Output
29+import qualified Generate.Html as Html
30+import qualified Generate
31+import qualified Reporting
28import qualified Reporting.Exit as Exit
32import qualified Reporting.Exit as Exit
29−import qualified Reporting.Progress as Progress
30import qualified Reporting.Task as Task
33import qualified Reporting.Task as Task
34+import qualified Stuff
31
35
32
36
33
37
@@ -42,31 +46,19 @@ data Flags =
42
46
43run :: () -> Flags -> IO ()
47run :: () -> Flags -> IO ()
44run () (Flags maybePort) =
48run () (Flags maybePort) =
45− let
49+ do let port = maybe 8000 id maybePort
46− port =
50+ putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard."
47− maybe 8000 id maybePort
51+ httpServe (config port) $
48− in
52+ serveFiles
49− do putStrLn $ "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."
53+ <|> serveDirectoryWith directoryConfig "."
50−
54+ <|> serveAssets
51− httpServe (config port) $
55+ <|> error404
52− serveFiles
53− <|> serveDirectoryWith directoryConfig "."
54− <|> serveAssets
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
61+ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
62− # setPort port
63− # setAccessLog ConfigNoLog
64− # setErrorLog ConfigNoLog
65−
66−
67−(#) :: a -> (a -> b) -> b
68−(#) value func =
69− func value
70
62
71
63
72
64
@@ -75,18 +67,12 @@ config port =
75
67
76directoryConfig :: MonadSnap m => DirectoryConfig m
68directoryConfig :: MonadSnap m => DirectoryConfig m
77directoryConfig =
69directoryConfig =
78− let
70+ fancyDirectoryConfig
79− customGenerator pwd =
71+ { indexFiles = []
80− do modifyResponse $ setContentType "text/html; charset=utf-8"
72+ , indexGenerator = \pwd ->
81− html <- liftIO $
73+ do modifyResponse $ setContentType "text/html;charset=utf-8"
82− do root <- Dir.getCurrentDirectory
74+ writeBuilder =<< liftIO (Index.generate pwd)
83− Index.get root pwd
75+ }
84− writeBuilder html
85− in
86− fancyDirectoryConfig
87− { indexFiles = []
88− , indexGenerator = customGenerator
89− }
90
76
91
77
92
78
@@ -96,8 +82,8 @@ directoryConfig =
96error404 :: Snap ()
82error404 :: Snap ()
97error404 =
83error404 =
98 do modifyResponse $ setResponseStatus 404 "Not Found"
84 do modifyResponse $ setResponseStatus 404 "Not Found"
99− modifyResponse $ setContentType "text/html; charset=utf-8"
85+ modifyResponse $ setContentType "text/html;charset=utf-8"
100− writeBuilder $ Generate.makePageHtml "NotFound" Nothing
86+ writeBuilder $ Help.makePageHtml "NotFound" Nothing
101
87
102
88
103
89
@@ -106,9 +92,9 @@ error404 =
106
92
107serveFiles :: Snap ()
93serveFiles :: Snap ()
108serveFiles =
94serveFiles =
109− do file <- getSafePath
95+ do path <- getSafePath
110− guard =<< liftIO (Dir.doesFileExist file)
96+ guard =<< liftIO (Dir.doesFileExist path)
111− serveElm file <|> serveFilePretty file
97+ serveElm path <|> serveFilePretty path
112
98
113
99
114
100
@@ -116,34 +102,33 @@ serveFiles =
116
102
117
103
118serveFilePretty :: FilePath -> Snap ()
104serveFilePretty :: FilePath -> Snap ()
119−serveFilePretty file =
105+serveFilePretty path =
120 let
106 let
121 possibleExtensions =
107 possibleExtensions =
122− getSubExts (takeExtensions file)
108+ getSubExts (takeExtensions path)
123 in
109 in
124 case mconcat (map lookupMimeType possibleExtensions) of
110 case mconcat (map lookupMimeType possibleExtensions) of
125 Nothing ->
111 Nothing ->
126− serveCode file
112+ serveCode path
127
113
128 Just mimeType ->
114 Just mimeType ->
129− serveFileAs mimeType file
115+ serveFileAs mimeType path
130
116
131
117
132getSubExts :: String -> [String]
118getSubExts :: String -> [String]
133getSubExts fullExtension =
119getSubExts fullExtension =
134 if null fullExtension then
120 if null fullExtension then
135 []
121 []
136−
137 else
122 else
138 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
123 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
139
124
140
125
141serveCode :: String -> Snap ()
126serveCode :: String -> Snap ()
142−serveCode file =
127+serveCode path =
143− do code <- liftIO (BS.readFile file)
128+ do code <- liftIO (BS.readFile path)
144 modifyResponse (setContentType "text/html")
129 modifyResponse (setContentType "text/html")
145 writeBuilder $
130 writeBuilder $
146− Generate.makeCodeHtml ('~' : '/' : file) (B.byteString code)
131+ Help.makeCodeHtml ('~' : '/' : path) (B.byteString code)
147
132
148
133
149
134
@@ -151,31 +136,33 @@ serveCode file =
151
136
152
137
153serveElm :: FilePath -> Snap ()
138serveElm :: FilePath -> Snap ()
154−serveElm file =
139+serveElm path =
155− do guard (takeExtension file == ".elm")
140+ do guard (takeExtension path == ".elm")
156 modifyResponse (setContentType "text/html")
141 modifyResponse (setContentType "text/html")
157− writeBuilder =<< liftIO (compileToHtmlBuilder file)
142+ result <- liftIO $ compile path
158−
143+ case result of
159−
144+ Right builder ->
160−compileToHtmlBuilder :: FilePath -> IO B.Builder
145+ writeBuilder builder
161−compileToHtmlBuilder file =
162− do mvar1 <- newEmptyMVar
163− mvar2 <- newEmptyMVar
164−
165− let reporter = Progress.Reporter (\_ -> return ()) (\_ -> return True) (putMVar mvar1)
166− let output = Just (Output.HtmlBuilder mvar2)
167
146
168− void $ Task.try reporter $
147+ Left exit ->
169− do summary <- Project.getRoot
148+ writeBuilder $ Help.makePageHtml "Errors" $ Just $
170− Project.compile Output.Dev Output.Client output summary [file]
149+ Exit.toJson $ Exit.reactorToReport exit
171
150
172− result <- takeMVar mvar1
173− case result of
174− Just exit ->
175− return $ Generate.makePageHtml "Errors" (Just (Exit.toJson exit))
176
151
152+compile :: FilePath -> IO (Either Exit.Reactor B.Builder)
153+compile path =
154+ do maybeRoot <- Stuff.findRoot
155+ case maybeRoot of
177 Nothing ->
156 Nothing ->
178− takeMVar mvar2
157+ return $ Left $ Exit.ReactorNoOutline
158+
159+ Just root ->
160+ BW.withScope $ \scope -> Stuff.withRootLock root $ Task.run $
161+ do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root
162+ artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details (NE.List path [])
163+ javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts
164+ let (NE.List name _) = Build.getRootNames artifacts
165+ return $ Html.sandwich name javascript
179
166
180
167
181
168
@@ -184,8 +171,8 @@ compileToHtmlBuilder file =
184
171
185serveAssets :: Snap ()
172serveAssets :: Snap ()
186serveAssets =
173serveAssets =
187− do file <- getSafePath
174+ do path <- getSafePath
188− case StaticFiles.lookup file of
175+ case StaticFiles.lookup path of
189 Nothing ->
176 Nothing ->
190 pass
177 pass
191
178
@@ -231,13 +218,16 @@ mimeTypeDict =
231 , ".m3u" ==> "audio/x-mpegurl"
218 , ".m3u" ==> "audio/x-mpegurl"
232 , ".mov" ==> "video/quicktime"
219 , ".mov" ==> "video/quicktime"
233 , ".mp3" ==> "audio/mpeg"
220 , ".mp3" ==> "audio/mpeg"
221+ , ".mp4" ==> "video/mp4"
234 , ".mpeg" ==> "video/mpeg"
222 , ".mpeg" ==> "video/mpeg"
235 , ".mpg" ==> "video/mpeg"
223 , ".mpg" ==> "video/mpeg"
236 , ".ogg" ==> "application/ogg"
224 , ".ogg" ==> "application/ogg"
225+ , ".otf" ==> "font/otf"
237 , ".pac" ==> "application/x-ns-proxy-autoconfig"
226 , ".pac" ==> "application/x-ns-proxy-autoconfig"
238 , ".pdf" ==> "application/pdf"
227 , ".pdf" ==> "application/pdf"
239 , ".png" ==> "image/png"
228 , ".png" ==> "image/png"
240 , ".qt" ==> "video/quicktime"
229 , ".qt" ==> "video/quicktime"
230+ , ".sfnt" ==> "font/sfnt"
241 , ".sig" ==> "application/pgp-signature"
231 , ".sig" ==> "application/pgp-signature"
242 , ".spl" ==> "application/futuresplash"
232 , ".spl" ==> "application/futuresplash"
243 , ".svg" ==> "image/svg+xml"
233 , ".svg" ==> "image/svg+xml"
@@ -248,16 +238,19 @@ mimeTypeDict =
248 , ".tbz" ==> "application/x-bzip-compressed-tar"
238 , ".tbz" ==> "application/x-bzip-compressed-tar"
249 , ".text" ==> "text/plain"
239 , ".text" ==> "text/plain"
250 , ".tgz" ==> "application/x-tgz"
240 , ".tgz" ==> "application/x-tgz"
251− , ".ttf" ==> "application/x-font-truetype"
241+ , ".ttf" ==> "font/ttf"
252 , ".txt" ==> "text/plain"
242 , ".txt" ==> "text/plain"
253 , ".wav" ==> "audio/x-wav"
243 , ".wav" ==> "audio/x-wav"
254 , ".wax" ==> "audio/x-ms-wax"
244 , ".wax" ==> "audio/x-ms-wax"
245+ , ".webm" ==> "video/webm"
246+ , ".webp" ==> "image/webp"
255 , ".wma" ==> "audio/x-ms-wma"
247 , ".wma" ==> "audio/x-ms-wma"
256 , ".wmv" ==> "video/x-ms-wmv"
248 , ".wmv" ==> "video/x-ms-wmv"
249+ , ".woff" ==> "font/woff"
250+ , ".woff2" ==> "font/woff2"
257 , ".xbm" ==> "image/x-xbitmap"
251 , ".xbm" ==> "image/x-xbitmap"
258 , ".xml" ==> "text/xml"
252 , ".xml" ==> "text/xml"
259 , ".xpm" ==> "image/x-xpixmap"
253 , ".xpm" ==> "image/x-xpixmap"
260 , ".xwd" ==> "image/x-xwindowdump"
254 , ".xwd" ==> "image/x-xwindowdump"
261 , ".zip" ==> "application/zip"
255 , ".zip" ==> "application/zip"
262 ]
256 ]
263−
terminal/src/Develop/Generate/Index.hs+149−74
@@ -1,36 +1,37 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Develop.Generate.Index
3module Develop.Generate.Index
4− ( get
4+ ( generate
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
11import qualified Data.Map as Map
12import qualified Data.Map as Map
12−import qualified Data.Text as Text
13−import qualified Data.Text.IO as Text
14import qualified System.Directory as Dir
13import qualified System.Directory as Dir
15import System.FilePath ((</>), splitDirectories, takeExtension)
14import System.FilePath ((</>), splitDirectories, takeExtension)
16
15
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
18import qualified Elm.Package as Pkg
20import qualified Elm.Package as Pkg
19−import qualified Elm.Project.Json as Project
21+import qualified Elm.Version as V
20−import qualified Elm.Project.Summary as Summary
21import qualified Json.Encode as E
22import qualified Json.Encode as E
22−import qualified Reporting.Progress as Progress
23+import Json.Encode ((==>))
23−import qualified Reporting.Task as Task
24+import qualified Reporting
24−import qualified Stuff.Verify as Verify
25+import qualified Stuff
25
26
26
27
27
28
28−-- GET
29+-- GENERATE
29
30
30
31
31−get :: FilePath -> FilePath -> IO B.Builder
32+generate :: FilePath -> IO B.Builder
32−get root pwd =
33+generate pwd =
33− do flags <- getFlags root pwd
34+ do flags <- getFlags pwd
34 return $ Help.makePageHtml "Index" (Just (encode flags))
35 return $ Help.makePageHtml "Index" (Just (encode flags))
35
36
36
37
@@ -43,60 +44,33 @@ data Flags =
43 { _root :: FilePath
44 { _root :: FilePath
44 , _pwd :: [String]
45 , _pwd :: [String]
45 , _dirs :: [FilePath]
46 , _dirs :: [FilePath]
46− , _files :: [(FilePath, Bool)]
47+ , _files :: [File]
47− , _readme :: Maybe Text.Text
48+ , _readme :: Maybe String
48− , _project :: Maybe Project.Project
49+ , _outline :: Maybe Outline.Outline
49− , _exactDeps :: Map.Map Pkg.Name Pkg.Version
50+ , _exactDeps :: Map.Map Pkg.Name V.Version
50 }
51 }
51
52
52
53
53−
54+data File =
54−-- JSON
55+ File
55−
56+ { _path :: FilePath
56−
57+ , _runnable :: Bool
57−encode :: Flags -> E.Value
58+ }
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− ]
81
59
82
60
83
61
84-- GET FLAGS
62-- GET FLAGS
85
63
86
64
87−getFlags :: FilePath -> FilePath -> IO Flags
65+getFlags :: FilePath -> IO Flags
88−getFlags root pwd =
66+getFlags pwd =
89− do (dirs, files) <- getDirsAndFiles pwd
67+ do contents <- Dir.getDirectoryContents pwd
68+ root <- Dir.getCurrentDirectory
69+ dirs <- getDirs pwd contents
70+ files <- getFiles pwd contents
90 readme <- getReadme pwd
71 readme <- getReadme pwd
91− exists <- Dir.doesFileExist (root </> "elm.json")
72+ outline <- getOutline
92−
73+ exactDeps <- getExactDeps outline
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−
100 return $
74 return $
101 Flags
75 Flags
102 { _root = root
76 { _root = root
@@ -104,35 +78,136 @@ getFlags root pwd =
104 , _dirs = dirs
78 , _dirs = dirs
105 , _files = files
79 , _files = files
106 , _readme = readme
80 , _readme = readme
107− , _project = fmap Summary._project maybeSummary
81+ , _outline = outline
108− , _exactDeps = maybe Map.empty (Map.map fst . Summary._depsGraph) maybeSummary
82+ , _exactDeps = exactDeps
109 }
83 }
110
84
111
85
112−getReadme :: FilePath -> IO (Maybe Text.Text)
86+
87+-- README
88+
89+
90+getReadme :: FilePath -> IO (Maybe String)
113getReadme dir =
91getReadme dir =
114 do let readmePath = dir </> "README.md"
92 do let readmePath = dir </> "README.md"
115 exists <- Dir.doesFileExist readmePath
93 exists <- Dir.doesFileExist readmePath
116 if exists
94 if exists
117− then Just <$> Text.readFile readmePath
95+ then Just <$> readFile readmePath
118 else return Nothing
96 else return Nothing
119
97
120
98
121−getDirsAndFiles :: FilePath -> IO ([FilePath], [(FilePath, Bool)])
122−getDirsAndFiles pwd =
123− do contents <- Dir.getDirectoryContents pwd
124− dirs <- filterM (Dir.doesDirectoryExist . (pwd </>)) contents
125− filePaths <- filterM (Dir.doesFileExist . (pwd </>)) contents
126− files <- mapM (inspectFile pwd) filePaths
127− return (dirs, files)
128
99
100+-- GET DIRECTORIES
129
101
130−inspectFile :: FilePath -> FilePath -> IO (FilePath, Bool)
131−inspectFile pwd path =
132− if takeExtension path == ".elm" then
133− do source <- Text.readFile (pwd </> path)
134− let hasMain = Text.isInfixOf "\nmain " source
135− return (path, hasMain)
136
102
103+getDirs :: FilePath -> [FilePath] -> IO [FilePath]
104+getDirs pwd contents =
105+ 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
115+ mapM (toFile pwd) paths
116+
117+
118+toFile :: FilePath -> FilePath -> IO File
119+toFile pwd path =
120+ if takeExtension path == ".elm" then
121+ do source <- readFile (pwd </> path)
122+ let hasMain = List.isInfixOf "\nmain " source
123+ return (File path hasMain)
137 else
124 else
138− return (path, False)
125+ return (File path False)
126+
127+
128+
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
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+1−7
@@ -36,7 +36,6 @@ 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")
40 , elmPath ==> (elm , "application/javascript")
39 , elmPath ==> (elm , "application/javascript")
41 , cssPath ==> (css , "text/css")
40 , cssPath ==> (css , "text/css")
42 , codeFontPath ==> (codeFont, "font/ttf")
41 , codeFontPath ==> (codeFont, "font/ttf")
@@ -89,7 +88,7 @@ sansFontPath =
89
88
90elm :: BS.ByteString
89elm :: BS.ByteString
91elm =
90elm =
92− $(bsToExp =<< runIO Build.compile)
91+ $(bsToExp =<< runIO Build.buildReactorFrontEnd)
93
92
94
93
95
94
@@ -122,8 +121,3 @@ sansFont =
122favicon :: BS.ByteString
121favicon :: BS.ByteString
123favicon =
122favicon =
124 $(bsToExp =<< runIO (Build.readAsset "favicon.ico"))
123 $(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+46−29
@@ -1,19 +1,25 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Develop.StaticFiles.Build
2module Develop.StaticFiles.Build
3 ( readAsset
3 ( readAsset
4− , compile
4+ , buildReactorFrontEnd
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
10import qualified System.Directory as Dir
13import qualified System.Directory as Dir
11import System.FilePath ((</>))
14import System.FilePath ((</>))
12
15
13−import qualified Elm.Project as Project
16+import qualified BackgroundWriter as BW
14−import qualified Generate.Output as Output
17+import qualified Build
18+import qualified Elm.Details as Details
19+import qualified Generate
20+import qualified Reporting
21+import qualified Reporting.Exit as Exit
15import qualified Reporting.Task as Task
22import qualified Reporting.Task as Task
16−import qualified Reporting.Progress.Terminal as Terminal
17
23
18
24
19
25
@@ -26,31 +32,42 @@ readAsset path =
26
32
27
33
28
34
29−-- COMPILE
35+-- BUILD REACTOR ELM
30
36
31
37
32−compile :: IO BS.ByteString
38+buildReactorFrontEnd :: IO BS.ByteString
33−compile =
39+buildReactorFrontEnd =
40+ BW.withScope $ \scope ->
34 Dir.withCurrentDirectory "reactor" $
41 Dir.withCurrentDirectory "reactor" $
35− do reporter <- Terminal.create
42+ do root <- Dir.getCurrentDirectory
36− Task.run reporter $
43+ runTaskUnsafe $
37− do summary <- Project.getRoot
44+ do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root
38− let jsOutput = Just (Output.JavaScript Nothing tempFileName)
45+ artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details paths
39− Project.compile Output.Prod Output.Client jsOutput summary rootPaths
46+ javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.prod root details artifacts
40−
47+ return (LBS.toStrict (B.toLazyByteString javascript))
41− result <- BS.readFile tempFileName
48+
42− seq (BS.length result) (Dir.removeFile tempFileName)
49+
43− return result
50+paths :: NE.List FilePath
44−
51+paths =
45−
52+ NE.List
46−tempFileName :: FilePath
53+ ("src" </> "NotFound.elm")
47−tempFileName =
54+ [ "src" </> "Errors.elm"
48− "elm.js"
55+ , "src" </> "Index.elm"
49−
56+ ]
50−
57+
51−rootPaths :: [FilePath]
58+
52−rootPaths =
59+runTaskUnsafe :: Task.Task Exit.Reactor a -> IO a
53− [ "src" </> "Errors.elm"
60+runTaskUnsafe task =
54− , "src" </> "Index.elm"
61+ do result <- Task.run task
55− , "src" </> "NotFound.elm"
62+ case result of
56− ]
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+348−6
@@ -1,17 +1,359 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Diff (run) where
2+{-# LANGUAGE OverloadedStrings #-}
3+module Diff
4+ ( Args(..)
5+ , run
6+ )
7+ where
3
8
4
9
5−import qualified Elm.Diff as Diff
10+import qualified Data.List as List
11+import qualified Data.Map as Map
12+import qualified Data.Maybe as Maybe
13+import qualified Data.Name as Name
14+import qualified Data.NonEmptyList as NE
15+
16+import qualified BackgroundWriter as BW
17+import qualified Build
18+import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..))
19+import qualified Deps.Diff as DD
20+import qualified Deps.Registry as Registry
21+import qualified Elm.Compiler.Type as Type
22+import qualified Elm.Details as Details
23+import qualified Elm.Docs as Docs
24+import qualified Elm.Magnitude as M
25+import qualified Elm.Outline as Outline
26+import qualified Elm.Package as Pkg
27+import qualified Elm.Version as V
28+import qualified Http
29+import qualified Reporting
30+import Reporting.Doc ((<>), (<+>))
31+import qualified Reporting.Doc as D
32+import qualified Reporting.Exit as Exit
33+import qualified Reporting.Exit.Help as Help
34+import qualified Reporting.Render.Type.Localizer as L
6import qualified Reporting.Task as Task
35import qualified Reporting.Task as Task
7−import qualified Reporting.Progress.Terminal as Terminal
36+import qualified Stuff
8
37
9
38
10
39
11-- RUN
40-- RUN
12
41
13
42
14−run :: Diff.Args -> () -> IO ()
43+data Args
44+ = CodeVsLatest
45+ | CodeVsExactly V.Version
46+ | LocalInquiry V.Version V.Version
47+ | GlobalInquiry Pkg.Name V.Version V.Version
48+
49+
50+run :: Args -> () -> IO ()
15run args () =
51run args () =
16− do reporter <- Terminal.create
52+ Reporting.attempt Exit.diffToReport $
17− Task.run reporter $ Diff.diff args
53+ Task.run $
54+ do env <- getEnv
55+ diff env args
56+
57+
58+
59+-- ENVIRONMENT
60+
61+
62+data Env =
63+ Env
64+ { _maybeRoot :: Maybe FilePath
65+ , _cache :: Stuff.PackageCache
66+ , _manager :: Http.Manager
67+ , _registry :: Registry.Registry
68+ }
69+
70+
71+getEnv :: Task Env
72+getEnv =
73+ do maybeRoot <- Task.io $ Stuff.findRoot
74+ cache <- Task.io $ Stuff.getPackageCache
75+ manager <- Task.io $ Http.getManager
76+ registry <- Task.eio Exit.DiffMustHaveLatestRegistry $ Registry.latest manager cache
77+ return (Env maybeRoot cache manager registry)
78+
79+
80+
81+-- DIFF
82+
83+
84+type Task a =
85+ Task.Task Exit.Diff a
86+
87+
88+diff :: Env -> Args -> Task ()
89+diff env@(Env _ _ _ registry) args =
90+ case args of
91+ GlobalInquiry name v1 v2 ->
92+ case Registry.getVersions' name registry of
93+ Right vsns ->
94+ do oldDocs <- getDocs env name vsns (min v1 v2)
95+ newDocs <- getDocs env name vsns (max v1 v2)
96+ writeDiff oldDocs newDocs
97+
98+ Left suggestions ->
99+ Task.throw $ Exit.DiffUnknownPackage name suggestions
100+
101+ LocalInquiry v1 v2 ->
102+ do (name, vsns) <- readOutline env
103+ oldDocs <- getDocs env name vsns (min v1 v2)
104+ newDocs <- getDocs env name vsns (max v1 v2)
105+ writeDiff oldDocs newDocs
106+
107+ CodeVsLatest ->
108+ do (name, vsns) <- readOutline env
109+ oldDocs <- getLatestDocs env name vsns
110+ newDocs <- generateDocs env
111+ writeDiff oldDocs newDocs
112+
113+ CodeVsExactly version ->
114+ do (name, vsns) <- readOutline env
115+ oldDocs <- getDocs env name vsns version
116+ newDocs <- generateDocs env
117+ writeDiff oldDocs newDocs
118+
119+
120+
121+-- GET DOCS
122+
123+
124+getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation
125+getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version =
126+ if latest == version || elem version previous
127+ then Task.eio (Exit.DiffDocsProblem version) $ DD.getDocs cache manager name version
128+ else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous)
129+
130+
131+getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation
132+getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) =
133+ Task.eio (Exit.DiffDocsProblem latest) $ DD.getDocs cache manager name latest
134+
135+
136+
137+-- READ OUTLINE
138+
139+
140+readOutline :: Env -> Task (Pkg.Name, Registry.KnownVersions)
141+readOutline (Env maybeRoot _ _ registry) =
142+ case maybeRoot of
143+ Nothing ->
144+ Task.throw $ Exit.DiffNoOutline
145+
146+ Just root ->
147+ do result <- Task.io $ Outline.read root
148+ case result of
149+ Left err ->
150+ Task.throw $ Exit.DiffBadOutline err
151+
152+ Right outline ->
153+ case outline of
154+ Outline.App _ ->
155+ Task.throw $ Exit.DiffApplication
156+
157+ Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) ->
158+ case Registry.getVersions pkg registry of
159+ Just vsns -> return (pkg, vsns)
160+ Nothing -> Task.throw Exit.DiffUnpublished
161+
162+
163+
164+-- GENERATE DOCS
165+
166+
167+generateDocs :: Env -> Task Docs.Documentation
168+generateDocs (Env maybeRoot _ _ _) =
169+ case maybeRoot of
170+ Nothing ->
171+ Task.throw $ Exit.DiffNoOutline
172+
173+ Just root ->
174+ do details <-
175+ Task.eio Exit.DiffBadDetails $ BW.withScope $ \scope ->
176+ Details.load Reporting.silent scope root
177+
178+ case Details._outline details of
179+ Details.ValidApp _ ->
180+ Task.throw $ Exit.DiffApplication
181+
182+ Details.ValidPkg _ exposed _ ->
183+ case exposed of
184+ [] ->
185+ Task.throw $ Exit.DiffNoExposed
186+
187+ e:es ->
188+ Task.eio Exit.DiffBadBuild $
189+ Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)
190+
191+
192+
193+-- WRITE DIFF
194+
195+
196+writeDiff :: Docs.Documentation -> Docs.Documentation -> Task ()
197+writeDiff oldDocs newDocs =
198+ let
199+ changes = DD.diff oldDocs newDocs
200+ localizer = L.fromNames (Map.union oldDocs newDocs)
201+ in
202+ Task.io $ Help.toStdout $ toDoc localizer changes <> "\n"
203+
204+
205+
206+-- TO DOC
207+
208+
209+toDoc :: L.Localizer -> PackageChanges -> D.Doc
210+toDoc localizer changes@(PackageChanges added changed removed) =
211+ if null added && Map.null changed && null removed then
212+ "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
213+ else
214+ let
215+ magDoc =
216+ D.fromChars (M.toChars (DD.toMagnitude changes))
217+
218+ header =
219+ "This is a" <+> D.green magDoc <+> "change."
220+
221+ addedChunk =
222+ if null added then [] else
223+ [ Chunk "ADDED MODULES" M.MINOR $
224+ D.vcat $ map D.fromName added
225+ ]
226+
227+ removedChunk =
228+ if null removed then [] else
229+ [ Chunk "REMOVED MODULES" M.MAJOR $
230+ D.vcat $ map D.fromName removed
231+ ]
232+
233+ chunks =
234+ addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
235+ in
236+ D.vcat (header : "" : map chunkToDoc chunks)
237+
238+
239+data Chunk =
240+ Chunk
241+ { _title :: String
242+ , _magnitude :: M.Magnitude
243+ , _details :: D.Doc
244+ }
245+
246+
247+chunkToDoc :: Chunk -> D.Doc
248+chunkToDoc (Chunk title magnitude details) =
249+ let
250+ header =
251+ "----" <+> D.fromChars title <+> "-" <+> D.fromChars (M.toChars magnitude) <+> "----"
252+ in
253+ D.vcat
254+ [ D.dullcyan header
255+ , ""
256+ , D.indent 4 details
257+ , ""
258+ , ""
259+ ]
260+
261+
262+changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
263+changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
264+ let
265+ magnitude =
266+ DD.moduleChangeMagnitude changes
267+
268+ (unionAdd, unionChange, unionRemove) =
269+ changesToDocTriple (unionToDoc localizer) unions
270+
271+ (aliasAdd, aliasChange, aliasRemove) =
272+ changesToDocTriple (aliasToDoc localizer) aliases
273+
274+ (valueAdd, valueChange, valueRemove) =
275+ changesToDocTriple (valueToDoc localizer) values
276+
277+ (binopAdd, binopChange, binopRemove) =
278+ changesToDocTriple (binopToDoc localizer) binops
279+ in
280+ Chunk (Name.toChars name) magnitude $
281+ D.vcat $ List.intersperse "" $ Maybe.catMaybes $
282+ [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
283+ , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
284+ , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
285+ ]
286+
287+
288+changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
289+changesToDocTriple entryToDoc (Changes added changed removed) =
290+ let
291+ indented (name, value) =
292+ D.indent 4 (entryToDoc name value)
293+
294+ diffed (name, (oldValue, newValue)) =
295+ D.vcat
296+ [ " - " <> entryToDoc name oldValue
297+ , " + " <> entryToDoc name newValue
298+ , ""
299+ ]
300+ in
301+ ( map indented (Map.toList added)
302+ , map diffed (Map.toList changed)
303+ , map indented (Map.toList removed)
304+ )
305+
306+
307+changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
308+changesToDoc categoryName unions aliases values binops =
309+ if null unions && null aliases && null values && null binops then
310+ Nothing
311+
312+ else
313+ Just $ D.vcat $
314+ D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
315+
316+
317+unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
318+unionToDoc localizer name (Docs.Union _ tvars ctors) =
319+ let
320+ setup =
321+ "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
322+
323+ ctorDoc (ctor, tipes) =
324+ typeDoc localizer (Type.Type ctor tipes)
325+ in
326+ D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
327+
328+
329+aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
330+aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
331+ let
332+ declaration =
333+ "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
334+ in
335+ D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
336+
337+
338+valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
339+valueToDoc localizer name (Docs.Value _ tipe) =
340+ D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
341+
342+
343+binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
344+binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
345+ "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
346+ where
347+ details =
348+ " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
349+
350+ assoc =
351+ case associativity of
352+ Docs.Left -> "left"
353+ Docs.Non -> "non"
354+ Docs.Right -> "right"
355+
356+
357+typeDoc :: L.Localizer -> Type.Type -> D.Doc
358+typeDoc localizer tipe =
359+ Type.toDoc localizer Type.None tipe
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 "src" []) directs indirects Map.empty Map.empty
93+ Outline.AppOutline V.compiler (NE.List (Outline.RelativeSrcDir "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+16−31
@@ -10,6 +10,7 @@ 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
13import qualified Deps.Solver as Solver
14import qualified Deps.Solver as Solver
14import qualified Deps.Registry as Registry
15import qualified Deps.Registry as Registry
15import qualified Elm.Constraint as C
16import qualified Elm.Constraint as C
@@ -40,7 +41,7 @@ run args () =
40 do maybeRoot <- Stuff.findRoot
41 do maybeRoot <- Stuff.findRoot
41 case maybeRoot of
42 case maybeRoot of
42 Nothing ->
43 Nothing ->
43− return (Left Exit.InstallNoProject)
44+ return (Left Exit.InstallNoOutline)
44
45
45 Just root ->
46 Just root ->
46 case args of
47 case args of
@@ -50,8 +51,8 @@ run args () =
50
51
51 Install pkg ->
52 Install pkg ->
52 Task.run $
53 Task.run $
53− do env <- getEnv
54+ do env <- Task.eio Exit.InstallBadRegistry $ Solver.initEnv
54− oldOutline <- getOutline root
55+ oldOutline <- Task.eio Exit.InstallBadOutline $ Outline.read root
55 case oldOutline of
56 case oldOutline of
56 Outline.App outline ->
57 Outline.App outline ->
57 do changes <- makeAppPlan env pkg outline
58 do changes <- makeAppPlan env pkg outline
@@ -63,23 +64,6 @@ run args () =
63
64
64
65
65
66
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−
83-- ATTEMPT CHANGES
67-- ATTEMPT CHANGES
84
68
85
69
@@ -140,12 +124,13 @@ attemptChanges root env oldOutline toChars changes =
140
124
141attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
125attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
142attemptChangesHelp root env oldOutline newOutline question =
126attemptChangesHelp root env oldOutline newOutline question =
143− Task.eio Exit.InstallHasBadDetails $
127+ Task.eio Exit.InstallBadDetails $
128+ BW.withScope $ \scope ->
144 do approved <- Reporting.ask question
129 do approved <- Reporting.ask question
145 if approved
130 if approved
146 then
131 then
147 do Outline.write root newOutline
132 do Outline.write root newOutline
148− result <- Details.verifyInstall root env newOutline
133+ result <- Details.verifyInstall scope root env newOutline
149 case result of
134 case result of
150 Left exit ->
135 Left exit ->
151 do Outline.write root oldOutline
136 do Outline.write root oldOutline
@@ -203,8 +188,8 @@ makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOut
203 case Registry.getVersions' pkg registry of
188 case Registry.getVersions' pkg registry of
204 Left suggestions ->
189 Left suggestions ->
205 case connection of
190 case connection of
206− Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline suggestions)
191+ Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
207− Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline suggestions)
192+ Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)
208
193
209 Right _ ->
194 Right _ ->
210 do result <- Task.io $ Solver.addToApp cache connection registry pkg outline
195 do result <- Task.io $ Solver.addToApp cache connection registry pkg outline
@@ -213,10 +198,10 @@ makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOut
213 return (Changes (detectChanges old new) (Outline.App app))
198 return (Changes (detectChanges old new) (Outline.App app))
214
199
215 Solver.NoSolution ->
200 Solver.NoSolution ->
216− Task.throw Exit.InstallNoOnlineSolution
201+ Task.throw (Exit.InstallNoOnlineAppSolution pkg)
217
202
218 Solver.NoOfflineSolution ->
203 Solver.NoOfflineSolution ->
219− Task.throw Exit.InstallNoOfflineSolution
204+ Task.throw (Exit.InstallNoOfflineAppSolution pkg)
220
205
221 Solver.Err exit ->
206 Solver.Err exit ->
222 Task.throw (Exit.InstallHadSolverTrouble exit)
207 Task.throw (Exit.InstallHadSolverTrouble exit)
@@ -245,8 +230,8 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOut
245 case Registry.getVersions' pkg registry of
230 case Registry.getVersions' pkg registry of
246 Left suggestions ->
231 Left suggestions ->
247 case connection of
232 case connection of
248− Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline suggestions)
233+ Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
249− Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline suggestions)
234+ Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)
250
235
251 Right (Registry.KnownVersions _ _) ->
236 Right (Registry.KnownVersions _ _) ->
252 do let old = Map.union deps test
237 do let old = Map.union deps test
@@ -269,10 +254,10 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOut
269 }
254 }
270
255
271 Solver.NoSolution ->
256 Solver.NoSolution ->
272− Task.throw Exit.InstallNoOnlineSolution
257+ Task.throw (Exit.InstallNoOnlinePkgSolution pkg)
273
258
274 Solver.NoOfflineSolution ->
259 Solver.NoOfflineSolution ->
275− Task.throw Exit.InstallNoOfflineSolution
260+ Task.throw (Exit.InstallNoOfflinePkgSolution pkg)
276
261
277 Solver.Err exit ->
262 Solver.Err exit ->
278 Task.throw (Exit.InstallHadSolverTrouble exit)
263 Task.throw (Exit.InstallHadSolverTrouble exit)
@@ -400,7 +385,7 @@ viewRemove toChars (Widths nameWidth leftWidth _) name old =
400
385
401viewName :: Int -> Pkg.Name -> D.Doc
386viewName :: Int -> Pkg.Name -> D.Doc
402viewName width name =
387viewName width name =
403− D.fill (width + 3) (D.fromUtf8 (Pkg.toString name))
388+ D.fill (width + 3) (D.fromPackage name)
404
389
405
390
406pad :: Int -> String -> D.Doc
391pad :: Int -> String -> D.Doc
terminal/src/Main.hs+32−36
@@ -6,17 +6,14 @@ module Main
6
6
7
7
8import Prelude hiding (init)
8import Prelude hiding (init)
9−import GHC.IO.Encoding (setLocaleEncoding, utf8)
10import qualified Data.List as List
9import qualified Data.List as List
11import qualified Text.PrettyPrint.ANSI.Leijen as P
10import qualified Text.PrettyPrint.ANSI.Leijen as P
12import Text.PrettyPrint.ANSI.Leijen ((<>))
11import Text.PrettyPrint.ANSI.Leijen ((<>))
13import Text.Read (readMaybe)
12import Text.Read (readMaybe)
14
13
15−import qualified Elm.Diff as Diff
16import qualified Elm.Version as V
14import 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
20
17
21import qualified Bump
18import qualified Bump
22import qualified Develop
19import qualified Develop
@@ -34,17 +31,16 @@ import qualified Repl
34
31
35main :: IO ()
32main :: IO ()
36main =
33main =
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− ]
48
44
49
45
50intro :: P.Doc
46intro :: P.Doc
@@ -76,7 +72,7 @@ outro =
76-- INIT
72-- INIT
77
73
78
74
79−init :: Interface
75+init :: Terminal.Command
80init =
76init =
81 let
77 let
82 summary =
78 summary =
@@ -91,14 +87,14 @@ init =
91 "It will ask permission to create an elm.json file, the one thing common\
87 "It will ask permission to create an elm.json file, the one thing common\
92 \ to all Elm projects. It also provides a link explaining what to do from there."
88 \ to all Elm projects. It also provides a link explaining what to do from there."
93 in
89 in
94− Interface "init" (Common summary) details example noArgs noFlags Init.run
90+ Terminal.Command "init" (Common summary) details example noArgs noFlags Init.run
95
91
96
92
97
93
98-- REPL
94-- REPL
99
95
100
96
101−repl :: Interface
97+repl :: Terminal.Command
102repl =
98repl =
103 let
99 let
104 summary =
100 summary =
@@ -119,7 +115,7 @@ repl =
119 |-- flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs."
115 |-- flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs."
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."
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."
121 in
117 in
122− Interface "repl" (Common summary) details example noArgs replFlags Repl.run
118+ Terminal.Command "repl" (Common summary) details example noArgs replFlags Repl.run
123
119
124
120
125interpreter :: Parser String
121interpreter :: Parser String
@@ -137,7 +133,7 @@ interpreter =
137-- REACTOR
133-- REACTOR
138
134
139
135
140−reactor :: Interface
136+reactor :: Terminal.Command
141reactor =
137reactor =
142 let
138 let
143 summary =
139 summary =
@@ -158,7 +154,7 @@ reactor =
158 flags Develop.Flags
154 flags Develop.Flags
159 |-- flag "port" port_ "The port of the server (default: 8000)"
155 |-- flag "port" port_ "The port of the server (default: 8000)"
160 in
156 in
161− Interface "reactor" (Common summary) details example noArgs reactorFlags Develop.run
157+ Terminal.Command "reactor" (Common summary) details example noArgs reactorFlags Develop.run
162
158
163
159
164port_ :: Parser Int
160port_ :: Parser Int
@@ -176,7 +172,7 @@ port_ =
176-- MAKE
172-- MAKE
177
173
178
174
179−make :: Interface
175+make :: Terminal.Command
180make =
176make =
181 let
177 let
182 details =
178 details =
@@ -188,26 +184,26 @@ make =
188 "For example:"
184 "For example:"
189 , P.indent 4 $ P.green "elm make src/Main.elm"
185 , P.indent 4 $ P.green "elm make src/Main.elm"
190 , reflow
186 , reflow
191− "This tries to compile an Elm file named src/Main.elm, putting the resulting\
187+ "This tries to compile an Elm file named src/Main.elm, generating an index.html\
192− \ JavaScript code in an elm.js file."
188+ \ file if possible."
193 ]
189 ]
194
190
195 makeFlags =
191 makeFlags =
196 flags Make.Flags
192 flags Make.Flags
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!"
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!"
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."
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."
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!"
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!"
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!"
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!"
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."
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."
202 in
198 in
203− Interface "make" Uncommon details example (zeroOrMore elmFile) makeFlags Make.run
199+ Terminal.Command "make" Uncommon details example (zeroOrMore elmFile) makeFlags Make.run
204
200
205
201
206
202
207-- INSTALL
203-- INSTALL
208
204
209
205
210−install :: Interface
206+install :: Terminal.Command
211install =
207install =
212 let
208 let
213 details =
209 details =
@@ -236,14 +232,14 @@ install =
236 , require1 Install.Install package
232 , require1 Install.Install package
237 ]
233 ]
238 in
234 in
239− Interface "install" Uncommon details example installArgs noFlags Install.run
235+ Terminal.Command "install" Uncommon details example installArgs noFlags Install.run
240
236
241
237
242
238
243-- PUBLISH
239-- PUBLISH
244
240
245
241
246−publish :: Interface
242+publish :: Terminal.Command
247publish =
243publish =
248 let
244 let
249 details =
245 details =
@@ -270,17 +266,17 @@ publish =
270 \ it ends up as an experiment on GitHub only. Point is, try to be\
266 \ it ends up as an experiment on GitHub only. Point is, try to be\
271 \ respectful of the community and package ecosystem!"
267 \ respectful of the community and package ecosystem!"
272 , reflow
268 , reflow
273− "Check out <TODO> for guidance on how to create great packages!"
269+ "Check out <https://package.elm-lang.org/help/design-guidelines> for guidance on how to create great packages!"
274 ]
270 ]
275 in
271 in
276− Interface "publish" Uncommon details example noArgs noFlags Publish.run
272+ Terminal.Command "publish" Uncommon details example noArgs noFlags Publish.run
277
273
278
274
279
275
280-- BUMP
276-- BUMP
281
277
282
278
283−bump :: Interface
279+bump :: Terminal.Command
284bump =
280bump =
285 let
281 let
286 details =
282 details =
@@ -293,14 +289,14 @@ bump =
293 \ it is a MAJOR change, and bump your version number to 2.0.0. I do this with\
289 \ it is a MAJOR change, and bump your version number to 2.0.0. I do this with\
294 \ all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!"
290 \ all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!"
295 in
291 in
296− Interface "bump" Uncommon details example noArgs noFlags Bump.run
292+ Terminal.Command "bump" Uncommon details example noArgs noFlags Bump.run
297
293
298
294
299
295
300-- DIFF
296-- DIFF
301
297
302
298
303−diff :: Interface
299+diff :: Terminal.Command
304diff =
300diff =
305 let
301 let
306 details =
302 details =
@@ -325,7 +321,7 @@ diff =
325 , require3 Diff.GlobalInquiry package version version
321 , require3 Diff.GlobalInquiry package version version
326 ]
322 ]
327 in
323 in
328− Interface "diff" Uncommon details example diffArgs noFlags Diff.run
324+ Terminal.Command "diff" Uncommon details example diffArgs noFlags Diff.run
329
325
330
326
331
327
terminal/src/Make.hs+113−268
@@ -1,4 +1,4 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
2module Make
2module Make
3 ( Flags(..)
3 ( Flags(..)
4 , Output(..)
4 , Output(..)
@@ -6,36 +6,30 @@ module Make
6 , run
6 , run
7 , reportType
7 , reportType
8 , output
8 , output
9+ , docsFile
9 )
10 )
10 where
11 where
11
12
12
13
13−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
14−import Control.Monad (liftM2)
15import qualified Data.ByteString.Builder as B
14import qualified Data.ByteString.Builder as B
16−import qualified Data.Map as Map
17import qualified Data.Maybe as Maybe
15import qualified Data.Maybe as Maybe
18import qualified Data.NonEmptyList as NE
16import qualified Data.NonEmptyList as NE
17+import qualified System.Directory as Dir
19import qualified System.FilePath as FP
18import qualified System.FilePath as FP
20
19
21import qualified AST.Optimized as Opt
20import 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
24import qualified Elm.Details as Details
23import qualified Elm.Details as Details
25−import qualified Elm.Interface as I
26import qualified Elm.ModuleName as ModuleName
24import qualified Elm.ModuleName as ModuleName
27−import qualified Elm.Outline as Outline
28−import qualified Elm.Package as Pkg
29import qualified File
25import qualified File
26+import qualified Generate
30import qualified Generate.Html as Html
27import 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
34import qualified Reporting
28import qualified Reporting
35import qualified Reporting.Exit as Exit
29import qualified Reporting.Exit as Exit
36import qualified Reporting.Task as Task
30import qualified Reporting.Task as Task
37import qualified Stuff
31import qualified Stuff
38−import Terminal.Args (Parser(..))
32+import Terminal (Parser(..))
39
33
40
34
41
35
@@ -48,6 +42,7 @@ data Flags =
48 , _optimize :: Bool
42 , _optimize :: Bool
49 , _output :: Maybe Output
43 , _output :: Maybe Output
50 , _report :: Maybe ReportType
44 , _report :: Maybe ReportType
45+ , _docs :: Maybe FilePath
51 }
46 }
52
47
53
48
@@ -69,54 +64,58 @@ type Task a = Task.Task Exit.Make a
69
64
70
65
71run :: [FilePath] -> Flags -> IO ()
66run :: [FilePath] -> Flags -> IO ()
72−run paths (Flags debug optimize maybeOutput report) =
67+run paths flags@(Flags _ _ _ report _) =
73 do style <- getStyle report
68 do style <- getStyle report
74− Reporting.attemptWithStyle style Exit.makeToReport $ Task.run $
69+ maybeRoot <- Stuff.findRoot
75− do root <- getRoot
70+ Reporting.attemptWithStyle style Exit.makeToReport $
76− desiredMode <- getMode debug optimize
71+ case maybeRoot of
77− details <- getDetails style root
72+ Just root -> runHelp root paths style flags
78− case paths of
73+ Nothing -> return $ Left $ Exit.MakeNoOutline
79− [] ->
74+
80− do exposed <- getExposed details
75+
81− _ <- buildExposed style root details exposed
76+runHelp :: FilePath -> [FilePath] -> Reporting.Style -> Flags -> IO (Either Exit.Make ())
82− return ()
77+runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) =
83−
78+ BW.withScope $ \scope ->
84− p:ps ->
79+ Stuff.withRootLock root $ Task.run $
85− do artifacts <- buildPaths style root details (NE.List p ps)
80+ do desiredMode <- getMode debug optimize
86− case maybeOutput of
81+ details <- Task.eio Exit.MakeBadDetails (Details.load style scope root)
87− Nothing ->
82+ case paths of
88− case getMains artifacts of
83+ [] ->
89− [] ->
84+ do exposed <- getExposed details
90− return ()
85+ buildExposed style root details maybeDocs exposed
91−
86+
92− [name] ->
87+ p:ps ->
93− do builder <- toBuilder root details desiredMode artifacts
88+ do artifacts <- buildPaths style root details (NE.List p ps)
94− generate style "index.html" (Html.sandwich name builder) (NE.List name [])
89+ case maybeOutput of
95−
90+ Nothing ->
96− name:names ->
91+ case getMains artifacts of
97− do builder <- toBuilder root details desiredMode artifacts
92+ [] ->
98− generate style "elm.js" builder (NE.List name names)
93+ return ()
99−
94+
100− Just DevNull ->
95+ [name] ->
101− return ()
96+ do builder <- toBuilder root details desiredMode artifacts
102−
97+ generate style "index.html" (Html.sandwich name builder) (NE.List name [])
103− Just (JS target) ->
98+
104− case getNoMains artifacts of
99+ name:names ->
105− [] ->
100+ do builder <- toBuilder root details desiredMode artifacts
106− do builder <- toBuilder root details desiredMode artifacts
101+ generate style "elm.js" builder (NE.List name names)
107− generate style target builder (getMainNames artifacts)
102+
108−
103+ Just DevNull ->
109− name:names ->
104+ return ()
110− Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
105+
111−
106+ Just (JS target) ->
112− Just (Html target) ->
107+ case getNoMains artifacts of
113− case hasOneMain artifacts of
108+ [] ->
114− Just name ->
109+ do builder <- toBuilder root details desiredMode artifacts
115− do builder <- toBuilder root details desiredMode artifacts
110+ generate style target builder (Build.getRootNames artifacts)
116− generate style target (Html.sandwich name builder) (NE.List name [])
111+
117−
112+ name:names ->
118− Nothing ->
113+ Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
119− Task.throw Exit.MakeMultipleFilesIntoHtml
114+
115+ Just (Html target) ->
116+ do name <- hasOneMain artifacts
117+ builder <- toBuilder root details desiredMode artifacts
118+ generate style target (Html.sandwich name builder) (NE.List name [])
120
119
121
120
122
121
@@ -130,14 +129,6 @@ getStyle report =
130 Just Json -> return Reporting.json
129 Just Json -> return Reporting.json
131
130
132
131
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−
141getMode :: Bool -> Bool -> Task DesiredMode
132getMode :: Bool -> Bool -> Task DesiredMode
142getMode debug optimize =
133getMode debug optimize =
143 case (debug, optimize) of
134 case (debug, optimize) of
@@ -147,19 +138,14 @@ getMode debug optimize =
147 (False, True ) -> return Prod
138 (False, True ) -> return Prod
148
139
149
140
150−getDetails :: Reporting.Style -> FilePath -> Task Details.Details
151−getDetails style root =
152− Task.eio Exit.MakeBlockedByDetailsProblem (Details.load style root)
153−
154−
155getExposed :: Details.Details -> Task (NE.List ModuleName.Raw)
141getExposed :: Details.Details -> Task (NE.List ModuleName.Raw)
156−getExposed (Details.Details _ validOutline _ _ _) =
142+getExposed (Details.Details _ validOutline _ _ _ _) =
157 case validOutline of
143 case validOutline of
158 Details.ValidApp _ ->
144 Details.ValidApp _ ->
159 Task.throw Exit.MakeAppNeedsFileNames
145 Task.throw Exit.MakeAppNeedsFileNames
160
146
161− Details.ValidPkg (Outline.PkgOutline _ _ _ _ exposed _ _ _) _ ->
147+ Details.ValidPkg _ exposed _ ->
162− case Outline.flattenExposed exposed of
148+ case exposed of
163 [] -> Task.throw Exit.MakePkgNeedsExposing
149 [] -> Task.throw Exit.MakePkgNeedsExposing
164 m:ms -> return (NE.List m ms)
150 m:ms -> return (NE.List m ms)
165
151
@@ -168,16 +154,19 @@ getExposed (Details.Details _ validOutline _ _ _) =
168-- BUILD PROJECTS
154-- BUILD PROJECTS
169
155
170
156
171−buildExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> Task ()
157+buildExposed :: Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.List ModuleName.Raw -> Task ()
172−buildExposed style root details exposed =
158+buildExposed style root details maybeDocs exposed =
159+ let
160+ docsGoal = maybe Build.IgnoreDocs Build.WriteDocs maybeDocs
161+ in
173 Task.eio Exit.MakeCannotBuild $
162 Task.eio Exit.MakeCannotBuild $
174− Build.fromExposed style root details exposed
163+ Build.fromExposed style root details docsGoal exposed
175
164
176
165
177buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts
166buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts
178buildPaths style root details paths =
167buildPaths style root details paths =
179 Task.eio Exit.MakeCannotBuild $
168 Task.eio Exit.MakeCannotBuild $
180− Build.fromMains style root details paths
169+ Build.fromPaths style root details paths
181
170
182
171
183
172
@@ -185,13 +174,13 @@ buildPaths style root details paths =
185
174
186
175
187getMains :: Build.Artifacts -> [ModuleName.Raw]
176getMains :: Build.Artifacts -> [ModuleName.Raw]
188−getMains (Build.Artifacts _ _ mains modules) =
177+getMains (Build.Artifacts _ _ roots modules) =
189− Maybe.mapMaybe (getMain modules) (NE.toList mains)
178+ Maybe.mapMaybe (getMain modules) (NE.toList roots)
190
179
191
180
192−getMain :: [Build.Module] -> Build.Main -> Maybe ModuleName.Raw
181+getMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw
193−getMain modules main =
182+getMain modules root =
194− case main of
183+ case root of
195 Build.Inside name ->
184 Build.Inside name ->
196 if any (isMain name) modules
185 if any (isMain name) modules
197 then Just name
186 then Just name
@@ -217,11 +206,11 @@ isMain targetName modul =
217-- HAS ONE MAIN
206-- HAS ONE MAIN
218
207
219
208
220−hasOneMain :: Build.Artifacts -> Maybe ModuleName.Raw
209+hasOneMain :: Build.Artifacts -> Task ModuleName.Raw
221−hasOneMain (Build.Artifacts _ _ mains modules) =
210+hasOneMain (Build.Artifacts _ _ roots modules) =
222− case mains of
211+ case roots of
223− NE.List main [] -> getMain modules main
212+ NE.List root [] -> Task.mio Exit.MakeNoMain (return $ getMain modules root)
224− NE.List _ (_:_) -> Nothing
213+ NE.List _ (_:_) -> Task.throw Exit.MakeMultipleFilesIntoHtml
225
214
226
215
227
216
@@ -229,13 +218,13 @@ hasOneMain (Build.Artifacts _ _ mains modules) =
229
218
230
219
231getNoMains :: Build.Artifacts -> [ModuleName.Raw]
220getNoMains :: Build.Artifacts -> [ModuleName.Raw]
232−getNoMains (Build.Artifacts _ _ mains modules) =
221+getNoMains (Build.Artifacts _ _ roots modules) =
233− Maybe.mapMaybe (getNoMain modules) (NE.toList mains)
222+ Maybe.mapMaybe (getNoMain modules) (NE.toList roots)
234
223
235
224
236−getNoMain :: [Build.Module] -> Build.Main -> Maybe ModuleName.Raw
225+getNoMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw
237−getNoMain modules main =
226+getNoMain modules root =
238− case main of
227+ case root of
239 Build.Inside name ->
228 Build.Inside name ->
240 if any (isMain name) modules
229 if any (isMain name) modules
241 then Nothing
230 then Nothing
@@ -248,29 +237,14 @@ getNoMain modules main =
248
237
249
238
250
239
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−
267-- GENERATE
240-- GENERATE
268
241
269
242
270generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task ()
243generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task ()
271generate style target builder names =
244generate style target builder names =
272 Task.io $
245 Task.io $
273− do File.writeBuilder target builder
246+ do Dir.createDirectoryIfMissing True (FP.takeDirectory target)
247+ File.writeBuilder target builder
274 Reporting.reportGenerate style names target
248 Reporting.reportGenerate style names target
275
249
276
250
@@ -282,150 +256,12 @@ data DesiredMode = Debug | Dev | Prod
282
256
283
257
284toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
258toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
285−toBuilder root details desiredMode (Build.Artifacts pkg ifaces roots modules) =
259+toBuilder root details desiredMode artifacts =
286− case desiredMode of
260+ Task.mapError Exit.MakeBadGenerate $
287− Debug ->
261+ case desiredMode of
288− do loading <- loadObjects root details modules
262+ Debug -> Generate.debug root details artifacts
289− types <- loadTypes root ifaces modules
263+ Dev -> Generate.dev root details artifacts
290− objects <- finalizeObjects loading
264+ Prod -> Generate.prod root details artifacts
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
429
265
430
266
431
267
@@ -450,25 +286,34 @@ output =
450 , _plural = "output files"
286 , _plural = "output files"
451 , _parser = parseOutput
287 , _parser = parseOutput
452 , _suggest = \_ -> return []
288 , _suggest = \_ -> return []
453− , _examples = exampleOutput
289+ , _examples = \_ -> return [ "elm.js", "index.html", "/dev/null" ]
454 }
290 }
455
291
456
292
457parseOutput :: String -> Maybe Output
293parseOutput :: String -> Maybe Output
458−parseOutput string =
294+parseOutput name
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+
461
300
462− else if FP.takeExtension string == ".html" && length string > 5 then
301+docsFile :: Parser FilePath
463− Just (Html string)
302+docsFile =
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+ }
464
310
465− else if FP.takeExtension string == ".js" && length string > 3 then
466− Just (JS string)
467
311
468− else
312+hasExt :: String -> String -> Bool
469− Nothing
313+hasExt ext path =
314+ FP.takeExtension path == ext && length path > length ext
470
315
471
316
472−exampleOutput :: String -> IO [String]
317+isDevNull :: String -> Bool
473−exampleOutput _ =
318+isDevNull name =
474− return [ "elm.js", "index.html", "/dev/null" ]
319+ name == "/dev/null" || name == "NUL" || name == "$null"
terminal/src/Publish.hs+529−8
@@ -1,19 +1,540 @@
1−module Publish (run) where
1+{-# LANGUAGE OverloadedStrings #-}
2+module Publish
3+ ( run
4+ )
5+ where
2
6
3
7
4−import qualified Elm.Project as Project
8+import Control.Exception (bracket_)
5−import qualified Elm.Publish as Publish
9+import Control.Monad (void)
10+import qualified Data.List as List
11+import qualified Data.NonEmptyList as NE
12+import qualified Data.Utf8 as Utf8
13+import qualified System.Directory as Dir
14+import qualified System.Exit as Exit
15+import System.FilePath ((</>))
16+import qualified System.Info as Info
17+import qualified System.IO as IO
18+import qualified System.Process as Process
19+
20+import qualified BackgroundWriter as BW
21+import qualified Build
22+import qualified Deps.Bump as Bump
23+import qualified Deps.Diff as Diff
24+import qualified Deps.Registry as Registry
25+import qualified Deps.Website as Website
26+import qualified Elm.Details as Details
27+import qualified Elm.Docs as Docs
28+import qualified Elm.Magnitude as M
29+import qualified Elm.Outline as Outline
30+import qualified Elm.Package as Pkg
31+import qualified Elm.Version as V
32+import qualified File
33+import qualified Http
34+import qualified Json.Decode as D
35+import qualified Json.String as Json
36+import qualified Reporting
37+import Reporting.Doc ((<+>))
38+import qualified Reporting.Doc as D
39+import qualified Reporting.Exit as Exit
40+import qualified Reporting.Exit.Help as Help
6import qualified Reporting.Task as Task
41import qualified Reporting.Task as Task
7−import qualified Reporting.Progress.Terminal as Terminal
42+import qualified Stuff
8
43
9
44
10
45
11-- RUN
46-- RUN
12
47
13
48
49+-- TODO mandate no "exposing (..)" in packages to make
50+-- optimization to skip builds in Elm.Details always valid
51+
52+
14run :: () -> () -> IO ()
53run :: () -> () -> IO ()
15run () () =
54run () () =
16− do reporter <- Terminal.create
55+ Reporting.attempt Exit.publishToReport $
17− Task.run reporter $
56+ Task.run $ publish =<< getEnv
18− do summary <- Project.getRoot
57+
19− Publish.publish summary
58+
59+
60+-- ENV
61+
62+
63+data Env =
64+ Env
65+ { _root :: FilePath
66+ , _cache :: Stuff.PackageCache
67+ , _manager :: Http.Manager
68+ , _registry :: Registry.Registry
69+ , _outline :: Outline.Outline
70+ }
71+
72+
73+getEnv :: Task.Task Exit.Publish Env
74+getEnv =
75+ do root <- Task.mio Exit.PublishNoOutline $ Stuff.findRoot
76+ cache <- Task.io $ Stuff.getPackageCache
77+ manager <- Task.io $ Http.getManager
78+ registry <- Task.eio Exit.PublishMustHaveLatestRegistry $ Registry.latest manager cache
79+ outline <- Task.eio Exit.PublishBadOutline $ Outline.read root
80+ return $ Env root cache manager registry outline
81+
82+
83+
84+-- PUBLISH
85+
86+
87+publish :: Env -> Task.Task Exit.Publish ()
88+publish env@(Env root _ manager registry outline) =
89+ case outline of
90+ Outline.App _ ->
91+ Task.throw Exit.PublishApplication
92+
93+ Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) ->
94+ do let maybeKnownVersions = Registry.getVersions pkg registry
95+
96+ reportPublishStart pkg vsn maybeKnownVersions
97+
98+ if noExposed exposed then Task.throw Exit.PublishNoExposed else return ()
99+ if badSummary summary then Task.throw Exit.PublishNoSummary else return ()
100+
101+ verifyReadme root
102+ verifyLicense root
103+ docs <- verifyBuild root
104+ verifyVersion env pkg vsn docs maybeKnownVersions
105+ git <- getGit
106+ commitHash <- verifyTag git manager pkg vsn
107+ verifyNoChanges git commitHash vsn
108+ zipHash <- verifyZip env pkg vsn
109+
110+ Task.io $ putStrLn ""
111+ register manager pkg vsn docs commitHash zipHash
112+ Task.io $ putStrLn "Success!"
113+
114+
115+
116+-- VERIFY SUMMARY
117+
118+
119+badSummary :: Json.String -> Bool
120+badSummary summary =
121+ Json.isEmpty summary || Outline.defaultSummary == summary
122+
123+
124+noExposed :: Outline.Exposed -> Bool
125+noExposed exposed =
126+ case exposed of
127+ Outline.ExposedList modules ->
128+ null modules
129+
130+ Outline.ExposedDict chunks ->
131+ all (null . snd) chunks
132+
133+
134+
135+-- VERIFY README
136+
137+
138+verifyReadme :: FilePath -> Task.Task Exit.Publish ()
139+verifyReadme root =
140+ reportReadmeCheck $
141+ do let readmePath = root </> "README.md"
142+ exists <- File.exists readmePath
143+ case exists of
144+ False ->
145+ return (Left Exit.PublishNoReadme)
146+
147+ True ->
148+ do size <- IO.withFile readmePath IO.ReadMode IO.hFileSize
149+ if size < 300
150+ then return (Left Exit.PublishShortReadme)
151+ else return (Right ())
152+
153+
154+
155+-- VERIFY LICENSE
156+
157+
158+verifyLicense :: FilePath -> Task.Task Exit.Publish ()
159+verifyLicense root =
160+ reportLicenseCheck $
161+ do let licensePath = root </> "LICENSE"
162+ exists <- File.exists licensePath
163+ if exists
164+ then return (Right ())
165+ else return (Left Exit.PublishNoLicense)
166+
167+
168+
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
220+
221+
222+verifyTag :: Git -> Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish String
223+verifyTag git manager pkg vsn =
224+ reportTagCheck vsn $
225+ do -- https://stackoverflow.com/questions/1064499/how-to-list-all-git-tags
226+ exitCode <- _run git [ "show", "--name-only", V.toChars vsn, "--" ]
227+ case exitCode of
228+ Exit.ExitFailure _ ->
229+ return $ Left (Exit.PublishMissingTag vsn)
230+
231+ Exit.ExitSuccess ->
232+ let url = toTagUrl pkg vsn in
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+
241+
242+toTagUrl :: Pkg.Name -> V.Version -> String
243+toTagUrl pkg vsn =
244+ "https://api.github.com/repos/" ++ Pkg.toUrl pkg ++ "/git/refs/tags/" ++ V.toChars vsn
245+
246+
247+commitHashDecoder :: D.Decoder e String
248+commitHashDecoder =
249+ Utf8.toChars <$>
250+ D.field "object" (D.field "sha" D.string)
251+
252+
253+
254+-- VERIFY NO LOCAL CHANGES SINCE TAG
255+
256+
257+verifyNoChanges :: Git -> String -> V.Version -> Task.Task Exit.Publish ()
258+verifyNoChanges git commitHash vsn =
259+ reportLocalChangesCheck $
260+ do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
261+ exitCode <- _run git [ "diff-index", "--quiet", commitHash, "--" ]
262+ case exitCode of
263+ Exit.ExitSuccess -> return $ Right ()
264+ Exit.ExitFailure _ -> return $ Left (Exit.PublishLocalChanges vsn)
265+
266+
267+
268+-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
269+
270+
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+
276+ (sha, archive) <-
277+ reportDownloadCheck $
278+ Http.getArchive manager url
279+ Exit.PublishCannotGetZip
280+ (Exit.PublishCannotDecodeZip url)
281+ (return . Right)
282+
283+ Task.io $ File.writePackage prepublishDir archive
284+
285+ reportZipBuildCheck $
286+ Dir.withCurrentDirectory prepublishDir $
287+ verifyZipBuild prepublishDir
288+
289+ return sha
290+
291+
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
298+withPrepublishDir root callback =
299+ let
300+ dir = Stuff.prepublishDir root
301+ in
302+ Task.eio id $
303+ bracket_
304+ (Dir.createDirectoryIfMissing True dir)
305+ (Dir.removeDirectoryRecursive dir)
306+ (Task.run (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+
322+ _ <- Task.eio Exit.PublishZipBuildProblem $
323+ Build.fromExposed Reporting.silent root details Build.KeepDocs exposed
324+
325+ return ()
326+
327+
328+
329+-- VERIFY VERSION
330+
331+
332+data GoodVersion
333+ = GoodStart
334+ | GoodBump V.Version M.Magnitude
335+
336+
337+verifyVersion :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task.Task Exit.Publish ()
338+verifyVersion env pkg vsn newDocs publishedVersions =
339+ reportSemverCheck vsn $
340+ case publishedVersions of
341+ Nothing ->
342+ if vsn == V.one
343+ then return $ Right GoodStart
344+ else return $ Left $ Exit.PublishNotInitialVersion vsn
345+
346+ Just knownVersions@(Registry.KnownVersions latest previous) ->
347+ if vsn == latest || elem vsn previous
348+ then return $ Left $ Exit.PublishAlreadyPublished vsn
349+ else verifyBump env pkg vsn newDocs knownVersions
350+
351+
352+verifyBump :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Registry.KnownVersions -> IO (Either Exit.Publish GoodVersion)
353+verifyBump (Env _ cache manager _ _) pkg vsn newDocs knownVersions@(Registry.KnownVersions latest _) =
354+ case List.find (\(_ ,new, _) -> vsn == new) (Bump.getPossibilities knownVersions) of
355+ Nothing ->
356+ return $ Left $
357+ Exit.PublishInvalidBump vsn latest
358+
359+ Just (old, new, magnitude) ->
360+ do result <- Diff.getDocs cache manager pkg old
361+ case result of
362+ Left dp ->
363+ return $ Left $ Exit.PublishCannotGetDocs old new dp
364+
365+ Right oldDocs ->
366+ let
367+ changes = Diff.diff oldDocs newDocs
368+ realNew = Diff.bump changes old
369+ in
370+ if new == realNew
371+ then return $ Right $ GoodBump old magnitude
372+ else
373+ return $ Left $
374+ Exit.PublishBadBump old new magnitude realNew (Diff.toMagnitude changes)
375+
376+
377+
378+-- REGISTER PACKAGES
379+
380+
381+register :: Http.Manager -> Pkg.Name -> V.Version -> Docs.Documentation -> String -> Http.Sha -> Task.Task Exit.Publish ()
382+register manager pkg vsn docs commitHash sha =
383+ let
384+ url =
385+ Website.route "/register"
386+ [ ("name", Pkg.toChars pkg)
387+ , ("version", V.toChars vsn)
388+ , ("commit-hash", commitHash)
389+ ]
390+ in
391+ Task.eio Exit.PublishCannotRegister $
392+ Http.upload manager url
393+ [ Http.filePart "elm.json" "elm.json"
394+ , Http.jsonPart "docs.json" "docs.json" (Docs.encode docs)
395+ , Http.filePart "README.md" "README.md"
396+ , Http.stringPart "github-hash" (Http.shaToChars sha)
397+ ]
398+
399+
400+
401+-- REPORTING
402+
403+
404+reportPublishStart :: Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> Task.Task x ()
405+reportPublishStart pkg vsn maybeKnownVersions =
406+ Task.io $
407+ case maybeKnownVersions of
408+ Nothing ->
409+ putStrLn $ Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n"
410+
411+ Just _ ->
412+ putStrLn $ "Verifying " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " ...\n"
413+
414+
415+
416+-- REPORTING PHASES
417+
418+
419+reportReadmeCheck :: IO (Either x a) -> Task.Task x a
420+reportReadmeCheck =
421+ reportCheck
422+ "Looking for README.md"
423+ "Found README.md"
424+ "Problem with your README.md"
425+
426+
427+reportLicenseCheck :: IO (Either x a) -> Task.Task x a
428+reportLicenseCheck =
429+ reportCheck
430+ "Looking for LICENSE"
431+ "Found LICENSE"
432+ "Problem with your LICENSE"
433+
434+
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 ()
444+reportSemverCheck version work =
445+ let
446+ vsn = V.toChars version
447+
448+ waiting = "Checking semantic versioning rules. Is " ++ vsn ++ " correct?"
449+ failure = "Version " ++ vsn ++ " is not correct!"
450+ success result =
451+ case result of
452+ GoodStart ->
453+ "All packages start at version " ++ V.toChars V.one
454+
455+ GoodBump oldVersion magnitude ->
456+ "Version number " ++ vsn ++ " verified ("
457+ ++ M.toChars magnitude ++ " change, "
458+ ++ V.toChars oldVersion ++ " => " ++ vsn ++ ")"
459+ in
460+ void $ reportCustomCheck waiting success failure work
461+
462+
463+reportTagCheck :: V.Version -> IO (Either x a) -> Task.Task x a
464+reportTagCheck vsn =
465+ reportCheck
466+ ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?")
467+ ("Version " ++ V.toChars vsn ++ " is tagged on GitHub")
468+ ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!")
469+
470+
471+reportDownloadCheck :: IO (Either x a) -> Task.Task x a
472+reportDownloadCheck =
473+ reportCheck
474+ "Downloading code from GitHub..."
475+ "Code downloaded successfully from GitHub"
476+ "Could not download code from GitHub!"
477+
478+
479+reportLocalChangesCheck :: IO (Either x a) -> Task.Task x a
480+reportLocalChangesCheck =
481+ reportCheck
482+ "Checking for uncommitted changes..."
483+ "No uncommitted changes in local code"
484+ "Your local code is different than the code tagged on GitHub"
485+
486+
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
496+reportCheck waiting success failure work =
497+ reportCustomCheck waiting (\_ -> success) failure work
498+
499+
500+reportCustomCheck :: String -> (a -> String) -> String -> IO (Either x a) -> Task.Task x a
501+reportCustomCheck waiting success failure work =
502+ let
503+ putFlush doc =
504+ Help.toStdout doc >> IO.hFlush IO.stdout
505+
506+ padded message =
507+ message ++ replicate (length waiting - length message) ' '
508+ in
509+ Task.eio id $
510+ do putFlush $ " " <> waitingMark <+> D.fromChars waiting
511+ result <- work
512+ putFlush $
513+ case result of
514+ Right a -> "\r " <> goodMark <+> D.fromChars (padded (success a) ++ "\n")
515+ Left _ -> "\r " <> badMark <+> D.fromChars (padded failure ++ "\n\n")
516+
517+ return result
518+
519+
520+-- MARKS
521+
522+
523+goodMark :: D.Doc
524+goodMark =
525+ D.green $ if isWindows then "+" else "●"
526+
527+
528+badMark :: D.Doc
529+badMark =
530+ D.red $ if isWindows then "X" else "✗"
531+
532+
533+waitingMark :: D.Doc
534+waitingMark =
535+ D.dullyellow $ if isWindows then "-" else "→"
536+
537+
538+isWindows :: Bool
539+isWindows =
540+ Info.os == "mingw32"
terminal/src/Repl.hs+522−197

This diff is too big to show here.

worker/elm.cabal+25−3

This diff is too big to show here.

worker/elm.jsonnew file+26

This diff is too big to show here.

worker/nginx.confnew file+22

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Artifacts.hsnew file+155

This diff is too big to show here.

worker/src/Cors.hsnew file+48

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Errors.elmnew file+217

This diff is too big to show here.

worker/src/Main.hs+36−241

This diff is too big to show here.