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+626−331
@@ -1,12 +1,16 @@
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns #-}
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
@@ -26,25 +29,32 @@ import qualified Data.Maybe as Maybe
26import qualified Data.Name as Name
29import qualified Data.Name as Name
27import qualified Data.NonEmptyList as NE
30import qualified Data.NonEmptyList as NE
28import qualified Data.OneOrMore as OneOrMore
31import qualified Data.OneOrMore as OneOrMore
32+import qualified Data.Set as Set
29import qualified System.Directory as Dir
33import qualified System.Directory as Dir
30import qualified System.FilePath as FP
34import qualified System.FilePath as FP
31import System.FilePath ((</>), (<.>))
35import System.FilePath ((</>), (<.>))
32
36
37+import qualified AST.Canonical as Can
33import qualified AST.Source as Src
38import qualified AST.Source as Src
34import qualified AST.Optimized as Opt
39import qualified AST.Optimized as Opt
35import qualified Compile
40import qualified Compile
36import qualified Elm.Details as Details
41import qualified Elm.Details as Details
42+import qualified Elm.Docs as Docs
37import qualified Elm.Interface as I
43import qualified Elm.Interface as I
38import qualified Elm.ModuleName as ModuleName
44import qualified Elm.ModuleName as ModuleName
39import qualified Elm.Outline as Outline
45import qualified Elm.Outline as Outline
40import qualified Elm.Package as Pkg
46import qualified Elm.Package as Pkg
41import qualified File
47import qualified File
48+import qualified Json.Encode as E
42import qualified Parse.Module as Parse
49import qualified Parse.Module as Parse
43import qualified Reporting
50import qualified Reporting
44import qualified Reporting.Annotation as A
51import qualified Reporting.Annotation as A
52+import qualified Reporting.Error as Error
53+import qualified Reporting.Error.Docs as EDocs
54+import qualified Reporting.Error.Syntax as Syntax
55+import qualified Reporting.Error.Import as Import
45import qualified Reporting.Exit as Exit
56import qualified Reporting.Exit as Exit
46−import qualified Reporting.Problem as Problem
57+import qualified Reporting.Render.Type.Localizer as L
47−import qualified Reporting.Render.Type.Localizer as Localizer
48import qualified Stuff
58import qualified Stuff
49
59
50
60
@@ -56,27 +66,57 @@ data Env =
56 Env
66 Env
57 { _key :: Reporting.BKey
67 { _key :: Reporting.BKey
58 , _root :: FilePath
68 , _root :: FilePath
59− , _pkg :: Pkg.Name
69+ , _project :: Parse.ProjectType
60− , _srcDirs :: [FilePath]
70+ , _srcDirs :: [AbsoluteSrcDir]
71+ , _buildID :: Details.BuildID
61 , _locals :: Map.Map ModuleName.Raw Details.Local
72 , _locals :: Map.Map ModuleName.Raw Details.Local
62 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
73 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
63 }
74 }
64
75
65
76
66−makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
77+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
67−makeEnv key root (Details.Details _ validOutline locals foreigns _) =
78+makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
68 case validOutline of
79 case validOutline of
69− Details.ValidApp (Outline.AppOutline _ srcDirs _ _ _ _) ->
80+ Details.ValidApp givenSrcDirs ->
81+ do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
70− Env key root Pkg.dummyName srcDirs locals foreigns
82+ return $ Env key root Parse.Application srcDirs buildID locals foreigns
71
83
72− Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->
84+ Details.ValidPkg pkg _ _ ->
85+ do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
73− 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
74
110
75
111
76
112
77-- FORK
113-- FORK
78
114
79
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+--
80fork :: IO a -> IO (MVar a)
120fork :: IO a -> IO (MVar a)
81fork work =
121fork work =
82 do mvar <- newEmptyMVar
122 do mvar <- newEmptyMVar
@@ -94,21 +134,22 @@ forkWithKey func dict =
94-- FROM EXPOSED
134-- FROM EXPOSED
95
135
96
136
97−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)
98−fromExposed style root details (NE.List e es) =
138+fromExposed style root details docsGoal exposed@(NE.List e es) =
99 Reporting.trackBuild style $ \key ->
139 Reporting.trackBuild style $ \key ->
100− do let env = makeEnv key root details
140+ do env <- makeEnv key root details
101 dmvar <- Details.loadInterfaces root details
141 dmvar <- Details.loadInterfaces root details
102
142
103 -- crawl
143 -- crawl
104 mvar <- newEmptyMVar
144 mvar <- newEmptyMVar
145+ let docsNeed = toDocsNeed docsGoal
105− roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
146+ roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
106 putMVar mvar roots
147 putMVar mvar roots
107 mapM_ readMVar roots
148 mapM_ readMVar roots
108 statuses <- traverse readMVar =<< readMVar mvar
149 statuses <- traverse readMVar =<< readMVar mvar
109
150
110 -- compile
151 -- compile
111− midpoint <- checkExposedMidpoint dmvar statuses
152+ midpoint <- checkMidpoint dmvar statuses
112 case midpoint of
153 case midpoint of
113 Left problem ->
154 Left problem ->
114 return (Left (Exit.BuildProjectProblem problem))
155 return (Left (Exit.BuildProjectProblem problem))
@@ -119,18 +160,18 @@ fromExposed style root details (NE.List e es) =
119 putMVar rmvar resultMVars
160 putMVar rmvar resultMVars
120 results <- traverse readMVar resultMVars
161 results <- traverse readMVar resultMVars
121 writeDetails root details results
162 writeDetails root details results
122− return (detectProblems results)
163+ finalizeExposed root docsGoal exposed results
123
164
124
165
125
166
126−-- FROM MAINS
167+-- FROM PATHS
127
168
128
169
129data Artifacts =
170data Artifacts =
130 Artifacts
171 Artifacts
131 { _name :: Pkg.Name
172 { _name :: Pkg.Name
132 , _deps :: Dependencies
173 , _deps :: Dependencies
133− , _mains :: NE.List Main
174+ , _roots :: NE.List Root
134 , _modules :: [Module]
175 , _modules :: [Module]
135 }
176 }
136
177
@@ -144,25 +185,25 @@ type Dependencies =
144 Map.Map ModuleName.Canonical I.DependencyInterface
185 Map.Map ModuleName.Canonical I.DependencyInterface
145
186
146
187
147−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)
148−fromMains style root details paths =
189+fromPaths style root details paths =
149 Reporting.trackBuild style $ \key ->
190 Reporting.trackBuild style $ \key ->
150− do let env = makeEnv key root details
191+ do env <- makeEnv key root details
151
192
152− elmains <- findMains env paths
193+ elroots <- findRoots env paths
153− case elmains of
194+ case elroots of
154 Left problem ->
195 Left problem ->
155 return (Left (Exit.BuildProjectProblem problem))
196 return (Left (Exit.BuildProjectProblem problem))
156
197
157− Right lmains ->
198+ Right lroots ->
158 do -- crawl
199 do -- crawl
159 dmvar <- Details.loadInterfaces root details
200 dmvar <- Details.loadInterfaces root details
160 smvar <- newMVar Map.empty
201 smvar <- newMVar Map.empty
161− smainMVars <- traverse (fork . crawlMain env smvar) lmains
202+ srootMVars <- traverse (fork . crawlRoot env smvar) lroots
162− smains <- traverse readMVar smainMVars
203+ sroots <- traverse readMVar srootMVars
163 statuses <- traverse readMVar =<< readMVar smvar
204 statuses <- traverse readMVar =<< readMVar smvar
164
205
165− midpoint <- checkMainsMidpoint dmvar statuses smains
206+ midpoint <- checkMidpointAndRoots dmvar statuses sroots
166 case midpoint of
207 case midpoint of
167 Left problem ->
208 Left problem ->
168 return (Left (Exit.BuildProjectProblem problem))
209 return (Left (Exit.BuildProjectProblem problem))
@@ -172,10 +213,26 @@ fromMains style root details paths =
172 rmvar <- newEmptyMVar
213 rmvar <- newEmptyMVar
173 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
214 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
174 putMVar rmvar resultsMVars
215 putMVar rmvar resultsMVars
175− rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
216+ rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
176 results <- traverse readMVar resultsMVars
217 results <- traverse readMVar resultsMVars
177 writeDetails root details results
218 writeDetails root details results
178− 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
179
236
180
237
181
238
@@ -188,9 +245,9 @@ type StatusDict =
188
245
189data Status
246data Status
190 = SCached Details.Local
247 = SCached Details.Local
191− | SChanged Details.Local B.ByteString Src.Module
248+ | SChanged Details.Local B.ByteString Src.Module DocsNeed
192− | SBadImport Problem.Import
249+ | SBadImport Import.Problem
193− | SBadSyntax Problem.Syntax
250+ | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
194 | SForeign Pkg.Name
251 | SForeign Pkg.Name
195 | SKernel
252 | SKernel
196
253
@@ -205,38 +262,34 @@ crawlDeps env mvar deps blockedValue =
205 mapM_ readMVar statuses
262 mapM_ readMVar statuses
206 return blockedValue
263 return blockedValue
207 where
264 where
208− crawlNew name () = fork (crawlModule env mvar name)
265+ crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
209
266
210
267
211−crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
268+crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
212−crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
269+crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
213 do let fileName = ModuleName.toFilePath name <.> "elm"
270 do let fileName = ModuleName.toFilePath name <.> "elm"
214− let inRoot path = File.exists (root </> path)
215
271
216− paths <- filterM inRoot (map (</> fileName) srcDirs)
272+ paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
217
273
218 case paths of
274 case paths of
219 [path] ->
275 [path] ->
220 case Map.lookup name foreigns of
276 case Map.lookup name foreigns of
221 Just (Details.Foreign dep deps) ->
277 Just (Details.Foreign dep deps) ->
222− return $ SBadImport $ Import.Ambiguous name path [] dep deps
278+ return $ SBadImport $ Import.Ambiguous path [] dep deps
223
279
224 Nothing ->
280 Nothing ->
281+ do newTime <- File.getTime path
225− case Map.lookup name locals of
282+ case Map.lookup name locals of
226− Nothing ->
283+ Nothing ->
227− crawlFile env mvar name path
284+ crawlFile env mvar docsNeed name path newTime buildID
228
285
229− Just local@(Details.Local oldPath oldTime deps _) ->
286+ Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
230− if path /= oldPath
287+ if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
231− then crawlFile env mvar name path
232− else
233− do newTime <- File.getTime path
234− if oldTime < newTime
235− then crawlFile env mvar name path
288+ then crawlFile env mvar docsNeed name path newTime lastChange
236− else crawlDeps env mvar deps (SCached local)
289+ else crawlDeps env mvar deps (SCached local)
237
290
238 p1:p2:ps ->
291 p1:p2:ps ->
239− return $ SBadImport $ Import.AmbiguousLocal name p1 p2 ps
292+ return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
240
293
241 [] ->
294 [] ->
242 case Map.lookup name foreigns of
295 case Map.lookup name foreigns of
@@ -246,44 +299,43 @@ crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
246 return $ SForeign dep
299 return $ SForeign dep
247
300
248 d:ds ->
301 d:ds ->
249− return $ SBadImport $ Import.AmbiguousForeign name dep d ds
302+ return $ SBadImport $ Import.AmbiguousForeign dep d ds
250
303
251 Nothing ->
304 Nothing ->
252− if Name.isKernel name && Pkg.isKernel pkg then
305+ if Name.isKernel name && Parse.isKernel projectType then
253 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
306 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
254− return $ if exists then SKernel else SBadImport (Import.NotFound name)
307+ return $ if exists then SKernel else SBadImport Import.NotFound
255 else
308 else
256− return $ SBadImport (Import.NotFound name)
309+ return $ SBadImport Import.NotFound
310+
257
311
312+crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
313+crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
314+ do source <- File.readUtf8 (root </> path)
258
315
259−crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
316+ case Parse.fromByteString projectType source of
260−crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
317+ Left err ->
261− do time <- File.getTime path
318+ return $ SBadSyntax path time source err
262− source <- File.readUtf8 (root </> path)
263
319
264− case Parse.fromByteString pkg source of
265− Right modul@(Src.Module maybeActualName _ imports values _ _ _ _) ->
320+ Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
266 case maybeActualName of
321 case maybeActualName of
322+ Nothing ->
323+ return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
324+
267− Just actualName ->
325+ Just name@(A.At _ actualName) ->
268 if expectedName == actualName then
326 if expectedName == actualName then
269 let
327 let
270 deps = map Src.getImportName imports
328 deps = map Src.getImportName imports
271− local = Details.Local path time deps (any isMain values)
329+ local = Details.Local path time deps (any isMain values) lastChange buildID
272 in
330 in
273− crawlDeps env mvar deps (SChanged local source modul)
331+ crawlDeps env mvar deps (SChanged local source modul docsNeed)
274 else
332 else
275− return $ SBadSyntax $ Problem.ModuleNameMismatch expectedName actualName
333+ return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
276−
277− Nothing ->
278− return $ SBadSyntax $ Problem.ModuleNameUnspecified expectedName
279−
280− Left syntaxError ->
281− return $ SBadSyntax $ Problem.SyntaxProblem path time syntaxError
282
334
283
335
284isMain :: A.Located Src.Value -> Bool
336isMain :: A.Located Src.Value -> Bool
285isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
337isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
286− name == Name.main
338+ name == Name._main
287
339
288
340
289
341
@@ -295,11 +347,11 @@ type ResultDict =
295
347
296
348
297data Result
349data Result
298− = RNew Details.Local I.Interface Opt.LocalGraph
350+ = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
299− | RSame Details.Local I.Interface Opt.LocalGraph
351+ | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
300− | RCached Bool (MVar CachedInterface)
352+ | RCached Bool Details.BuildID (MVar CachedInterface)
301− | RNotFound Problem.Import
353+ | RNotFound Import.Problem
302− | RProblem Problem.Problem
354+ | RProblem Error.Module
303 | RBlocked
355 | RBlocked
304 | RForeign I.Interface
356 | RForeign I.Interface
305 | RKernel
357 | RKernel
@@ -312,63 +364,68 @@ data CachedInterface
312
364
313
365
314checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
366checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
315−checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
367+checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
316 case status of
368 case status of
317− SCached local@(Details.Local path time deps hasMain) ->
369+ SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
318 do results <- readMVar resultsMVar
370 do results <- readMVar resultsMVar
319− depsStatus <- checkDeps root results deps
371+ depsStatus <- checkDeps root results deps lastCompile
320 case depsStatus of
372 case depsStatus of
321 DepsChange ifaces ->
373 DepsChange ifaces ->
322 do source <- File.readUtf8 path
374 do source <- File.readUtf8 path
323− case Parse.fromByteString pkg source of
375+ case Parse.fromByteString projectType source of
324− Right modul -> compile env local source ifaces modul
376+ Right modul -> compile env (DocsNeed False) local source ifaces modul
325− Left syntaxError ->
377+ Left err ->
326− return $ RProblem $ Problem.BadSyntax $
378+ return $ RProblem $
327− Problem.SyntaxProblem path time syntaxError
379+ Error.Module name path time source (Error.BadSyntax err)
328
380
329 DepsSame _ _ ->
381 DepsSame _ _ ->
330 do mvar <- newMVar Unneeded
382 do mvar <- newMVar Unneeded
331− return (RCached hasMain mvar)
383+ return (RCached hasMain lastChange mvar)
332
384
333 DepsBlock ->
385 DepsBlock ->
334 return RBlocked
386 return RBlocked
335
387
336− DepsNotFound name1 problem1 others ->
388+ DepsNotFound problems ->
337− return (RProblem (Problem.BadImports name1 problem1 others))
389+ do source <- File.readUtf8 path
390+ return $ RProblem $ Error.Module name path time source $
391+ case Parse.fromByteString projectType source of
392+ Right (Src.Module _ _ _ imports _ _ _ _ _) ->
393+ Error.BadImports (toImportErrors env results imports problems)
394+
395+ Left err ->
396+ Error.BadSyntax err
338
397
339− SChanged local@(Details.Local _ _ deps _) source modul ->
398+ SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
340 do results <- readMVar resultsMVar
399 do results <- readMVar resultsMVar
341− depsStatus <- checkDeps root results deps
400+ depsStatus <- checkDeps root results deps lastCompile
342 case depsStatus of
401 case depsStatus of
343 DepsChange ifaces ->
402 DepsChange ifaces ->
344− compile env local source ifaces modul
403+ compile env docsNeed local source ifaces modul
345
404
346 DepsSame same cached ->
405 DepsSame same cached ->
347− do maybeLoaded <- checkCachedInterfaces root cached
406+ do maybeLoaded <- loadInterfaces root same cached
348 case maybeLoaded of
407 case maybeLoaded of
349− Nothing ->
350− return RBlocked
408+ Nothing -> return RBlocked
351−
352− Just loaded ->
353− do let ifaces = Map.union loaded (Map.fromList same)
354− compile env local source ifaces modul
409+ Just ifaces -> compile env docsNeed local source ifaces modul
355
410
356 DepsBlock ->
411 DepsBlock ->
357 return RBlocked
412 return RBlocked
358
413
359− DepsNotFound name1 problem1 others ->
414+ DepsNotFound problems ->
360− return (RProblem (Problem.BadImports name1 problem1 others))
415+ return $ RProblem $ Error.Module name path time source $
416+ Error.BadImports (toImportErrors env results imports problems)
361
417
362 SBadImport importProblem ->
418 SBadImport importProblem ->
363 return (RNotFound importProblem)
419 return (RNotFound importProblem)
364
420
365− SBadSyntax syntaxProblem ->
421+ SBadSyntax path time source err ->
366− return (RProblem (Problem.BadSyntax syntaxProblem))
422+ return $ RProblem $ Error.Module name path time source $
423+ Error.BadSyntax err
367
424
368 SForeign home ->
425 SForeign home ->
369 case foreigns ! ModuleName.Canonical home name of
426 case foreigns ! ModuleName.Canonical home name of
370 I.Public iface -> return (RForeign iface)
427 I.Public iface -> return (RForeign iface)
371− I.Private _ _ _ -> error "loading private interface in Build"
428+ I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
372
429
373 SKernel ->
430 SKernel ->
374 return RKernel
431 return RKernel
@@ -382,69 +439,112 @@ data DepsStatus
382 = DepsChange (Map.Map ModuleName.Raw I.Interface)
439 = DepsChange (Map.Map ModuleName.Raw I.Interface)
383 | DepsSame [Dep] [CDep]
440 | DepsSame [Dep] [CDep]
384 | DepsBlock
441 | DepsBlock
385− | DepsNotFound ModuleName.Raw Problem.Import [(ModuleName.Raw, Problem.Import)]
442+ | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
386
443
387
444
388−checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
445+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
389−checkDeps root results deps =
446+checkDeps root results deps lastCompile =
390− checkDepsHelp root results deps [] [] [] [] False
447+ checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
391
448
392
449
393type Dep = (ModuleName.Raw, I.Interface)
450type Dep = (ModuleName.Raw, I.Interface)
394type CDep = (ModuleName.Raw, MVar CachedInterface)
451type CDep = (ModuleName.Raw, MVar CachedInterface)
395
452
396
453
397−checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw, Problem.Import)] -> Bool -> IO DepsStatus
454+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
398−checkDepsHelp root results deps new same cached badImports isBlocked =
455+checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
399 case deps of
456 case deps of
400 dep:otherDeps ->
457 dep:otherDeps ->
401 do result <- readMVar (results ! dep)
458 do result <- readMVar (results ! dep)
402 case result of
459 case result of
460+ RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
403− RNew _ iface _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached badImports isBlocked
461+ checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
462+
463+ RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
404− RSame _ iface _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached badImports isBlocked
464+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
465+
466+ RCached _ lastChange mvar ->
405− RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) badImports isBlocked
467+ checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
468+
469+ RNotFound prob ->
406− RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : badImports) True
470+ checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
471+
472+ RProblem _ ->
407− RProblem _ -> checkDepsHelp root results otherDeps new same cached badImports True
473+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
474+
475+ RBlocked ->
408− RBlocked -> checkDepsHelp root results otherDeps new same cached badImports True
476+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
477+
478+ RForeign iface ->
409− RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached badImports isBlocked
479+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
480+
481+ RKernel ->
410− RKernel -> checkDepsHelp root results otherDeps new same cached badImports isBlocked
482+ checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
483+
411
484
412 [] ->
485 [] ->
413− case badImports of
486+ case reverse importProblems of
414− (name, problem) : otherBadImports ->
487+ p:ps ->
415− return $ DepsNotFound name problem otherBadImports
488+ return $ DepsNotFound (NE.List p ps)
416
489
417 [] ->
490 [] ->
418 if isBlocked then
491 if isBlocked then
419 return $ DepsBlock
492 return $ DepsBlock
420
493
421− else if null new then
494+ else if null new && lastDepChange <= lastCompile then
422 return $ DepsSame same cached
495 return $ DepsSame same cached
423
496
424 else
497 else
425− do maybeLoaded <- checkCachedInterfaces root cached
498+ do maybeLoaded <- loadInterfaces root same cached
426 case maybeLoaded of
499 case maybeLoaded of
427− Nothing ->
500+ Nothing -> return DepsBlock
428− return DepsBlock
501+ Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
429
502
430− Just loaded ->
431− return $ DepsChange $
432− Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
433
503
434
504
505+-- TO IMPORT ERROR
435
506
436−-- CACHED INTERFACE
437
507
508+toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
509+toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
510+ let
511+ knownModules =
512+ Set.unions
513+ [ Map.keysSet foreigns
514+ , Map.keysSet locals
515+ , Map.keysSet results
516+ ]
438
517
439−checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
518+ unimportedModules =
440−checkCachedInterfaces root deps =
519+ Set.difference knownModules (Set.fromList (map Src.getImportName imports))
441− do loading <- traverse (fork . checkCache root) deps
442− loaded <- traverse readMVar loading
443− return $ Map.fromList <$> sequence loaded
444
520
521+ regionDict =
522+ Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
445
523
446−checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
524+ toError (name, problem) =
525+ Import.Error (regionDict ! name) name unimportedModules problem
526+ in
527+ fmap toError problems
528+
529+
530+
531+-- LOAD CACHED INTERFACES
532+
533+
534+loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
535+loadInterfaces root same cached =
536+ do loading <- traverse (fork . loadInterface root) cached
537+ maybeLoaded <- traverse readMVar loading
538+ case sequence maybeLoaded of
539+ Nothing ->
540+ return Nothing
541+
542+ Just loaded ->
543+ return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
544+
545+
546+loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
447−checkCache root (name, ciMvar) =
547+loadInterface root (name, ciMvar) =
448 do cachedInterface <- takeMVar ciMvar
548 do cachedInterface <- takeMVar ciMvar
449 case cachedInterface of
549 case cachedInterface of
450 Corrupted ->
550 Corrupted ->
@@ -471,8 +571,8 @@ checkCache root (name, ciMvar) =
471-- CHECK PROJECT
571-- CHECK PROJECT
472
572
473
573
474−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)
475−checkExposedMidpoint dmvar statuses =
575+checkMidpoint dmvar statuses =
476 case checkForCycles statuses of
576 case checkForCycles statuses of
477 Nothing ->
577 Nothing ->
478 do maybeForeigns <- readMVar dmvar
578 do maybeForeigns <- readMVar dmvar
@@ -485,11 +585,11 @@ checkExposedMidpoint dmvar statuses =
485 return (Left (Exit.BP_Cycle name names))
585 return (Left (Exit.BP_Cycle name names))
486
586
487
587
488−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)
489−checkMainsMidpoint dmvar statuses smains =
589+checkMidpointAndRoots dmvar statuses sroots =
490 case checkForCycles statuses of
590 case checkForCycles statuses of
491 Nothing ->
591 Nothing ->
492− case checkUniqueMains statuses smains of
592+ case checkUniqueRoots statuses sroots of
493 Nothing ->
593 Nothing ->
494 do maybeForeigns <- readMVar dmvar
594 do maybeForeigns <- readMVar dmvar
495 case maybeForeigns of
595 case maybeForeigns of
@@ -540,25 +640,25 @@ addToGraph name status graph =
540 let
640 let
541 dependencies =
641 dependencies =
542 case status of
642 case status of
543− SCached (Details.Local _ _ deps _) -> deps
643+ SCached (Details.Local _ _ deps _ _ _) -> deps
544− SChanged (Details.Local _ _ deps _) _ _ -> deps
644+ SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
545− SBadImport _ -> []
645+ SBadImport _ -> []
546− SBadSyntax _ -> []
646+ SBadSyntax _ _ _ _ -> []
547− SForeign _ -> []
647+ SForeign _ -> []
548− SKernel -> []
648+ SKernel -> []
549 in
649 in
550 (name, name, dependencies) : graph
650 (name, name, dependencies) : graph
551
651
552
652
553
653
554−-- CHECK UNIQUE MAINS
654+-- CHECK UNIQUE ROOTS
555
655
556
656
557−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
558−checkUniqueMains insides smains =
658+checkUniqueRoots insides sroots =
559 let
659 let
560 outsidesDict =
660 outsidesDict =
561− Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
661+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
562 in
662 in
563 case Map.traverseWithKey checkOutside outsidesDict of
663 case Map.traverseWithKey checkOutside outsidesDict of
564 Left problem ->
664 Left problem ->
@@ -570,61 +670,78 @@ checkUniqueMains insides smains =
570 Left problem -> Just problem
670 Left problem -> Just problem
571
671
572
672
573−mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
673+rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
574−mainStatusToNamePathPair smain =
674+rootStatusToNamePathPair sroot =
575− case smain of
675+ case sroot of
576− SInside _ -> Nothing
676+ SInside _ -> Nothing
577− 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)
578− SOutsideErr _ -> Nothing
678+ SOutsideErr _ -> Nothing
579
679
580
680
581checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
582checkOutside name paths =
682checkOutside name paths =
583 case OneOrMore.destruct NE.List paths of
683 case OneOrMore.destruct NE.List paths of
584 NE.List p [] -> Right p
684 NE.List p [] -> Right p
585− NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
685+ NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
586
686
587
687
588checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
589checkInside name p1 status =
689checkInside name p1 status =
590 case status of
690 case status of
591− SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
691+ SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
592− SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
692+ SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
593− SBadImport _ -> Right ()
693+ SBadImport _ -> Right ()
594− SBadSyntax _ -> Right ()
694+ SBadSyntax _ _ _ _ -> Right ()
595− SForeign _ -> Right ()
695+ SForeign _ -> Right ()
596− SKernel -> Right ()
696+ SKernel -> Right ()
597
697
598
698
599
699
600-- COMPILE MODULE
700-- COMPILE MODULE
601
701
602
702
603−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
604−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
605 case Compile.compile pkg ifaces modul of
708 case Compile.compile pkg ifaces modul of
606 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 ->
607− do let name = Src.getName modul
716+ do let name = Src.getName modul
608− let iface = I.fromModule pkg canonical annotations
717+ let iface = I.fromModule pkg canonical annotations
718+ let elmi = Stuff.elmi root name
609− File.writeBinary (Stuff.elmo root name) objects
719+ File.writeBinary (Stuff.elmo root name) objects
610− maybeOldi <- File.readBinary (Stuff.elmi root name)
720+ maybeOldi <- File.readBinary elmi
611− case maybeOldi of
721+ case maybeOldi of
612− Just oldi | oldi == iface ->
722+ Just oldi | oldi == iface ->
613− do -- iface should be fully forced by equality check
723+ do -- iface should be fully forced by equality check
614− Reporting.report key Reporting.BDone
724+ Reporting.report key Reporting.BDone
725+ let local = Details.Local path time deps main lastChange buildID
615− return (RSame local iface objects)
726+ return (RSame local iface objects docs)
616−
727+
617− _ ->
728+ _ ->
618− do -- iface may be lazy still
729+ do -- iface may be lazy still
619− -- TODO try adding forkIO here
620− File.writeBinary (Stuff.elmi root name) iface
730+ File.writeBinary elmi iface
621− Reporting.report key Reporting.BDone
731+ Reporting.report key Reporting.BDone
732+ let local = Details.Local path time deps main buildID buildID
622− return (RNew local iface objects)
733+ return (RNew local iface objects docs)
623−
734+
624− Left errors ->
735+ Left err ->
625− do Reporting.report key Reporting.BDone
626− return $ RProblem $ Problem.BadContent $
736+ return $ RProblem $
627− Problem.Module (Src.getName modul) path time source errors (Localizer.fromModule modul)
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
628
745
629
746
630
747
@@ -632,46 +749,210 @@ compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifac
632
749
633
750
634writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
635−writeDetails root (Details.Details time outline locals foreigns extras) results =
752+writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
636 File.writeBinary (Stuff.details root) $
753 File.writeBinary (Stuff.details root) $
637− Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
754+ Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
638
755
639
756
640addNewLocal :: 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
641addNewLocal name result locals =
758addNewLocal name result locals =
642 case result of
759 case result of
643− RNew local _ _ -> Map.insert name local locals
760+ RNew local _ _ _ -> Map.insert name local locals
644− RSame local _ _ -> Map.insert name local locals
761+ RSame local _ _ _ -> Map.insert name local locals
645− RCached _ _ -> locals
762+ RCached _ _ _ -> locals
646− RNotFound _ -> locals
763+ RNotFound _ -> locals
647− RProblem _ -> locals
764+ RProblem _ -> locals
648− RBlocked -> locals
765+ RBlocked -> locals
649− RForeign _ -> locals
766+ RForeign _ -> locals
650− RKernel -> locals
767+ RKernel -> locals
768+
769+
770+
771+-- FINALIZE EXPOSED
772+
773+
774+finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
775+finalizeExposed root docsGoal exposed results =
776+ case foldr (addImportProblems results) [] (NE.toList exposed) of
777+ p:ps ->
778+ return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
779+
780+ [] ->
781+ case Map.foldr addErrors [] results of
782+ [] -> Right <$> finalizeDocs docsGoal results
783+ e:es -> return $ Left $ Exit.BuildBadModules root e es
784+
785+
786+addErrors :: Result -> [Error.Module] -> [Error.Module]
787+addErrors result errors =
788+ case result of
789+ RNew _ _ _ _ -> errors
790+ RSame _ _ _ _ -> errors
791+ RCached _ _ _ -> errors
792+ RNotFound _ -> errors
793+ RProblem e -> e:errors
794+ RBlocked -> errors
795+ RForeign _ -> errors
796+ RKernel -> errors
797+
798+
799+addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
800+addImportProblems results name problems =
801+ case results ! name of
802+ RNew _ _ _ _ -> problems
803+ RSame _ _ _ _ -> problems
804+ RCached _ _ _ -> problems
805+ RNotFound p -> (name, p) : problems
806+ RProblem _ -> problems
807+ RBlocked -> problems
808+ RForeign _ -> problems
809+ RKernel -> problems
810+
811+
812+
813+-- DOCS
814+
815+
816+data DocsGoal a where
817+ KeepDocs :: DocsGoal Docs.Documentation
818+ WriteDocs :: FilePath -> DocsGoal ()
819+ IgnoreDocs :: DocsGoal ()
820+
821+
822+newtype DocsNeed =
823+ DocsNeed { needsDocs :: Bool }
824+
825+
826+toDocsNeed :: DocsGoal a -> DocsNeed
827+toDocsNeed goal =
828+ case goal of
829+ IgnoreDocs -> DocsNeed False
830+ WriteDocs _ -> DocsNeed True
831+ KeepDocs -> DocsNeed True
651
832
652
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+
653
843
654−-- DETECT PROBLEMS
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
655
849
850+ WriteDocs path ->
851+ E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
656
852
657−detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
853+ IgnoreDocs ->
658−detectProblems results =
854+ return ()
659− case Map.foldr addProblem [] results of
660− [] -> Right ()
661− p:ps -> Left (Exit.BuildModuleProblems p ps)
662
855
663
856
664−addProblem :: Result -> [Problem.Problem] -> [Problem.Problem]
857+toDocs :: Result -> Maybe Docs.Module
665−addProblem result problems =
858+toDocs result =
666 case result of
859 case result of
667− RNew _ _ _ -> problems
860+ RNew _ _ _ d -> d
668− RSame _ _ _ -> problems
861+ RSame _ _ _ d -> d
669− RCached _ _ -> problems
862+ RCached _ _ _ -> Nothing
670− RNotFound _ -> problems
863+ RNotFound _ -> Nothing
671− RProblem p -> p:problems
864+ RProblem _ -> Nothing
672− RBlocked -> problems
865+ RBlocked -> Nothing
673− RForeign _ -> problems
866+ RForeign _ -> Nothing
674− RKernel -> problems
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
675
956
676
957
677
958
@@ -683,25 +964,25 @@ addProblem result problems =
683
964
684
965
685
966
686−-- FIND MAIN
967+-- FIND ROOT
687
968
688
969
689−data MainLocation
970+data RootLocation
690 = LInside ModuleName.Raw
971 = LInside ModuleName.Raw
691 | LOutside FilePath
972 | LOutside FilePath
692
973
693
974
694−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))
695−findMains env paths =
976+findRoots env paths =
696− do mvars <- traverse (fork . findLocation env) paths
977+ do mvars <- traverse (fork . getRootInfo env) paths
697− elocs <- traverse readMVar mvars
978+ einfos <- traverse readMVar mvars
698− return $ checkLocations =<< sequence elocs
979+ return $ checkRoots =<< sequence einfos
699
980
700
981
701−checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
982+checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
702−checkLocations locations =
983+checkRoots infos =
703 let
984 let
704− toOneOrMore loc@(Location absolute _ _) =
985+ toOneOrMore loc@(RootInfo absolute _ _) =
705 (absolute, OneOrMore.one loc)
986 (absolute, OneOrMore.one loc)
706
987
707 fromOneOrMore loc locs =
988 fromOneOrMore loc locs =
@@ -709,70 +990,83 @@ checkLocations locations =
709 [] -> Right ()
990 [] -> Right ()
710 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
711 in
992 in
712− fmap (\_ -> fmap _location locations) $
993+ fmap (\_ -> fmap _location infos) $
713 traverse (OneOrMore.destruct fromOneOrMore) $
994 traverse (OneOrMore.destruct fromOneOrMore) $
714− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
995+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
715
996
716
997
717
998
718−-- LOCATIONS
999+-- ROOT INFO
719
1000
720
1001
721−data Location =
1002+data RootInfo =
722− Location
1003+ RootInfo
723 { _absolute :: FilePath
1004 { _absolute :: FilePath
724 , _relative :: FilePath
1005 , _relative :: FilePath
725− , _location :: MainLocation
1006+ , _location :: RootLocation
726 }
1007 }
727
1008
728
1009
729−findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
1010+getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
730−findLocation env path =
1011+getRootInfo env path =
731 do exists <- File.exists path
1012 do exists <- File.exists path
732 if exists
1013 if exists
733− then isInsideSrcDirs env path <$> Dir.canonicalizePath path
1014+ then getRootInfoHelp env path =<< Dir.canonicalizePath path
734 else return (Left (Exit.BP_PathUnknown path))
1015 else return (Left (Exit.BP_PathUnknown path))
735
1016
736
1017
737−isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
1018+getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
738−isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
1019+getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
739 let
1020 let
740 (dirs, file) = FP.splitFileName absolutePath
1021 (dirs, file) = FP.splitFileName absolutePath
741− (final, ext) = break (=='.') file
1022+ (final, ext) = FP.splitExtension file
742 in
1023 in
743 if ext /= ".elm"
1024 if ext /= ".elm"
1025+ then
744− then Left (Exit.BP_WithBadExtension path)
1026+ return $ Left $ Exit.BP_WithBadExtension path
745 else
1027 else
746 let
1028 let
747− roots = FP.splitDirectories root
748− segments = FP.splitDirectories dirs ++ [final]
1029+ absoluteSegments = FP.splitDirectories dirs ++ [final]
749 in
1030 in
750− case dropPrefix roots segments of
1031+ case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
751− Nothing ->
1032+ [] ->
752− Right (Location absolutePath path (LOutside path))
1033+ return $ Right $ RootInfo absolutePath path (LOutside path)
753−
1034+
754− Just relativeSegments ->
1035+ [(_, Right names)] ->
755− let
1036+ do let name = Name.fromChars (List.intercalate "." names)
756− (exits, maybes) =
1037+ matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
757− Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
1038+ case matchingDirs of
758− in
1039+ d1:d2:_ ->
759− case (exits, Maybe.catMaybes maybes) of
1040+ do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
1041+ let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1042+ return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1043+
1044+ _ ->
760− (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
1045+ return $ Right $ RootInfo absolutePath path (LInside name)
761− ([], []) -> Right (Location absolutePath path (LOutside path))
1046+
1047+ [(s, Left names)] ->
1048+ return $ Left $ Exit.BP_RootNameInvalid path s names
1049+
1050+ (s1,_):(s2,_):_ ->
762− (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
1051+ return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
763− (exit:_, _) -> Left exit
1052+
764−
1053+
765−
1054+
766−isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
1055+isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
767−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) =
768 case dropPrefix (FP.splitDirectories srcDir) segments of
1062 case dropPrefix (FP.splitDirectories srcDir) segments of
769 Nothing ->
1063 Nothing ->
770− Right Nothing
1064+ Nothing
771
1065
772 Just names ->
1066 Just names ->
773 if all isGoodName names
1067 if all isGoodName names
774− then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
1068+ then Just (srcDir, Right names)
775− else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
1069+ else Just (srcDir, Left names)
776
1070
777
1071
778isGoodName :: [Char] -> Bool
1072isGoodName :: [Char] -> Bool
@@ -785,6 +1079,8 @@ isGoodName name =
785 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
786
1080
787
1081
1082+-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083+--
788dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
789dropPrefix roots paths =
1085dropPrefix roots paths =
790 case roots of
1086 case roots of
@@ -793,153 +1089,152 @@ dropPrefix roots paths =
793
1089
794 r:rs ->
1090 r:rs ->
795 case paths of
1091 case paths of
796− [] -> Nothing
1092+ [] -> Nothing
797 p:ps -> if r == p then dropPrefix rs ps else Nothing
1093 p:ps -> if r == p then dropPrefix rs ps else Nothing
798
1094
799
1095
800
1096
801−-- CRAWL MAINS
1097+-- CRAWL ROOTS
802
1098
803
1099
804−data MainStatus
1100+data RootStatus
805 = SInside ModuleName.Raw
1101 = SInside ModuleName.Raw
806 | SOutsideOk Details.Local B.ByteString Src.Module
1102 | SOutsideOk Details.Local B.ByteString Src.Module
807− | SOutsideErr Problem.Syntax
1103+ | SOutsideErr Error.Module
808
1104
809
1105
810−crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1106+crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
811−crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1107+crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
812− case given of
1108+ case root of
813 LInside name ->
1109 LInside name ->
814 do statusMVar <- newEmptyMVar
1110 do statusMVar <- newEmptyMVar
815 statusDict <- takeMVar mvar
1111 statusDict <- takeMVar mvar
816 putMVar mvar (Map.insert name statusMVar statusDict)
1112 putMVar mvar (Map.insert name statusMVar statusDict)
817− putMVar statusMVar =<< crawlModule env mvar name
1113+ putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
818 return (SInside name)
1114 return (SInside name)
819
1115
820 LOutside path ->
1116 LOutside path ->
821 do time <- File.getTime path
1117 do time <- File.getTime path
822 source <- File.readUtf8 path
1118 source <- File.readUtf8 path
823− case Parse.fromByteString pkg source of
1119+ case Parse.fromByteString projectType source of
824− Right modul@(Src.Module _ _ imports values _ _ _ _) ->
1120+ Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
825 do let deps = map Src.getImportName imports
1121 do let deps = map Src.getImportName imports
826− let local = Details.Local path time deps (any isMain values)
1122+ let local = Details.Local path time deps (any isMain values) buildID buildID
827 crawlDeps env mvar deps (SOutsideOk local source modul)
1123 crawlDeps env mvar deps (SOutsideOk local source modul)
828
1124
829 Left syntaxError ->
1125 Left syntaxError ->
830− return (SOutsideErr (Problem.SyntaxProblem path time syntaxError))
1126+ return $ SOutsideErr $
1127+ Error.Module "???" path time source (Error.BadSyntax syntaxError)
831
1128
832
1129
833
1130
834−-- CHECK MAINS
1131+-- CHECK ROOTS
835
1132
836
1133
837−data MainResult
1134+data RootResult
838 = RInside ModuleName.Raw
1135 = RInside ModuleName.Raw
839 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
840− | ROutsideErr Problem.Problem
1137+ | ROutsideErr Error.Module
841 | ROutsideBlocked
1138 | ROutsideBlocked
842
1139
843
1140
844−checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1141+checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
845−checkMain env@(Env _ root _ _ _ _) results pendingMain =
1142+checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
846− case pendingMain of
1143+ case rootStatus of
847 SInside name ->
1144 SInside name ->
848 return (RInside name)
1145 return (RInside name)
849
1146
850− SOutsideErr syntaxProblem ->
1147+ SOutsideErr err ->
851− return (ROutsideErr (Problem.BadSyntax syntaxProblem))
1148+ return (ROutsideErr err)
852
1149
853− SOutsideOk local@(Details.Local _ _ deps _) source modul ->
1150+ SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
854− do depsStatus <- checkDeps root results deps
1151+ do depsStatus <- checkDeps root results deps lastCompile
855 case depsStatus of
1152 case depsStatus of
856 DepsChange ifaces ->
1153 DepsChange ifaces ->
857− return $ compileOutside env local source ifaces modul
1154+ compileOutside env local source ifaces modul
858
1155
859 DepsSame same cached ->
1156 DepsSame same cached ->
860− do maybeLoaded <- checkCachedInterfaces root cached
1157+ do maybeLoaded <- loadInterfaces root same cached
861 case maybeLoaded of
1158 case maybeLoaded of
862− Nothing ->
863− return ROutsideBlocked
1159+ Nothing -> return ROutsideBlocked
864−
865− Just loaded ->
866− do let ifaces = Map.union loaded (Map.fromList same)
867− return $ compileOutside env local source ifaces modul
1160+ Just ifaces -> compileOutside env local source ifaces modul
868
1161
869 DepsBlock ->
1162 DepsBlock ->
870 return ROutsideBlocked
1163 return ROutsideBlocked
871
1164
872− DepsNotFound name1 problem1 others ->
1165+ DepsNotFound problems ->
873− return (ROutsideErr (Problem.BadImports name1 problem1 others))
1166+ return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1167+ Error.BadImports (toImportErrors env results imports problems)
874
1168
875
1169
876−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
877−compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1171+compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
878 let
1172 let
1173+ pkg = projectTypeToPkg projectType
879 name = Src.getName modul
1174 name = Src.getName modul
880 in
1175 in
881 case Compile.compile pkg ifaces modul of
1176 case Compile.compile pkg ifaces modul of
882 Right (Compile.Artifacts canonical annotations objects) ->
1177 Right (Compile.Artifacts canonical annotations objects) ->
1178+ do Reporting.report key Reporting.BDone
883− ROutsideOk name (I.fromModule pkg canonical annotations) objects
1179+ return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
884
1180
885 Left errors ->
1181 Left errors ->
886− ROutsideErr $ Problem.BadContent $
887− Problem.Module name path time source errors (Localizer.fromModule modul)
1182+ return $ ROutsideErr $ Error.Module name path time source errors
888
1183
889
1184
890
1185
891-- TO ARTIFACTS
1186-- TO ARTIFACTS
892
1187
893
1188
894−data Main
1189+data Root
895 = Inside ModuleName.Raw
1190 = Inside ModuleName.Raw
896 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
897
1192
898
1193
899−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
900−toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1195+toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
901− case gatherProblemsOrMains results mainResults of
1196+ case gatherProblemsOrMains results rootResults of
902− Left (NE.List p ps) ->
1197+ Left (NE.List e es) ->
903− Left (Exit.BuildModuleProblems p ps)
1198+ Left (Exit.BuildBadModules root e es)
904
1199
905− Right mains ->
1200+ Right roots ->
906− Right $ Artifacts pkg foreigns mains $
1201+ Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
907− Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1202+ Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
908
1203
909
1204
910−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Problem.Problem) (NE.List Main)
1205+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
911−gatherProblemsOrMains results (NE.List mainResult mainResults) =
1206+gatherProblemsOrMains results (NE.List rootResult rootResults) =
912 let
1207 let
913− sortMain result (ps, mains) =
1208+ addResult result (es, roots) =
914 case result of
1209 case result of
915− RInside n -> ( ps, Inside n : mains)
1210+ RInside n -> ( es, Inside n : roots)
916− ROutsideOk n i o -> ( ps, Outside n i o : mains)
1211+ ROutsideOk n i o -> ( es, Outside n i o : roots)
917− ROutsideErr p -> (p:ps, mains)
1212+ ROutsideErr e -> (e:es, roots)
918− ROutsideBlocked -> ( ps, mains)
1213+ ROutsideBlocked -> ( es, roots)
919
1214
920− problems = Map.foldr addProblem [] results
1215+ errors = Map.foldr addErrors [] results
921 in
1216 in
922− case (mainResult, foldr sortMain (problems, []) mainResults) of
1217+ case (rootResult, foldr addResult (errors, []) rootResults) of
923 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
924− (RInside _ , (p:ps, _ )) -> Left (NE.List p ps)
1219+ (RInside _ , (e:es, _ )) -> Left (NE.List e es)
925 (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)
926− (ROutsideOk _ _ _, (p:ps, _ )) -> Left (NE.List p ps)
1221+ (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
927− (ROutsideErr p , ( ps, _ )) -> Left (NE.List p ps)
1222+ (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
928 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1223 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
929− (ROutsideBlocked , (p:ps, _ )) -> Left (NE.List p ps)
1224+ (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
930
1225
931
1226
932addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1227addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
933addInside name result modules =
1228addInside name result modules =
934 case result of
1229 case result of
935− RNew _ iface objs -> Fresh name iface objs : modules
1230+ RNew _ iface objs _ -> Fresh name iface objs : modules
936− RSame _ iface objs -> Fresh name iface objs : modules
1231+ RSame _ iface objs _ -> Fresh name iface objs : modules
937− RCached main mvar -> Cached name main mvar : modules
1232+ RCached main _ mvar -> Cached name main mvar : modules
938− RNotFound _ -> error (badInside name)
1233+ RNotFound _ -> error (badInside name)
939− RProblem _ -> error (badInside name)
1234+ RProblem _ -> error (badInside name)
940− RBlocked -> error (badInside name)
1235+ RBlocked -> error (badInside name)
941− RForeign _ -> modules
1236+ RForeign _ -> modules
942− RKernel -> modules
1237+ RKernel -> modules
943
1238
944
1239
945badInside :: ModuleName.Raw -> [Char]
1240badInside :: ModuleName.Raw -> [Char]
@@ -947,9 +1242,9 @@ badInside name =
947 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1242 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
948
1243
949
1244
950−addOutside :: MainResult -> [Module] -> [Module]
1245+addOutside :: RootResult -> [Module] -> [Module]
951−addOutside main modules =
1246+addOutside root modules =
952− case main of
1247+ case root of
953 RInside _ -> modules
1248 RInside _ -> modules
954 ROutsideOk name iface objs -> Fresh name iface objs : modules
1249 ROutsideOk name iface objs -> Fresh name iface objs : modules
955 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+35−68
@@ -16,11 +16,8 @@ module Deps.Registry
16import Prelude hiding (read)
16import Prelude hiding (read)
17import Control.Monad (liftM2)
17import Control.Monad (liftM2)
18import Data.Binary (Binary, get, put)
18import Data.Binary (Binary, get, put)
19−import Data.Function (on)
20import qualified Data.List as List
19import qualified Data.List as List
21import qualified Data.Map.Strict as Map
20import qualified Data.Map.Strict as Map
22−import qualified Data.Name as Name
23−import qualified Data.Utf8 as Utf8
24
21
25import qualified Deps.Website as Website
22import qualified Deps.Website as Website
26import qualified Elm.Package as Pkg
23import qualified Elm.Package as Pkg
@@ -28,8 +25,8 @@ import qualified Elm.Version as V
28import qualified File
25import qualified File
29import qualified Http
26import qualified Http
30import qualified Json.Decode as D
27import qualified Json.Decode as D
28+import qualified Parse.Primitives as P
31import qualified Reporting.Exit as Exit
29import qualified Reporting.Exit as Exit
32−import qualified Reporting.Suggest as Suggest
33import qualified Stuff
30import qualified Stuff
34
31
35
32
@@ -57,11 +54,7 @@ data KnownVersions =
57
54
58read :: Stuff.PackageCache -> IO (Maybe Registry)
55read :: Stuff.PackageCache -> IO (Maybe Registry)
59read cache =
56read cache =
60− do let path = Stuff.registry cache
57+ File.readBinary (Stuff.registry cache)
61− exists <- File.exists path
62− if exists
63− then File.readBinary path
64− else return Nothing
65
58
66
59
67
60
@@ -86,26 +79,19 @@ addEntry (KnownVersions _ vs) count =
86
79
87allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
80allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
88allPkgsDecoder =
81allPkgsDecoder =
89− do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))
82+ let
90− checkKeys pairs Map.empty
83+ keyDecoder =
91− where
84+ Pkg.keyDecoder bail
92− checkKeys pairs pkgs =
93− case pairs of
94− [] ->
95− return pkgs
96−
97− (key, versions) : rest ->
98− case Pkg.fromString key of
99− Right pkg ->
100− case List.sortBy (flip compare) versions of
101− [] ->
102− D.failure ()
103
85
104− v:vs ->
86+ versionsDecoder =
105− checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)
87+ D.list (D.mapError (\_ -> ()) V.decoder)
106
88
107− Left _ ->
89+ toKnownVersions versions =
90+ case List.sortBy (flip compare) versions of
91+ v:vs -> return (KnownVersions v vs)
108− D.failure ()
92+ [] -> D.failure ()
93+ in
94+ D.dict keyDecoder (toKnownVersions =<< versionsDecoder)
109
95
110
96
111
97
@@ -144,22 +130,26 @@ addNew (name, version) versions =
144 Map.alter (Just . add) name versions
130 Map.alter (Just . add) name versions
145
131
146
132
133+
134+-- NEW PACKAGE DECODER
135+
136+
147newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
137newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
148newPkgDecoder =
138newPkgDecoder =
149− do str <- D.string
139+ D.customString newPkgParser bail
150− case Utf8.split 0x40 {-@-} str of
140+
151− [key, value] ->
152− case Pkg.fromString key of
153− Right pkg ->
154− case V.fromString value of
155− Just vsn -> return (pkg, vsn)
156− Nothing -> D.failure ()
157
141
158− Left _ ->
142+newPkgParser :: P.Parser () (Pkg.Name, V.Version)
159− D.failure ()
143+newPkgParser =
144+ do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
145+ P.word1 0x40 {-@-} bail
146+ vsn <- P.specialize (\_ _ _ -> ()) V.parser
147+ return (pkg, vsn)
160
148
161− _ ->
149+
162− D.failure ()
150+bail :: row -> col -> ()
151+bail _ _ =
152+ ()
163
153
164
154
165
155
@@ -190,33 +180,7 @@ getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
190getVersions' name (Registry _ versions) =
180getVersions' name (Registry _ versions) =
191 case Map.lookup name versions of
181 case Map.lookup name versions of
192 Just kvs -> Right kvs
182 Just kvs -> Right kvs
193− Nothing -> Left $ nearbyNames name (Map.keys versions)
183+ Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
194−
195−
196−nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
197−nearbyNames (Pkg.Name author1 project1) possibleNames =
198− let
199− authorDist = authorDistance (Name.toChars author1)
200− projectDist = projectDistance (Name.toChars project1)
201−
202− addDistance name@(Pkg.Name author2 project2) =
203− ( authorDist author2 + projectDist project2, name )
204− in
205− map snd $ take 4 $
206− List.sortBy (compare `on` fst) $
207− map addDistance possibleNames
208−
209−
210−authorDistance :: String -> Name.Name -> Int
211−authorDistance bad possibility =
212− abs (Suggest.distance bad (Name.toChars possibility))
213−
214−
215−projectDistance :: String -> Name.Name -> Int
216−projectDistance bad possibility =
217− if possibility == "elm" || possibility == "elm-explorations"
218− then 0
219− else abs (Suggest.distance bad (Name.toChars possibility))
220
184
221
185
222
186
@@ -225,11 +189,14 @@ projectDistance bad possibility =
225
189
226post :: 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)
227post manager path decoder callback =
191post manager path decoder callback =
192+ let
228− Http.post manager (Website.route path []) [] Exit.RP_Http $
193+ url = Website.route path []
194+ in
195+ Http.post manager url [] Exit.RP_Http $
229 \body ->
196 \body ->
230 case D.fromByteString decoder body of
197 case D.fromByteString decoder body of
231 Right a -> Right <$> callback a
198 Right a -> Right <$> callback a
232− Left _ -> return $ Left Exit.RP_Data
199+ Left _ -> return $ Left $ Exit.RP_Data url body
233
200
234
201
235
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+195−97
@@ -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,25 +16,32 @@ 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
27+import qualified Data.NonEmptyList as NE
24import qualified Data.OneOrMore as OneOrMore
28import qualified Data.OneOrMore as OneOrMore
25import qualified Data.Set as Set
29import qualified Data.Set as Set
26import qualified Data.Utf8 as Utf8
30import qualified Data.Utf8 as Utf8
31+import Data.Word (Word64)
27import qualified System.Directory as Dir
32import qualified System.Directory as Dir
28import System.FilePath ((</>), (<.>))
33import System.FilePath ((</>), (<.>))
29
34
35+import qualified AST.Canonical as Can
30import qualified AST.Source as Src
36import qualified AST.Source as Src
31import qualified AST.Optimized as Opt
37import qualified AST.Optimized as Opt
38+import qualified BackgroundWriter as BW
32import qualified Compile
39import qualified Compile
33import qualified Deps.Registry as Registry
40import qualified Deps.Registry as Registry
34import qualified Deps.Solver as Solver
41import qualified Deps.Solver as Solver
35import qualified Deps.Website as Website
42import qualified Deps.Website as Website
36import qualified Elm.Constraint as Con
43import qualified Elm.Constraint as Con
44+import qualified Elm.Docs as Docs
37import qualified Elm.Interface as I
45import qualified Elm.Interface as I
38import qualified Elm.Kernel as Kernel
46import qualified Elm.Kernel as Kernel
39import qualified Elm.ModuleName as ModuleName
47import qualified Elm.ModuleName as ModuleName
@@ -43,8 +51,10 @@ import qualified Elm.Version as V
43import qualified File
51import qualified File
44import qualified Http
52import qualified Http
45import qualified Json.Decode as D
53import qualified Json.Decode as D
54+import qualified Json.Encode as E
46import qualified Parse.Module as Parse
55import qualified Parse.Module as Parse
47import qualified Reporting
56import qualified Reporting
57+import qualified Reporting.Annotation as A
48import qualified Reporting.Exit as Exit
58import qualified Reporting.Exit as Exit
49import qualified Reporting.Task as Task
59import qualified Reporting.Task as Task
50import qualified Stuff
60import qualified Stuff
@@ -58,23 +68,42 @@ data Details =
58 Details
68 Details
59 { _outlineTime :: File.Time
69 { _outlineTime :: File.Time
60 , _outline :: ValidOutline
70 , _outline :: ValidOutline
71+ , _buildID :: BuildID
61 , _locals :: Map.Map ModuleName.Raw Local
72 , _locals :: Map.Map ModuleName.Raw Local
62 , _foreigns :: Map.Map ModuleName.Raw Foreign
73 , _foreigns :: Map.Map ModuleName.Raw Foreign
63 , _extras :: Extras
74 , _extras :: Extras
64 }
75 }
65
76
66
77
67−data ValidOutline
78+type BuildID = Word64
68− = ValidApp Outline.AppOutline
69− | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)
70
79
71
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+--
72data Local =
99data Local =
73 Local
100 Local
74 { _path :: FilePath
101 { _path :: FilePath
75 , _time :: File.Time
102 , _time :: File.Time
76 , _deps :: [ModuleName.Raw]
103 , _deps :: [ModuleName.Raw]
77 , _main :: Bool
104 , _main :: Bool
105+ , _lastChange :: BuildID
106+ , _lastCompile :: BuildID
78 }
107 }
79
108
80
109
@@ -96,14 +125,14 @@ type Interfaces =
96
125
97
126
98loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
127loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
99−loadObjects root (Details _ _ _ _ extras) =
128+loadObjects root (Details _ _ _ _ _ extras) =
100 case extras of
129 case extras of
101 ArtifactsFresh _ o -> newMVar (Just o)
130 ArtifactsFresh _ o -> newMVar (Just o)
102 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
131 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
103
132
104
133
105loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
134loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
106−loadInterfaces root (Details _ _ _ _ extras) =
135+loadInterfaces root (Details _ _ _ _ _ extras) =
107 case extras of
136 case extras of
108 ArtifactsFresh i _ -> newMVar (Just i)
137 ArtifactsFresh i _ -> newMVar (Just i)
109 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
138 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
@@ -113,11 +142,11 @@ loadInterfaces root (Details _ _ _ _ extras) =
113-- VERIFY INSTALL -- used by Install
142-- VERIFY INSTALL -- used by Install
114
143
115
144
116−verifyInstall :: FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
145+verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
117−verifyInstall root (Solver.Env cache manager connection registry) outline =
146+verifyInstall scope root (Solver.Env cache manager connection registry) outline =
118 do time <- File.getTime (root </> "elm.json")
147 do time <- File.getTime (root </> "elm.json")
119 let key = Reporting.ignorer
148 let key = Reporting.ignorer
120− let env = Env key root cache manager connection registry
149+ let env = Env key scope root cache manager connection registry
121 case outline of
150 case outline of
122 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
151 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
123 Outline.App app -> Task.run (verifyApp env time app >> return ())
152 Outline.App app -> Task.run (verifyApp env time app >> return ())
@@ -127,28 +156,28 @@ verifyInstall root (Solver.Env cache manager connection registry) outline =
127-- LOAD -- used by Make, Repl, Reactor
156-- LOAD -- used by Make, Repl, Reactor
128
157
129
158
130−load :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)
159+load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
131−load style root =
160+load style scope root =
132 do newTime <- File.getTime (root </> "elm.json")
161 do newTime <- File.getTime (root </> "elm.json")
133 maybeDetails <- File.readBinary (Stuff.details root)
162 maybeDetails <- File.readBinary (Stuff.details root)
134 case maybeDetails of
163 case maybeDetails of
135 Nothing ->
164 Nothing ->
136− generate style root newTime
165+ generate style scope root newTime
137
166
138− Just details@(Details oldTime _ _ _ _) ->
167+ Just details@(Details oldTime _ buildID _ _ _) ->
139 if oldTime == newTime
168 if oldTime == newTime
140− then return (Right details)
169+ then return (Right details { _buildID = buildID + 1 })
141− else generate style root newTime
170+ else generate style scope root newTime
142
171
143
172
144
173
145-- GENERATE
174-- GENERATE
146
175
147
176
148−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)
149−generate style root time =
178+generate style scope root time =
150 Reporting.trackDetails style $ \key ->
179 Reporting.trackDetails style $ \key ->
151− do result <- initEnv key root
180+ do result <- initEnv key scope root
152 case result of
181 case result of
153 Left exit ->
182 Left exit ->
154 return (Left exit)
183 return (Left exit)
@@ -166,6 +195,7 @@ generate style root time =
166data Env =
195data Env =
167 Env
196 Env
168 { _key :: Reporting.DKey
197 { _key :: Reporting.DKey
198+ , _scope :: BW.Scope
169 , _root :: FilePath
199 , _root :: FilePath
170 , _cache :: Stuff.PackageCache
200 , _cache :: Stuff.PackageCache
171 , _manager :: Http.Manager
201 , _manager :: Http.Manager
@@ -174,8 +204,8 @@ data Env =
174 }
204 }
175
205
176
206
177−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))
178−initEnv key root =
208+initEnv key scope root =
179 do mvar <- fork Solver.initEnv
209 do mvar <- fork Solver.initEnv
180 eitherOutline <- Outline.read root
210 eitherOutline <- Outline.read root
181 case eitherOutline of
211 case eitherOutline of
@@ -189,7 +219,7 @@ initEnv key root =
189 return $ Left $ Exit.DetailsCannotGetRegistry problem
219 return $ Left $ Exit.DetailsCannotGetRegistry problem
190
220
191 Right (Solver.Env cache manager connection registry) ->
221 Right (Solver.Env cache manager connection registry) ->
192− return $ Right (Env key root cache manager connection registry, outline)
222+ return $ Right (Env key scope root cache manager connection registry, outline)
193
223
194
224
195
225
@@ -200,24 +230,25 @@ type Task a = Task.Task Exit.Details a
200
230
201
231
202verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
232verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
203−verifyPkg env time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
233+verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
204 if Con.goodElm elm
234 if Con.goodElm elm
205 then
235 then
206 do solution <- verifyConstraints env =<< union noDups direct testDirect
236 do solution <- verifyConstraints env =<< union noDups direct testDirect
237+ let exposedList = Outline.flattenExposed exposed
207− let vsns = Map.map (\(Solver.Details v _) -> v) solution
238+ let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
208− verifyDependencies env time (ValidPkg outline vsns) solution direct
239+ verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
209 else
240 else
210 Task.throw $ Exit.DetailsBadElmInPkg elm
241 Task.throw $ Exit.DetailsBadElmInPkg elm
211
242
212
243
213verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
244verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
214−verifyApp env time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
245+verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
215 if elmVersion == V.compiler
246 if elmVersion == V.compiler
216 then
247 then
217 do stated <- checkAppDeps outline
248 do stated <- checkAppDeps outline
218 actual <- verifyConstraints env (Map.map Con.exactly stated)
249 actual <- verifyConstraints env (Map.map Con.exactly stated)
219 if Map.size stated == Map.size actual
250 if Map.size stated == Map.size actual
220− then verifyDependencies env time (ValidApp outline) actual direct
251+ then verifyDependencies env time (ValidApp srcDirs) actual direct
221 else Task.throw $ Exit.DetailsHandEditedDependencies
252 else Task.throw $ Exit.DetailsHandEditedDependencies
222 else
253 else
223 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
254 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
@@ -235,7 +266,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
235
266
236
267
237verifyConstraints :: 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)
238−verifyConstraints (Env _ _ cache _ connection registry) constraints =
269+verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
239 do result <- Task.io $ Solver.verify cache connection registry constraints
270 do result <- Task.io $ Solver.verify cache connection registry constraints
240 case result of
271 case result of
241 Solver.Ok details -> return details
272 Solver.Ok details -> return details
@@ -281,27 +312,30 @@ fork work =
281
312
282
313
283verifyDependencies :: 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
284−verifyDependencies env@(Env key root _ _ _ _) time outline solution directDeps =
315+verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
285 Task.eio id $
316 Task.eio id $
286 do Reporting.report key (Reporting.DStart (Map.size solution))
317 do Reporting.report key (Reporting.DStart (Map.size solution))
287 mvar <- newEmptyMVar
318 mvar <- newEmptyMVar
319+ mvars <- Stuff.withRegistryLock cache $
288− 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
289 putMVar mvar mvars
321 putMVar mvar mvars
290 deps <- traverse readMVar mvars
322 deps <- traverse readMVar mvars
291 case sequence deps of
323 case sequence deps of
292− Left problem ->
324+ Left _ ->
293− error "TODO verifyDependencies" problem
325+ do home <- Stuff.getElmHome
326+ return $ Left $ Exit.DetailsBadDeps home $
327+ Maybe.catMaybes $ Either.lefts $ Map.elems deps
294
328
295 Right artifacts ->
329 Right artifacts ->
296 let
330 let
297 objs = Map.foldr addObjects Opt.empty artifacts
331 objs = Map.foldr addObjects Opt.empty artifacts
298 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
332 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
299− 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
300− details = Details time outline Map.empty foreigns (ArtifactsFresh ifaces objs)
334+ details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
301 in
335 in
302− do File.writeBinary (Stuff.objects root) objs
336+ do BW.writeBinary scope (Stuff.objects root) objs
303− File.writeBinary (Stuff.interfaces root) ifaces
337+ BW.writeBinary scope (Stuff.interfaces root) ifaces
304− File.writeBinary (Stuff.details root) details
338+ BW.writeBinary scope (Stuff.details root) details
305 return (Right details)
339 return (Right details)
306
340
307
341
@@ -341,44 +375,36 @@ data Artifacts =
341
375
342
376
343type Dep =
377type Dep =
344− Either Problem Artifacts
378+ Either (Maybe Exit.DetailsBadDep) Artifacts
345−
346−
347−data Problem
348− = BadDownload Exit.PackageProblem
349− | BadBuild
350− | BadDependency
351
379
352
380
353verifyDep :: 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
354−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) =
355− let
356− fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
383+ do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
357− in
358− do exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
384+ exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
359 if exists
385 if exists
360 then
386 then
361 do Reporting.report key Reporting.DCached
387 do Reporting.report key Reporting.DCached
362 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
388 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
363 case maybeCache of
389 case maybeCache of
364 Nothing ->
390 Nothing ->
365− build key cache depsMVar pkg details (Set.singleton fingerprint)
391+ build key cache depsMVar pkg details fingerprint Set.empty
366
392
367 Just (ArtifactCache fingerprints artifacts) ->
393 Just (ArtifactCache fingerprints artifacts) ->
368 if Set.member fingerprint fingerprints
394 if Set.member fingerprint fingerprints
369 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
395 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
370− else build key cache depsMVar pkg details (Set.insert fingerprint fingerprints)
396+ else build key cache depsMVar pkg details fingerprint fingerprints
371 else
397 else
372 do Reporting.report key Reporting.DRequested
398 do Reporting.report key Reporting.DRequested
373 result <- downloadPackage cache manager pkg vsn
399 result <- downloadPackage cache manager pkg vsn
374 case result of
400 case result of
375− Left p ->
401+ Left problem ->
376 do Reporting.report key (Reporting.DFailed pkg vsn)
402 do Reporting.report key (Reporting.DFailed pkg vsn)
377− return (Left (BadDownload p))
403+ return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
378
404
379 Right () ->
405 Right () ->
380 do Reporting.report key (Reporting.DReceived pkg vsn)
406 do Reporting.report key (Reporting.DReceived pkg vsn)
381− build key cache depsMVar pkg details (Set.singleton fingerprint)
407+ build key cache depsMVar pkg details fingerprint Set.empty
382
408
383
409
384
410
@@ -400,17 +426,17 @@ type Fingerprint =
400-- BUILD
426-- BUILD
401
427
402
428
403−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
404−build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
430+build key cache depsMVar pkg (Solver.Details vsn _) f fs =
405 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
431 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
406 case eitherOutline of
432 case eitherOutline of
407 Left _ ->
433 Left _ ->
408 do Reporting.report key Reporting.DBroken
434 do Reporting.report key Reporting.DBroken
409− return (Left BadBuild)
435+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
410
436
411 Right (Outline.App _) ->
437 Right (Outline.App _) ->
412 do Reporting.report key Reporting.DBroken
438 do Reporting.report key Reporting.DBroken
413− return (Left BadBuild)
439+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
414
440
415 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
441 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
416 do allDeps <- readMVar depsMVar
442 do allDeps <- readMVar depsMVar
@@ -418,21 +444,22 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
418 case sequence directDeps of
444 case sequence directDeps of
419 Left _ ->
445 Left _ ->
420 do Reporting.report key Reporting.DBroken
446 do Reporting.report key Reporting.DBroken
421− return (Left BadDependency)
447+ return $ Left $ Nothing
422
448
423 Right directArtifacts ->
449 Right directArtifacts ->
424 do let src = Stuff.package cache pkg vsn </> "src"
450 do let src = Stuff.package cache pkg vsn </> "src"
425 let foreignDeps = gatherForeignInterfaces directArtifacts
451 let foreignDeps = gatherForeignInterfaces directArtifacts
426 let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
452 let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
453+ docsStatus <- getDocsStatus cache pkg vsn
427 mvar <- newEmptyMVar
454 mvar <- newEmptyMVar
428− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) exposedDict
455+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
429 putMVar mvar mvars
456 putMVar mvar mvars
430 mapM_ readMVar mvars
457 mapM_ readMVar mvars
431 maybeStatuses <- traverse readMVar =<< readMVar mvar
458 maybeStatuses <- traverse readMVar =<< readMVar mvar
432 case sequence maybeStatuses of
459 case sequence maybeStatuses of
433 Nothing ->
460 Nothing ->
434 do Reporting.report key Reporting.DBroken
461 do Reporting.report key Reporting.DBroken
435− return (Left BadBuild)
462+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
436
463
437 Just statuses ->
464 Just statuses ->
438 do rmvar <- newEmptyMVar
465 do rmvar <- newEmptyMVar
@@ -442,7 +469,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
442 case sequence maybeResults of
469 case sequence maybeResults of
443 Nothing ->
470 Nothing ->
444 do Reporting.report key Reporting.DBroken
471 do Reporting.report key Reporting.DBroken
445− return (Left BadBuild)
472+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
446
473
447 Just results ->
474 Just results ->
448 let
475 let
@@ -450,8 +477,10 @@ build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
450 ifaces = gatherInterfaces exposedDict results
477 ifaces = gatherInterfaces exposedDict results
451 objects = gatherObjects results
478 objects = gatherObjects results
452 artifacts = Artifacts ifaces objects
479 artifacts = Artifacts ifaces objects
480+ fingerprints = Set.insert f fs
453 in
481 in
482+ do writeDocs cache pkg vsn docsStatus results
454− do File.writeBinary path (ArtifactCache fingerprints artifacts)
483+ File.writeBinary path (ArtifactCache fingerprints artifacts)
455 Reporting.report key Reporting.DBuilt
484 Reporting.report key Reporting.DBuilt
456 return (Right artifacts)
485 return (Right artifacts)
457
486
@@ -468,7 +497,7 @@ gatherObjects results =
468addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
497addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
469addLocalGraph name status graph =
498addLocalGraph name status graph =
470 case status of
499 case status of
471− RLocal _ objs -> Opt.addLocalGraph objs graph
500+ RLocal _ objs _ -> Opt.addLocalGraph objs graph
472 RForeign _ -> graph
501 RForeign _ -> graph
473 RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
502 RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
474 RKernelForeign -> graph
503 RKernelForeign -> graph
@@ -487,10 +516,10 @@ gatherInterfaces exposed artifacts =
487toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
516toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
488toLocalInterface func result =
517toLocalInterface func result =
489 case result of
518 case result of
490− RLocal iface _ -> Just (func iface)
519+ RLocal iface _ _ -> Just (func iface)
491− RForeign _ -> Nothing
520+ RForeign _ -> Nothing
492− RKernelLocal _ -> Nothing
521+ RKernelLocal _ -> Nothing
493− RKernelForeign -> Nothing
522+ RKernelForeign -> Nothing
494
523
495
524
496
525
@@ -533,14 +562,14 @@ type StatusDict =
533
562
534
563
535data Status
564data Status
536− = SLocal (Map.Map ModuleName.Raw ()) Src.Module
565+ = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
537 | SForeign I.Interface
566 | SForeign I.Interface
538 | SKernelLocal [Kernel.Chunk]
567 | SKernelLocal [Kernel.Chunk]
539 | SKernelForeign
568 | SKernelForeign
540
569
541
570
542−crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)
571+crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status)
543−crawlModule foreignDeps mvar pkg src name =
572+crawlModule foreignDeps mvar pkg src docsStatus name =
544 do let path = src </> ModuleName.toFilePath name <.> "elm"
573 do let path = src </> ModuleName.toFilePath name <.> "elm"
545 exists <- File.exists path
574 exists <- File.exists path
546 case Map.lookup name foreignDeps of
575 case Map.lookup name foreignDeps of
@@ -554,7 +583,7 @@ crawlModule foreignDeps mvar pkg src name =
554
583
555 Nothing ->
584 Nothing ->
556 if exists then
585 if exists then
557− crawlFile foreignDeps mvar pkg src name path
586+ crawlFile foreignDeps mvar pkg src docsStatus name path
558
587
559 else if Pkg.isKernel pkg && Name.isKernel name then
588 else if Pkg.isKernel pkg && Name.isKernel name then
560 crawlKernel foreignDeps mvar pkg src name
589 crawlKernel foreignDeps mvar pkg src name
@@ -563,13 +592,13 @@ crawlModule foreignDeps mvar pkg src name =
563 return Nothing
592 return Nothing
564
593
565
594
566−crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
595+crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
567−crawlFile foreignDeps mvar pkg src name path =
596+crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
568 do bytes <- File.readUtf8 path
597 do bytes <- File.readUtf8 path
569− case Parse.fromByteString pkg bytes of
598+ case Parse.fromByteString (Parse.Package pkg) bytes of
570− Right modul@(Src.Module (Just actualName) _ imports _ _ _ _ _) | name == actualName ->
599+ Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
571 do deps <- crawlImports foreignDeps mvar pkg src imports
600 do deps <- crawlImports foreignDeps mvar pkg src imports
572− return (Just (SLocal deps modul))
601+ return (Just (SLocal docsStatus deps modul))
573
602
574 _ ->
603 _ ->
575 return Nothing
604 return Nothing
@@ -580,7 +609,7 @@ crawlImports foreignDeps mvar pkg src imports =
580 do statusDict <- takeMVar mvar
609 do statusDict <- takeMVar mvar
581 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
610 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
582 let news = Map.difference deps statusDict
611 let news = Map.difference deps statusDict
583− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) news
612+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news
584 putMVar mvar (Map.union mvars statusDict)
613 putMVar mvar (Map.union mvars statusDict)
585 mapM_ readMVar mvars
614 mapM_ readMVar mvars
586 return deps
615 return deps
@@ -616,7 +645,7 @@ getDepHome fi =
616
645
617
646
618data Result
647data Result
619− = RLocal !I.Interface !Opt.LocalGraph
648+ = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)
620 | RForeign I.Interface
649 | RForeign I.Interface
621 | RKernelLocal [Kernel.Chunk]
650 | RKernelLocal [Kernel.Chunk]
622 | RKernelForeign
651 | RKernelForeign
@@ -625,7 +654,7 @@ data Result
625compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
654compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
626compile pkg mvar status =
655compile pkg mvar status =
627 case status of
656 case status of
628− SLocal deps modul ->
657+ SLocal docsStatus deps modul ->
629 do resultsDict <- readMVar mvar
658 do resultsDict <- readMVar mvar
630 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
659 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
631 case sequence maybeResults of
660 case sequence maybeResults of
@@ -638,7 +667,11 @@ compile pkg mvar status =
638 return Nothing
667 return Nothing
639
668
640 Right (Compile.Artifacts canonical annotations objects) ->
669 Right (Compile.Artifacts canonical annotations objects) ->
670+ let
641− return (Just (RLocal (I.fromModule pkg canonical annotations) objects))
671+ ifaces = I.fromModule pkg canonical annotations
672+ docs = makeDocs docsStatus canonical
673+ in
674+ return (Just (RLocal ifaces objects docs))
642
675
643 SForeign iface ->
676 SForeign iface ->
644 return (Just (RForeign iface))
677 return (Just (RForeign iface))
@@ -653,10 +686,59 @@ compile pkg mvar status =
653getInterface :: Result -> Maybe I.Interface
686getInterface :: Result -> Maybe I.Interface
654getInterface result =
687getInterface result =
655 case result of
688 case result of
656− RLocal iface _ -> Just iface
689+ RLocal iface _ _ -> Just iface
657− RForeign iface -> Just iface
690+ RForeign iface -> Just iface
658− RKernelLocal _ -> Nothing
691+ RKernelLocal _ -> Nothing
659− RKernelForeign -> Nothing
692+ RKernelForeign -> Nothing
693+
694+
695+
696+-- MAKE DOCS
697+
698+
699+data DocsStatus
700+ = DocsNeeded
701+ | DocsNotNeeded
702+
703+
704+getDocsStatus :: Stuff.PackageCache -> Pkg.Name -> V.Version -> IO DocsStatus
705+getDocsStatus cache pkg vsn =
706+ do exists <- File.exists (Stuff.package cache pkg vsn </> "docs.json")
707+ if exists
708+ then return DocsNotNeeded
709+ else return DocsNeeded
710+
711+
712+makeDocs :: DocsStatus -> Can.Module -> Maybe Docs.Module
713+makeDocs status modul =
714+ case status of
715+ DocsNeeded ->
716+ case Docs.fromModule modul of
717+ Right docs -> Just docs
718+ Left _ -> Nothing
719+
720+ DocsNotNeeded ->
721+ Nothing
722+
723+
724+writeDocs :: Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO ()
725+writeDocs cache pkg vsn status results =
726+ case status of
727+ DocsNeeded ->
728+ E.writeUgly (Stuff.package cache pkg vsn </> "docs.json") $
729+ Docs.encode $ Map.mapMaybe toDocs results
730+
731+ DocsNotNeeded ->
732+ return ()
733+
734+
735+toDocs :: Result -> Maybe Docs.Module
736+toDocs result =
737+ case result of
738+ RLocal _ _ docs -> docs
739+ RForeign _ -> Nothing
740+ RKernelLocal _ -> Nothing
741+ RKernelForeign -> Nothing
660
742
661
743
662
744
@@ -665,24 +747,27 @@ getInterface result =
665
747
666downloadPackage :: 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 ())
667downloadPackage cache manager pkg vsn =
749downloadPackage cache manager pkg vsn =
750+ let
751+ url = Website.metadata pkg vsn "endpoint.json"
752+ in
668 do eitherByteString <-
753 do eitherByteString <-
669− Http.get manager (Website.metadata pkg vsn "endpoint.json") [] id (return . Right)
754+ Http.get manager url [] id (return . Right)
670
755
671 case eitherByteString of
756 case eitherByteString of
672 Left err ->
757 Left err ->
673− return (Left (Exit.PP_BadEndpointRequest err))
758+ return $ Left $ Exit.PP_BadEndpointRequest err
674
759
675 Right byteString ->
760 Right byteString ->
676 case D.fromByteString endpointDecoder byteString of
761 case D.fromByteString endpointDecoder byteString of
677 Left _ ->
762 Left _ ->
678− return (Left Exit.PP_BadEndpointContent)
763+ return $ Left $ Exit.PP_BadEndpointContent url
679
764
680 Right (endpoint, expectedHash) ->
765 Right (endpoint, expectedHash) ->
681− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
766+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
682 \(sha, archive) ->
767 \(sha, archive) ->
683 if expectedHash == Http.shaToChars sha
768 if expectedHash == Http.shaToChars sha
684 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
769 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
685− else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
770+ else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
686
771
687
772
688endpointDecoder :: D.Decoder e (String, String)
773endpointDecoder :: D.Decoder e (String, String)
@@ -697,27 +782,40 @@ endpointDecoder =
697
782
698
783
699instance 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
700− 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)
701− put (Details a b c d _) = put a >> put b >> put c >> put d
702
793
703
794
704instance Binary ValidOutline where
795instance Binary ValidOutline where
705 put outline =
796 put outline =
706 case outline of
797 case outline of
707− ValidApp a -> putWord8 0 >> put a
798+ ValidApp a -> putWord8 0 >> put a
708− ValidPkg a b -> putWord8 1 >> put a >> put b
799+ ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
709
800
710 get =
801 get =
711 do n <- getWord8
802 do n <- getWord8
712 case n of
803 case n of
713 0 -> liftM ValidApp get
804 0 -> liftM ValidApp get
714− 1 -> liftM2 ValidPkg get get
805+ 1 -> liftM3 ValidPkg get get get
715− _ -> error "binary encoding of ValidOutline was corrupted"
806+ _ -> fail "binary encoding of ValidOutline was corrupted"
716
807
717
808
718instance Binary Local where
809instance Binary Local where
719− get = liftM4 Local get get get get
720− 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)
721
819
722
820
723instance 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+148−115
@@ -1,10 +1,11 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
3module Elm.Outline
3module Elm.Outline
4 ( Outline(..)
4 ( 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
@@ -18,10 +19,12 @@ module Elm.Outline
18import Prelude hiding (read)
19import Prelude hiding (read)
19import Control.Monad (filterM, liftM)
20import Control.Monad (filterM, liftM)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
21import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import Data.Foldable (traverse_)
22import qualified Data.Map as Map
22import qualified Data.Map as Map
23−import qualified Data.Utf8 as Utf8
23+import qualified Data.NonEmptyList as NE
24+import qualified Data.OneOrMore as OneOrMore
25+import Foreign.Ptr (minusPtr)
24import qualified System.Directory as Dir
26import qualified System.Directory as Dir
27+import qualified System.FilePath as FP
25import System.FilePath ((</>))
28import System.FilePath ((</>))
26
29
27import qualified Elm.Constraint as Con
30import qualified Elm.Constraint as Con
@@ -32,6 +35,9 @@ import qualified Elm.Version as V
32import qualified File
35import qualified File
33import qualified Json.Decode as D
36import qualified Json.Decode as D
34import qualified Json.Encode as E
37import qualified Json.Encode as E
38+import Json.Encode ((==>))
39+import qualified Json.String as Json
40+import qualified Parse.Primitives as P
35import qualified Reporting.Exit as Exit
41import qualified Reporting.Exit as Exit
36
42
37
43
@@ -47,7 +53,7 @@ data Outline
47data AppOutline =
53data AppOutline =
48 AppOutline
54 AppOutline
49 { _app_elm_version :: V.Version
55 { _app_elm_version :: V.Version
50− , _app_source_dirs :: [FilePath]
56+ , _app_source_dirs :: NE.List SrcDir
51 , _app_deps_direct :: Map.Map Pkg.Name V.Version
57 , _app_deps_direct :: Map.Map Pkg.Name V.Version
52 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
58 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
53 , _app_test_direct :: Map.Map Pkg.Name V.Version
59 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -58,7 +64,7 @@ data AppOutline =
58data PkgOutline =
64data PkgOutline =
59 PkgOutline
65 PkgOutline
60 { _pkg_name :: Pkg.Name
66 { _pkg_name :: Pkg.Name
61− , _pkg_summary :: Utf8.String
67+ , _pkg_summary :: Json.String
62 , _pkg_license :: Licenses.License
68 , _pkg_license :: Licenses.License
63 , _pkg_version :: V.Version
69 , _pkg_version :: V.Version
64 , _pkg_exposed :: Exposed
70 , _pkg_exposed :: Exposed
@@ -70,16 +76,21 @@ data PkgOutline =
70
76
71data Exposed
77data Exposed
72 = ExposedList [ModuleName.Raw]
78 = ExposedList [ModuleName.Raw]
73− | ExposedDict [(Utf8.String, [ModuleName.Raw])]
79+ | ExposedDict [(Json.String, [ModuleName.Raw])]
80+
81+
82+data SrcDir
83+ = AbsoluteSrcDir FilePath
84+ | RelativeSrcDir FilePath
74
85
75
86
76
87
77-- DEFAULTS
88-- DEFAULTS
78
89
79
90
80−defaultSummary :: Utf8.String
91+defaultSummary :: Json.String
81defaultSummary =
92defaultSummary =
82− "helpful summary of your project, less than 80 characters"
93+ Json.fromChars "helpful summary of your project, less than 80 characters"
83
94
84
95
85
96
@@ -114,8 +125,8 @@ encode outline =
114 case outline of
125 case outline of
115 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
116 E.object
127 E.object
117− [ "type" ==> E.string "application"
128+ [ "type" ==> E.chars "application"
118− , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs
129+ , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
119 , "elm-version" ==> V.encode elm
130 , "elm-version" ==> V.encode elm
120 , "dependencies" ==>
131 , "dependencies" ==>
121 E.object
132 E.object
@@ -131,7 +142,7 @@ encode outline =
131
142
132 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
143 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
133 E.object
144 E.object
134− [ "type" ==> E.string "package"
145+ [ "type" ==> E.string (Json.fromChars "package")
135 , "name" ==> Pkg.encode name
146 , "name" ==> Pkg.encode name
136 , "summary" ==> E.string summary
147 , "summary" ==> E.string summary
137 , "license" ==> Licenses.encode license
148 , "license" ==> Licenses.encode license
@@ -143,11 +154,6 @@ encode outline =
143 ]
154 ]
144
155
145
156
146−(==>) :: a -> b -> (a, b)
147−(==>) a b =
148− (a, b)
149−
150−
151encodeExposed :: Exposed -> E.Value
157encodeExposed :: Exposed -> E.Value
152encodeExposed exposed =
158encodeExposed exposed =
153 case exposed of
159 case exposed of
@@ -165,7 +171,14 @@ encodeModule name =
165
171
166encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
172encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
167encodeDeps encodeValue deps =
173encodeDeps encodeValue deps =
168− E.dict Pkg.toString encodeValue deps
174+ E.dict Pkg.toJsonString encodeValue deps
175+
176+
177+encodeSrcDir :: SrcDir -> E.Value
178+encodeSrcDir srcDir =
179+ case srcDir of
180+ AbsoluteSrcDir dir -> E.chars dir
181+ RelativeSrcDir dir -> E.chars dir
169
182
170
183
171
184
@@ -181,19 +194,72 @@ read root =
181
194
182 Right outline ->
195 Right outline ->
183 case outline of
196 case outline of
184− Pkg _ ->
197+ Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
198+ return $
199+ if Map.notMember Pkg.core deps && pkg /= Pkg.core
200+ then Left Exit.OutlineNoPkgCore
185− 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
236+
237+
238+toAbsolute :: FilePath -> SrcDir -> FilePath
239+toAbsolute root srcDir =
240+ case srcDir of
241+ AbsoluteSrcDir dir -> dir
242+ RelativeSrcDir dir -> root </> dir
243+
244+
245+detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
246+detectDuplicates root srcDirs =
247+ do pairs <- traverse (toPair root) srcDirs
248+ return $ Map.lookupMin $ Map.mapMaybe isDup $
249+ Map.fromListWith OneOrMore.more pairs
250+
186
251
187− App (AppOutline _ srcDirs _ _ _ _) ->
252+toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
188− do badDirs <- filterM (isBadSrcDir root) srcDirs
253+toPair root srcDir =
189− case badDirs of
254+ do key <- Dir.canonicalizePath (toAbsolute root srcDir)
190− [] -> return $ Right outline
255+ return (key, OneOrMore.one (toGiven srcDir))
191− d:ds -> return $ Left (Exit.OutlineHasBadSrcDirs d ds)
192
256
193
257
194−isBadSrcDir :: FilePath -> FilePath -> IO Bool
258+isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
195−isBadSrcDir root dir =
259+isDup paths =
196− not <$> Dir.doesDirectoryExist (root </> dir)
260+ case paths of
261+ OneOrMore.One _ -> Nothing
262+ OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
197
263
198
264
199
265
@@ -206,23 +272,21 @@ type Decoder a =
206
272
207decoder :: Decoder Outline
273decoder :: Decoder Outline
208decoder =
274decoder =
275+ let
276+ application = Json.fromChars "application"
277+ package = Json.fromChars "package"
278+ in
209 do tipe <- D.field "type" D.string
279 do tipe <- D.field "type" D.string
210− case tipe of
211− "application" ->
212− App <$> appDecoder
280+ if | tipe == application -> App <$> appDecoder
213−
214− "package" ->
215− Pkg <$> pkgDecoder
281+ | tipe == package -> Pkg <$> pkgDecoder
216−
217− other ->
218− D.failure (Exit.OP_BadType other)
282+ | otherwise -> D.failure Exit.OP_BadType
219
283
220
284
221appDecoder :: Decoder AppOutline
285appDecoder :: Decoder AppOutline
222appDecoder =
286appDecoder =
223 AppOutline
287 AppOutline
224 <$> D.field "elm-version" versionDecoder
288 <$> D.field "elm-version" versionDecoder
225− <*> D.field "source-directories" (D.list dirDecoder)
289+ <*> D.field "source-directories" dirsDecoder
226 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
290 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
227 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
291 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
228 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
292 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
@@ -232,7 +296,7 @@ appDecoder =
232pkgDecoder :: Decoder PkgOutline
296pkgDecoder :: Decoder PkgOutline
233pkgDecoder =
297pkgDecoder =
234 PkgOutline
298 PkgOutline
235− <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)
299+ <$> D.field "name" nameDecoder
236 <*> D.field "summary" summaryDecoder
300 <*> D.field "summary" summaryDecoder
237 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
301 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
238 <*> D.field "version" versionDecoder
302 <*> D.field "version" versionDecoder
@@ -246,17 +310,21 @@ pkgDecoder =
246-- JSON DECODE HELPERS
310-- JSON DECODE HELPERS
247
311
248
312
313+nameDecoder :: Decoder Pkg.Name
314+nameDecoder =
315+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316+
317+
249−summaryDecoder :: Decoder Utf8.String
318+summaryDecoder :: Decoder Json.String
250summaryDecoder =
319summaryDecoder =
251− do summary <- D.string
320+ D.customString
252− if Utf8.size summary < 80
321+ (boundParser 80 Exit.OP_BadSummaryTooLong)
253− then return summary
254− else D.failure Exit.OP_BadSummaryTooLong
322+ (\_ _ -> Exit.OP_BadSummaryTooLong)
255
323
256
324
257versionDecoder :: Decoder V.Version
325versionDecoder :: Decoder V.Version
258versionDecoder =
326versionDecoder =
259− D.mapError Exit.OP_BadVersion V.decoder
327+ D.mapError (uncurry Exit.OP_BadVersion) V.decoder
260
328
261
329
262constraintDecoder :: Decoder Con.Constraint
330constraintDecoder :: Decoder Con.Constraint
@@ -266,24 +334,19 @@ constraintDecoder =
266
334
267depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
335depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
268depsDecoder valueDecoder =
336depsDecoder valueDecoder =
269− Map.fromList <$> (
337+ D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
270− traverse validateKey =<< D.pairs valueDecoder
271− )
272
338
273
339
274−validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
340+dirsDecoder :: Decoder (NE.List SrcDir)
275−validateKey (key, value) =
341+dirsDecoder =
276− case Pkg.fromString key of
342+ fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
277− Right name ->
278− return (name, value)
279
343
280− Left _ ->
281− D.failure (Exit.OP_BadDependencyName key)
282
344
283−
345+toSrcDir :: FilePath -> SrcDir
284−dirDecoder :: Decoder FilePath
346+toSrcDir path =
285−dirDecoder =
347+ if FP.isRelative path
286− Utf8.toChars <$> D.string
348+ then RelativeSrcDir path
349+ else AbsoluteSrcDir path
287
350
288
351
289
352
@@ -294,81 +357,51 @@ exposedDecoder :: Decoder Exposed
294exposedDecoder =
357exposedDecoder =
295 D.oneOf
358 D.oneOf
296 [ ExposedList <$> D.list moduleDecoder
359 [ ExposedList <$> D.list moduleDecoder
297− , do pairs <- D.pairs (D.list moduleDecoder)
360+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
298− traverse_ (checkHeader . fst) pairs
299− return (ExposedDict pairs)
300 ]
361 ]
301
362
302
363
303moduleDecoder :: Decoder ModuleName.Raw
364moduleDecoder :: Decoder ModuleName.Raw
304moduleDecoder =
365moduleDecoder =
305− D.mapError Exit.OP_BadModuleName ModuleName.decoder
366+ D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
306
367
307
368
308−checkHeader :: Utf8.String -> Decoder ()
369+headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
309−checkHeader header =
370+headerKeyDecoder =
310− if Utf8.size header < 20
371+ D.KeyDecoder
311− then return ()
372+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
312− else D.failure (Exit.OP_BadModuleHeaderTooLong header)
373+ (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
313
374
314
375
315
376
316−-- BINARY
377+-- BOUND PARSER
317
378
318
379
319−instance Binary Outline where
380+boundParser :: Int -> x -> P.Parser x Json.String
320− put outline =
381+boundParser bound tooLong =
321− case outline of
382+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
322− App a -> putWord8 0 >> put a
383+ let
323− Pkg a -> putWord8 1 >> put a
384+ len = minusPtr end pos
324−
385+ newCol = col + fromIntegral len
325− get =
386+ in
326− do n <- getWord8
387+ if len < bound
327− case n of
388+ then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
328− 0 -> liftM App get
389+ else cerr row newCol (\_ _ -> tooLong)
329− 1 -> liftM Pkg get
330− _ -> error "binary encoding of Outline was corrupted"
331
390
332
391
333−instance Binary AppOutline where
334− put (AppOutline a b c d e f) =
335− put a >> put b >> put c >> put d >> put e >> put f
336−
337− get =
338− do a <- get
339− b <- get
340− c <- get
341− d <- get
342− e <- get
343− f <- get
344− return (AppOutline a b c d e f)
345
392
393+-- BINARY
346
394
347−instance Binary PkgOutline where
348− put (PkgOutline a b c d e f g h) =
349− put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
350
395
351− get =
352− do a <- get
353− b <- get
354− c <- get
355− d <- get
356− e <- get
357− f <- get
358− g <- get
359− h <- get
360− return (PkgOutline a b c d e f g h)
361−
362−
363−instance Binary Exposed where
396+instance Binary SrcDir where
364− put exposed =
397+ put outline =
365− case exposed of
398+ case outline of
366− ExposedList a -> putWord8 0 >> put a
399+ AbsoluteSrcDir a -> putWord8 0 >> put a
367− ExposedDict a -> putWord8 1 >> put a
400+ RelativeSrcDir a -> putWord8 1 >> put a
368
401
369 get =
402 get =
370 do n <- getWord8
403 do n <- getWord8
371 case n of
404 case n of
372− 0 -> liftM ExposedList get
405+ 0 -> liftM AbsoluteSrcDir get
373− 1 -> liftM ExposedDict get
406+ 1 -> liftM RelativeSrcDir get
374− _ -> error "binary encoding of ProjectDeps was corrupted"
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+1625−366
@@ -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,59 +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
37−import qualified Data.Utf8 as Utf8
35+import qualified Data.Map as Map
36+import qualified Data.Name as N
37+import qualified Data.NonEmptyList as NE
38+import qualified Network.HTTP.Client as HTTP
39+import qualified Network.HTTP.Types.Header as HTTP
40+import qualified Network.HTTP.Types.Status as HTTP
41+import qualified System.FilePath as FP
42+import System.FilePath ((</>), (<.>))
38
43
39import qualified Elm.Constraint as C
44import qualified Elm.Constraint as C
40import qualified Elm.Magnitude as M
45import qualified Elm.Magnitude as M
41import qualified Elm.ModuleName as ModuleName
46import qualified Elm.ModuleName as ModuleName
42import qualified Elm.Package as Pkg
47import qualified Elm.Package as Pkg
43import qualified Elm.Version as V
48import qualified Elm.Version as V
49+import qualified File
44import qualified Http
50import qualified Http
51+import qualified Json.Decode as Decode
45import 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
46import Reporting.Doc ((<>))
56import Reporting.Doc ((<>))
47import qualified Reporting.Doc as D
57import qualified Reporting.Doc as D
58+import qualified Reporting.Error.Import as Import
48import qualified Reporting.Error.Json as Json
59import qualified Reporting.Error.Json as Json
49import qualified Reporting.Exit.Help as Help
60import qualified Reporting.Exit.Help as Help
50−import qualified Reporting.Problem as Problem
61+import qualified Reporting.Error as Error
62+import qualified Reporting.Render.Code as Code
51
63
52
64
53
65
54−-- ALL POSSIBLE ERRORS
66+-- RENDERERS
55
67
56
68
57−data Exit
69+toString :: Help.Report -> String
58− -- bump
70+toString report =
59− = BumpApplication
71+ Help.toString (Help.reportToDoc report)
60− | BumpUnexpectedVersion V.Version [V.Version]
61− | BumpMustHaveLatestRegistry RegistryProblem
62− | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
63− -- publish
64− | PublishMustHaveLatestRegistry RegistryProblem
65− | PublishApplication
66− | PublishNotInitialVersion V.Version
67− | PublishAlreadyPublished V.Version
68− | PublishInvalidBump V.Version V.Version
69− | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
70− | PublishNoSummary
71− | PublishNoExposed
72− | PublishNoReadme
73− | PublishShortReadme
74− | PublishNoLicense
75− | PublishCannotGetTag Http.Error
76− | PublishCannotGetZip Http.Error
77− | PublishCannotDecodeZip
78− | PublishCannotGetDocs DocsProblem
79− | PublishCannotRegister Http.Error
80− | PublishMissingTag V.Version
81− | PublishNoGit
82− | PublishLocalChanges V.Version
83
72
84
73
85−data DocsProblem
74+toStderr :: Help.Report -> IO ()
86− = DP_Http Http.Error
75+toStderr report =
87− | DP_Data
76+ Help.toStderr (Help.reportToDoc report)
88− | DP_Cache
77+
78+
79+toJson :: Help.Report -> Encode.Value
80+toJson report =
81+ Help.reportToJson report
89
82
90
83
91
84
@@ -116,13 +109,18 @@ initToReport exit =
116
109
117 InitNoOfflineSolution pkgs ->
110 InitNoOfflineSolution pkgs ->
118 Help.report "NO OFFLINE SOLUTION" Nothing
111 Help.report "NO OFFLINE SOLUTION" Nothing
119− (error "TODO InitNoOfflineSolution" pkgs)
112+ "I tried to create an elm.json with the following direct dependencies:"
120− (error "TODO InitNoOfflineSolution" pkgs)
113+ [ D.indent 4 $ D.vcat $
121− -- note about Russia IP addresses?
114+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
122− -- 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+ ]
123
121
124 InitSolverProblem solver ->
122 InitSolverProblem solver ->
125− error "TODO InitSolverProblem" solver
123+ toSolverReport solver
126
124
127 InitAlreadyExists ->
125 InitAlreadyExists ->
128 Help.report "EXISTING PROJECT" Nothing
126 Help.report "EXISTING PROJECT" Nothing
@@ -133,8 +131,9 @@ initToReport exit =
133 ]
131 ]
134 ]
132 ]
135
133
136− InitRegistryProblem _ ->
134+ InitRegistryProblem problem ->
137− error "TODO InitRegistryProblem"
135+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
136+ "I need the list of published packages before I can start initializing projects"
138
137
139
138
140
139
@@ -142,22 +141,48 @@ initToReport exit =
142
141
143
142
144data Diff
143data Diff
144+ = DiffNoOutline
145+ | DiffBadOutline Outline
145− = DiffApplication
146+ | DiffApplication
147+ | DiffNoExposed
146 | DiffUnpublished
148 | DiffUnpublished
147 | DiffUnknownPackage Pkg.Name [Pkg.Name]
149 | DiffUnknownPackage Pkg.Name [Pkg.Name]
148 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
149− | DiffCannotFindDocs DocsProblem
151+ | DiffDocsProblem V.Version DocsProblem
150 | DiffMustHaveLatestRegistry RegistryProblem
152 | DiffMustHaveLatestRegistry RegistryProblem
153+ | DiffBadDetails Details
154+ | DiffBadBuild BuildProblem
151
155
152
156
153diffToReport :: Diff -> Help.Report
157diffToReport :: Diff -> Help.Report
154diffToReport diff =
158diffToReport diff =
155 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+
156 DiffApplication ->
171 DiffApplication ->
157− Help.report "CANNOT DIFF APPLICATIONS" Nothing
172+ Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
158− "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!"
159− \ 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:"
160− [ 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."
161 ]
186 ]
162
187
163 DiffUnpublished ->
188 DiffUnpublished ->
@@ -169,16 +194,16 @@ diffToReport diff =
169 Help.report "UNKNOWN PACKAGE" Nothing
194 Help.report "UNKNOWN PACKAGE" Nothing
170 ( "I cannot find a package called:"
195 ( "I cannot find a package called:"
171 )
196 )
172− [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg
197+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
173 , "Maybe you want one of these instead?"
198 , "Maybe you want one of these instead?"
174− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
199+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
175 , "But check <https://package.elm-lang.org> to see all possibilities!"
200 , "But check <https://package.elm-lang.org> to see all possibilities!"
176 ]
201 ]
177
202
178 DiffUnknownVersion _pkg vsn realVersions ->
203 DiffUnknownVersion _pkg vsn realVersions ->
179 Help.docReport "UNKNOWN VERSION" Nothing
204 Help.docReport "UNKNOWN VERSION" Nothing
180 ( D.fillSep $
205 ( D.fillSep $
181− [ "Version", D.red (D.fromUtf8 (V.toString vsn))
206+ [ "Version", D.red (D.fromVersion vsn)
182 , "has", "never", "been", "published,", "so", "I"
207 , "has", "never", "been", "published,", "so", "I"
183 , "cannot", "diff", "against", "it."
208 , "cannot", "diff", "against", "it."
184 ]
209 ]
@@ -187,230 +212,57 @@ diffToReport diff =
187 , D.indent 4 $ D.dullyellow $ D.vcat $
212 , D.indent 4 $ D.dullyellow $ D.vcat $
188 let
213 let
189 sameMajor v1 v2 = V._major v1 == V._major v2
214 sameMajor v1 v2 = V._major v1 == V._major v2
190− mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns
215+ mkRow vsns = D.hsep $ map D.fromVersion vsns
191 in
216 in
192 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
217 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
193 , "Want one of those instead?"
218 , "Want one of those instead?"
194 ]
219 ]
195
220
196− DiffCannotFindDocs problem ->
221+ DiffDocsProblem version problem ->
197− error "TODO DiffCannotFindDocs" problem
222+ toDocsProblemReport problem $
223+ "I need the docs for " ++ V.toChars version ++ " to compute this diff"
198
224
199 DiffMustHaveLatestRegistry problem ->
225 DiffMustHaveLatestRegistry problem ->
200− error "TODO DiffMustHaveLatestRegistry" problem
226+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
227+ "I need the latest list of published packages before I do this diff"
201
228
229+ DiffBadDetails details ->
230+ toDetailsReport details
202
231
232+ DiffBadBuild buildProblem ->
233+ toBuildProblemReport buildProblem
203
234
204−-- INSTALL
205
235
206
236
207−data Install
237+-- BUMP
208− = InstallNoProject
209− | InstallNoArgs FilePath
210− | InstallNoOnlineSolution
211− | InstallNoOfflineSolution
212− | InstallHadSolverTrouble Solver
213− | InstallUnknownPackageOnline [Pkg.Name]
214− | InstallUnknownPackageOffline [Pkg.Name]
215− | InstallHasBadDetails Details
216
238
217
239
218−installToReport :: Install -> Help.Report
240+data Bump
219−installToReport exit =
241+ = BumpNoOutline
220− case exit of
242+ | BumpBadOutline Outline
221− InstallNoProject ->
243+ | BumpApplication
222− Help.report "NEW PROJECT?" Nothing
244+ | BumpUnexpectedVersion V.Version [V.Version]
223− "Are you trying to start a new project? Try this command instead:"
245+ | BumpMustHaveLatestRegistry RegistryProblem
224− [ D.indent 4 $ D.green "elm init"
246+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
225− , D.reflow "It will help you get started!"
247+ | BumpBadDetails Details
226− ]
248+ | BumpNoExposed
249+ | BumpBadBuild BuildProblem
227
250
228− InstallNoArgs elmHome ->
229− Help.report "INSTALL WHAT?" Nothing
230− "I am expecting commands like:"
231− [ D.green $ D.indent 4 $ D.vcat $
232− [ "elm install elm/http"
233− , "elm install elm/json"
234− , "elm install elm/random"
235− ]
236− , D.toFancyHint
237− ["In","JavaScript","folks","run","`npm install`","to","start","projects."
238− ,"\"Gotta","download","everything!\"","But","why","download","packages"
239− ,"again","and","again?","Instead,","Elm","caches","packages","in"
240− ,D.dullyellow (D.fromChars elmHome)
241− ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
242− ,"Elm","projects","check","that","cache","before","trying","the","internet."
243− ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
244− ,"easier","to","work","offline.","As","a","result"
245− ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
246− ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
247− ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
248− ]
249− ]
250
251
251− InstallNoOnlineSolution ->
252+bumpToReport :: Bump -> Help.Report
252− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO recommend using solver in `elm reactor`
253+bumpToReport bump =
253− "This usually happens if you try to modify dependency constraints by\
254+ case bump of
254− \ hand. I recommend deleting any dependency you added recently (or all\
255+ BumpNoOutline ->
255− \ of them if things are bad) and then adding them again with:"
256+ Help.report "BUMP WHAT?" Nothing
256− [ 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."
257− , D.reflow $
258+ [ D.reflow $
258− "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."
259 ]
262 ]
260
263
261− InstallNoOfflineSolution ->
264+ BumpBadOutline outline ->
262− error "TODO InstallNoOfflineSolution"
265+ toOutlineReport outline
263−
264− InstallHadSolverTrouble solver ->
265− error "TODO InstallHadSolverTrouble" solver
266−
267− InstallUnknownPackageOnline suggestions ->
268− error "TODO InstallUnknownPackageOnline" suggestions
269−
270− InstallUnknownPackageOffline suggestions ->
271− error "TODO InstallUnknownPackageOffline" suggestions
272−
273− InstallHasBadDetails _ ->
274− error "TODO InstallHasBadDetails"
275−
276−
277−{- TODO detect if library has no 0.19.0 version. Maybe do this on website though?
278− Help.report "OLD DEPENDENCIES" (Just "elm.json")
279− ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
280− )
281− [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
282− , D.reflow $
283− "This may be because it is not upgraded yet. It may be because a\
284− \ better solution came along, so there was no need to upgrade it.\
285− \ Etc. Try asking around on Slack to learn more about the topic."
286− , D.toSimpleNote
287− "Whatever the case, please be kind to the relevant package authors! Having\
288− \ friendly interactions with users is great motivation, and conversely, getting\
289− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
290− \ authors are humans with families, friends, jobs, vacations, responsibilities,\
291− \ goals, etc. They face obstacles outside of their technical work you will never\
292− \ know about, so please assume the best and try to be patient and supportive!"
293− ]
294−-}
295−
296−
297−
298−-- SOLVER
299−
300−
301−data Solver
302− = SolverBadCacheData Pkg.Name V.Version
303− | SolverBadHttpData Pkg.Name V.Version
304− | SolverBadHttp Http.Error
305−
306−
307−
308−-- OUTLINE
309−
310−
311−data Outline
312− = OutlineHasBadStructure (Json.Error OutlineProblem)
313− | OutlineHasBadSrcDirs FilePath [FilePath]
314−
315−
316−data OutlineProblem
317− = OP_BadType Utf8.String
318− | OP_BadPkgName Pkg.BadName
319− | OP_BadVersion Utf8.String
320− | OP_BadConstraint C.Error
321− | OP_BadModuleName Utf8.String
322− | OP_BadModuleHeaderTooLong Utf8.String
323− | OP_BadDependencyName Utf8.String
324− | OP_BadLicense Utf8.String [Utf8.String]
325− | OP_BadSummaryTooLong
326−
327−
328−
329−-- DETAILS
330−
331−
332−data Details
333− = DetailsCorrupt
334− | DetailsNoSolution
335− | DetailsNoOfflineSolution
336− | DetailsSolverProblem Solver
337− | DetailsBadElmInPkg C.Constraint
338− | DetailsBadElmInAppOutline V.Version
339− | DetailsHandEditedDependencies
340− | DetailsBadOutline Outline
341− | DetailsCannotGetRegistry RegistryProblem
342− | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem
343−
344−
345−data RegistryProblem
346− = RP_Http Http.Error
347− | RP_Data
348−
349−
350−data PackageProblem
351− = PP_BadEndpointRequest Http.Error
352− | PP_BadEndpointContent
353− | PP_BadArchiveRequest Http.Error
354− | PP_BadArchiveContent
355− | PP_BadArchiveHash String String
356−
357−
358−
359−-- MAKE
360−
361−
362−data Make
363− = MakeNeedsOutline
364− | MakeCannotOptimizeAndDebug
365− | MakeBlockedByDetailsProblem Details
366− | MakeAppNeedsFileNames
367− | MakePkgNeedsExposing
368− | MakeMultipleFilesIntoHtml
369− | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
370− | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
371− | MakeCannotBuild BuildProblem
372− | MakeCannotLoadArtifacts
373−
374−
375−data BuildProblem
376− = BuildModuleProblems Problem.Problem [Problem.Problem]
377− | BuildProjectProblem BuildProjectProblem
378−
379−
380−data BuildProjectProblem
381− = BP_PathUnknown FilePath
382− | BP_WithBadExtension FilePath
383− | BP_WithAmbiguousSrcDir FilePath FilePath
384− | BP_MainPathDuplicate FilePath FilePath
385− | BP_MainNameDuplicate ModuleName.Raw FilePath FilePath
386− | BP_CannotLoadDependencies
387− | BP_Cycle ModuleName.Raw [ModuleName.Raw]
388−
389−
390−
391−-- RENDERERS
392−
393−
394−toString :: Help.Report -> String
395−toString report =
396− Help.toString (Help.reportToDoc report)
397−
398−
399−toStderr :: Help.Report -> IO ()
400−toStderr report =
401− Help.toStderr (Help.reportToDoc report)
402−
403−
404−toJson :: Help.Report -> Encode.Value
405−toJson report =
406− Help.reportToJson report
407−
408−
409−_toReport :: Exit -> Help.Report
410−_toReport exit =
411− case exit of
412−
413− -- bump
414
266
415 BumpApplication ->
267 BumpApplication ->
416 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
268 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
@@ -422,7 +274,7 @@ _toReport exit =
422 Help.docReport "CANNOT BUMP" (Just "elm.json")
274 Help.docReport "CANNOT BUMP" (Just "elm.json")
423 ( D.fillSep
275 ( D.fillSep
424 ["Your","elm.json","says","I","should","bump","relative","to","version"
276 ["Your","elm.json","says","I","should","bump","relative","to","version"
425− ,D.red (D.fromUtf8 (V.toString vsn)) <> ","
277+ ,D.red (D.fromVersion vsn) <> ","
426 ,"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>."
427 ,"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"
428 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
280 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
@@ -431,19 +283,116 @@ _toReport exit =
431 [ D.fillSep $
283 [ D.fillSep $
432 ["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"]
433 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
285 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
434− , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions
286+ , D.vcat $ map (D.green . D.fromVersion) versions
435 ]
287 ]
436
288
437 BumpMustHaveLatestRegistry problem ->
289 BumpMustHaveLatestRegistry problem ->
438− error "TODO BumpMustHaveLatestRegistry" problem
290+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
291+ "I need the latest list of published packages before I can bump any versions"
292+
293+ BumpCannotFindDocs _ version problem ->
294+ toDocsProblemReport problem $
295+ "I need the docs for " ++ V.toChars version ++ " to compute the next version number"
296+
297+ BumpBadDetails details ->
298+ toDetailsReport details
299+
300+ BumpNoExposed ->
301+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
302+ ( D.fillSep $
303+ [ "To", "bump", "a", "package,", "the"
304+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
305+ , "elm.json", "must", "list", "at", "least", "one", "module."
306+ ]
307+ )
308+ [ D.reflow $
309+ "Try adding some modules back to the \"exposed-modules\" field."
310+ ]
311+
312+ BumpBadBuild problem ->
313+ toBuildProblemReport problem
314+
315+
316+
317+-- OVERVIEW OF VERSIONING
318+
319+
320+newPackageOverview :: String
321+newPackageOverview =
322+ unlines
323+ [ "This package has never been published before. Here's how things work:"
324+ , ""
325+ , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
326+ , ""
327+ , " - All packages start with initial version " ++ V.toChars V.one
328+ , ""
329+ , " - Versions are incremented based on how the API changes:"
330+ , ""
331+ , " PATCH = the API is the same, no risk of breaking code"
332+ , " MINOR = values have been added, existing values are unchanged"
333+ , " MAJOR = existing values have been changed or removed"
334+ , ""
335+ , " - I will bump versions for you, automatically enforcing these rules"
336+ , ""
337+ ]
338+
339+
340+
341+-- PUBLISH
342+
343+
344+data Publish
345+ = PublishNoOutline
346+ | PublishBadOutline Outline
347+ | PublishBadDetails Details
348+ | PublishMustHaveLatestRegistry RegistryProblem
349+ | PublishApplication
350+ | PublishNotInitialVersion V.Version
351+ | PublishAlreadyPublished V.Version
352+ | PublishInvalidBump V.Version V.Version
353+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
354+ | PublishNoSummary
355+ | PublishNoExposed
356+ | PublishNoReadme
357+ | PublishShortReadme
358+ | PublishNoLicense
359+ | PublishBuildProblem BuildProblem
360+ | PublishMissingTag V.Version
361+ | PublishCannotGetTag V.Version Http.Error
362+ | PublishCannotGetTagData V.Version String BS.ByteString
363+ | PublishCannotGetZip Http.Error
364+ | PublishCannotDecodeZip String
365+ | PublishCannotGetDocs V.Version V.Version DocsProblem
366+ | PublishCannotRegister Http.Error
367+ | PublishNoGit
368+ | PublishLocalChanges V.Version
369+ --
370+ | PublishZipBadDetails Details
371+ | PublishZipApplication
372+ | PublishZipNoExposed
373+ | PublishZipBuildProblem BuildProblem
374+
375+
376+publishToReport :: Publish -> Help.Report
377+publishToReport publish =
378+ case publish of
379+ PublishNoOutline ->
380+ Help.report "PUBLISH WHAT?" Nothing
381+ "I cannot find an elm.json so I am not sure what you want me to publish."
382+ [ D.reflow $
383+ "Elm packages always have an elm.json that states the version number,\
384+ \ dependencies, exposed modules, etc."
385+ ]
439
386
440− BumpCannotFindDocs name version problem ->
387+ PublishBadOutline outline ->
441− error "TODO BumpCannotFindDocs" name version problem
388+ toOutlineReport outline
442
389
443− -- publish
390+ PublishBadDetails problem ->
391+ toDetailsReport problem
444
392
445 PublishMustHaveLatestRegistry problem ->
393 PublishMustHaveLatestRegistry problem ->
446− error "TODO PublishMustHaveLatestRegistry" problem
394+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
395+ "I need the latest list of published packages to make sure this is safe to publish"
447
396
448 PublishApplication ->
397 PublishApplication ->
449 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
398 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
@@ -452,7 +401,7 @@ _toReport exit =
452 Help.docReport "INVALID VERSION" Nothing
401 Help.docReport "INVALID VERSION" Nothing
453 ( D.fillSep
402 ( D.fillSep
454 ["I","cannot","publish"
403 ["I","cannot","publish"
455− ,D.red (D.fromUtf8 (V.toString vsn))
404+ ,D.red (D.fromVersion vsn)
456 ,"as","the","initial","version."
405 ,"as","the","initial","version."
457 ]
406 ]
458 )
407 )
@@ -466,7 +415,7 @@ _toReport exit =
466 Help.docReport "ALREADY PUBLISHED" Nothing
415 Help.docReport "ALREADY PUBLISHED" Nothing
467 ( D.vcat
416 ( D.vcat
468 [ D.fillSep
417 [ D.fillSep
469− [ "Version", D.green (D.fromUtf8 (V.toString vsn))
418+ [ "Version", D.green (D.fromVersion vsn)
470 , "has", "already", "been", "published.", "You", "cannot"
419 , "has", "already", "been", "published.", "You", "cannot"
471 , "publish", "it", "again!"
420 , "publish", "it", "again!"
472 ]
421 ]
@@ -483,14 +432,14 @@ _toReport exit =
483 Help.docReport "INVALID VERSION" (Just "elm.json")
432 Help.docReport "INVALID VERSION" (Just "elm.json")
484 ( D.fillSep $
433 ( D.fillSep $
485 ["Your","elm.json","says","the","next","version","should","be"
434 ["Your","elm.json","says","the","next","version","should","be"
486− ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","
435+ ,D.red (D.fromVersion statedVersion) <> ","
487 ,"but","that","is","not","valid","based","on","the","previously"
436 ,"but","that","is","not","valid","based","on","the","previously"
488 ,"published","versions."
437 ,"published","versions."
489 ]
438 ]
490 )
439 )
491 [ D.fillSep $
440 [ D.fillSep $
492 ["Change","the","version","back","to"
441 ["Change","the","version","back","to"
493− ,D.green (D.fromUtf8 (V.toString latestVersion))
442+ ,D.green (D.fromVersion latestVersion)
494 ,"which","is","the","most","recently","published","version."
443 ,"which","is","the","most","recently","published","version."
495 ,"From","there,","have","Elm","bump","the","version","by","running:"
444 ,"From","there,","have","Elm","bump","the","version","by","running:"
496 ]
445 ]
@@ -505,7 +454,7 @@ _toReport exit =
505 (
454 (
506 D.fillSep $
455 D.fillSep $
507 ["Your","elm.json","says","the","next","version","should","be"
456 ["Your","elm.json","says","the","next","version","should","be"
508− ,D.red (D.fromUtf8 (V.toString new)) <> ","
457+ ,D.red (D.fromVersion new) <> ","
509 ,"indicating","a",D.fromChars (M.toChars magnitude)
458 ,"indicating","a",D.fromChars (M.toChars magnitude)
510 ,"change","to","the","public","API."
459 ,"change","to","the","public","API."
511 ,"This","does","not","match","the","API","diff","given","by:"
460 ,"This","does","not","match","the","API","diff","given","by:"
@@ -518,7 +467,7 @@ _toReport exit =
518 ["This","command","says","this","is","a"
467 ["This","command","says","this","is","a"
519 ,D.fromChars (M.toChars realMagnitude)
468 ,D.fromChars (M.toChars realMagnitude)
520 ,"change,","so","the","next","version","should","be"
469 ,"change,","so","the","next","version","should","be"
521− ,D.green (D.fromUtf8 (V.toString realNew)) <> "."
470+ ,D.green (D.fromVersion realNew) <> "."
522 ,"Double","check","everything","to","make","sure","you"
471 ,"Double","check","everything","to","make","sure","you"
523 ,"are","publishing","what","you","want!"
472 ,"are","publishing","what","you","want!"
524 ]
473 ]
@@ -548,16 +497,17 @@ _toReport exit =
548 ]
497 ]
549 )
498 )
550 [ D.reflow $
499 [ D.reflow $
551− "What is the point of a package that has no modules?!"
500+ "Which modules do you want users of the package to have access to? Add their\
501+ \ names to the \"exposed-modules\" list."
552 ]
502 ]
553
503
554 PublishNoReadme ->
504 PublishNoReadme ->
555− badReadmeReport "NO README" $
505+ toBadReadmeReport "NO README" $
556 "Every published package must have a helpful README.md\
506 "Every published package must have a helpful README.md\
557 \ file, but I do not see one in your project."
507 \ file, but I do not see one in your project."
558
508
559 PublishShortReadme ->
509 PublishShortReadme ->
560− badReadmeReport "SHORT README" $
510+ toBadReadmeReport "SHORT README" $
561 "This README.md is too short. Having more details will help\
511 "This README.md is too short. Having more details will help\
562 \ people assess your package quickly and fairly."
512 \ people assess your package quickly and fairly."
563
513
@@ -574,20 +524,8 @@ _toReport exit =
574 \ named LICENSE. Add that file and you will be all set!"
524 \ named LICENSE. Add that file and you will be all set!"
575 ]
525 ]
576
526
577− PublishCannotGetTag httpError ->
527+ PublishBuildProblem buildProblem ->
578− error "TODO PublishCannotGetTag" httpError
528+ toBuildProblemReport buildProblem
579−
580− PublishCannotGetZip httpError ->
581− error "TODO PublishCannotGetZip" httpError
582−
583− PublishCannotDecodeZip ->
584− error "TODO PublishCannotDecodeZip"
585−
586− PublishCannotGetDocs docsProblem ->
587− error "TODO PublishCannotGetDocs" docsProblem
588−
589− PublishCannotRegister httpError ->
590− error "TODO PublishCannotRegister" httpError
591
529
592 PublishMissingTag version ->
530 PublishMissingTag version ->
593 let vsn = V.toChars version in
531 let vsn = V.toChars version in
@@ -608,6 +546,70 @@ _toReport exit =
608 , "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!"
609 ]
547 ]
610
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+
611 PublishNoGit ->
613 PublishNoGit ->
612 Help.report "NO GIT" Nothing
614 Help.report "NO GIT" Nothing
613 "I searched your PATH environment variable for `git` and could not\
615 "I searched your PATH environment variable for `git` and could not\
@@ -637,9 +639,21 @@ _toReport exit =
637 ++ vsn ++ "` and publish your code from there."
639 ++ vsn ++ "` and publish your code from there."
638 ]
640 ]
639
641
642+ PublishZipBadDetails _ ->
643+ badZipReport
640
644
645+ PublishZipApplication ->
646+ badZipReport
647+
648+ PublishZipNoExposed ->
649+ badZipReport
650+
651+ PublishZipBuildProblem _ ->
652+ badZipReport
653+
654+
641−badReadmeReport :: String -> String -> Help.Report
655+toBadReadmeReport :: String -> String -> Help.Report
642−badReadmeReport title summary =
656+toBadReadmeReport title summary =
643 Help.report title (Just "README.md") summary
657 Help.report title (Just "README.md") summary
644 [ D.reflow $
658 [ D.reflow $
645 "When people look at your README, they are wondering:"
659 "When people look at your README, they are wondering:"
@@ -652,32 +666,653 @@ badReadmeReport title summary =
652 \ most common usage scenario. Show people what they can expect if\
666 \ most common usage scenario. Show people what they can expect if\
653 \ they learn more!"
667 \ they learn more!"
654 , D.toSimpleNote $
668 , D.toSimpleNote $
655− "By publishing your package, you are inviting people to invest time\
669+ "By publishing your package, you are inviting people to invest time in\
656− \ in understanding your work. Spending an hour to communicate your\
670+ \ understanding your work. Spending an hour on your README to communicate your\
657− \ 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\
658− \ 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\
659− \ publishing packages! People really appreciate it, and it makes the\
673+ \ packages! People really appreciate it, and it makes the whole ecosystem feel\
660− \ whole ecosystem feel nicer!"
674+ \ nicer!"
675+ ]
676+
677+
678+badZipReport :: Help.Report
679+badZipReport =
680+ Help.report "PROBLEM VERIFYING PACKAGE" Nothing
681+ "Before publishing packages, I download the code from GitHub and try to build it\
682+ \ from scratch. That way I can be more confident that it will work for other\
683+ \ people too. But I am not able to build it!"
684+ [ D.reflow $
685+ "I was just able to build your local copy though. Is there some way the version\
686+ \ on GitHub could be different?"
661 ]
687 ]
662
688
663
689
664
690
665−-- DETAILS TO REPORT
691+-- DOCS
692+
693+
694+data DocsProblem
695+ = DP_Http Http.Error
696+ | DP_Data String BS.ByteString
697+ | DP_Cache
698+
699+
700+toDocsProblemReport :: DocsProblem -> String -> Help.Report
701+toDocsProblemReport problem context =
702+ case problem of
703+ DP_Http httpError ->
704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705+
706+ DP_Data url body ->
707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
709+ , D.reflow $
710+ "I got the data back, but it was not what I was expecting. The response\
711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713+ , D.indent 4 $ D.dullyellow $ D.fromChars $
714+ if BS.length body <= 76
715+ then BS_UTF8.toString body
716+ else take 73 (BS_UTF8.toString body) ++ "..."
717+ , D.reflow $
718+ "Does this error keep showing up? Maybe there is something weird with your\
719+ \ internet connection. We have gotten reports that schools, businesses,\
720+ \ airports, etc. sometimes intercept requests and add things to the body\
721+ \ or change its contents entirely. Could that be the problem?"
722+ ]
723+
724+ DP_Cache ->
725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726+ [ D.reflow $
727+ "I deleted the cached version, so the next run should download a fresh copy of\
728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730+ \ for some reason."
731+ ]
732+
733+
734+
735+-- INSTALL
736+
737+
738+data Install
739+ = InstallNoOutline
740+ | InstallBadOutline Outline
741+ | InstallBadRegistry RegistryProblem
742+ | InstallNoArgs FilePath
743+ | InstallNoOnlineAppSolution Pkg.Name
744+ | InstallNoOfflineAppSolution Pkg.Name
745+ | InstallNoOnlinePkgSolution Pkg.Name
746+ | InstallNoOfflinePkgSolution Pkg.Name
747+ | InstallHadSolverTrouble Solver
748+ | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
749+ | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
750+ | InstallBadDetails Details
751+
752+
753+installToReport :: Install -> Help.Report
754+installToReport exit =
755+ case exit of
756+ InstallNoOutline ->
757+ Help.report "NEW PROJECT?" Nothing
758+ "Are you trying to start a new project? Try this command instead:"
759+ [ D.indent 4 $ D.green "elm init"
760+ , D.reflow "It will help you get started!"
761+ ]
666
762
763+ InstallBadOutline outline ->
764+ toOutlineReport outline
667
765
668−detailsToReport :: Details -> Help.Report
766+ InstallBadRegistry problem ->
669−detailsToReport details =
767+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
768+ "I need the list of published packages to figure out how to install things"
769+
770+ InstallNoArgs elmHome ->
771+ Help.report "INSTALL WHAT?" Nothing
772+ "I am expecting commands like:"
773+ [ D.green $ D.indent 4 $ D.vcat $
774+ [ "elm install elm/http"
775+ , "elm install elm/json"
776+ , "elm install elm/random"
777+ ]
778+ , D.toFancyHint
779+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."
780+ ,"\"Gotta","download","everything!\"","But","why","download","packages"
781+ ,"again","and","again?","Instead,","Elm","caches","packages","in"
782+ ,D.dullyellow (D.fromChars elmHome)
783+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
784+ ,"Elm","projects","check","that","cache","before","trying","the","internet."
785+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
786+ ,"easier","to","work","offline.","As","a","result"
787+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
788+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
789+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
790+ ]
791+ ]
792+
793+ InstallNoOnlineAppSolution pkg ->
794+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
795+ (
796+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
797+ \ with your existing dependencies."
798+ )
799+ [ D.reflow $
800+ "I checked all the published versions. When that failed, I tried to find any\
801+ \ compatible combination of these packages, even if it meant changing all your\
802+ \ existing dependencies! That did not work either!"
803+ , D.reflow $
804+ "This is most likely to happen when a package is not upgraded yet. Maybe a new\
805+ \ version of Elm came out recently? Maybe a common package was changed recently?\
806+ \ Maybe a better package came along, so there was no need to upgrade this one?\
807+ \ Try asking around https://elm-lang.org/community to learn what might be going on\
808+ \ with this package."
809+ , D.toSimpleNote $
810+ "Whatever the case, please be kind to the relevant package authors! Having\
811+ \ friendly interactions with users is great motivation, and conversely, getting\
812+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
813+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
814+ \ goals, etc. They face obstacles outside of their technical work you will never\
815+ \ know about, so please assume the best and try to be patient and supportive!"
816+ ]
817+
818+ InstallNoOfflineAppSolution pkg ->
819+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
820+ (
821+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
822+ \ with your existing dependencies."
823+ )
824+ [ D.reflow $
825+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
826+ \ able to look through packages that you have downloaded in the past."
827+ , D.reflow $
828+ "Try again later when you have internet!"
829+ ]
830+
831+ InstallNoOnlinePkgSolution pkg ->
832+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
833+ (
834+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
835+ \ with your existing constraints."
836+ )
837+ [ D.reflow $
838+ "With applications, I try to broaden the constraints to see if anything works,\
839+ \ but messing with package constraints is much more delicate business. E.g. making\
840+ \ your constraints stricter may make it harder for applications to find compatible\
841+ \ dependencies. So fixing something here may break it for a lot of other people!"
842+ , D.reflow $
843+ "So I recommend making an application with the same dependencies as your package.\
844+ \ See if there is a solution at all. From there it may be easier to figure out\
845+ \ how to proceed in a way that will disrupt your users as little as possible. And\
846+ \ the solution may be to help other package authors to get their packages updated,\
847+ \ or to drop a dependency entirely."
848+ ]
849+
850+ InstallNoOfflinePkgSolution pkg ->
851+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
852+ (
853+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
854+ \ with your existing constraints."
855+ )
856+ [ D.reflow $
857+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
858+ \ able to look through packages that you have downloaded in the past."
859+ , D.reflow $
860+ "Try again later when you have internet!"
861+ ]
862+
863+ InstallHadSolverTrouble solver ->
864+ toSolverReport solver
865+
866+ InstallUnknownPackageOnline pkg suggestions ->
867+ Help.docReport "UNKNOWN PACKAGE" Nothing
868+ (
869+ D.fillSep
870+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
871+ )
872+ [ D.reflow $
873+ "I looked through https://package.elm-lang.org for packages with similar names\
874+ \ and found these:"
875+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
876+ , D.reflow $ "Maybe you want one of these instead?"
877+ ]
878+
879+ InstallUnknownPackageOffline pkg suggestions ->
880+ Help.docReport "UNKNOWN PACKAGE" Nothing
881+ (
882+ D.fillSep
883+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
884+ )
885+ [ D.reflow $
886+ "I could not connect to https://package.elm-lang.org though, so new packages may\
887+ \ have been published since I last updated my local cache of package names."
888+ , D.reflow $
889+ "Looking through the locally cached names, the closest ones are:"
890+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
891+ , D.reflow $ "Maybe you want one of these instead?"
892+ ]
893+
894+ InstallBadDetails details ->
895+ toDetailsReport details
896+
897+
898+
899+-- SOLVER
900+
901+
902+data Solver
903+ = SolverBadCacheData Pkg.Name V.Version
904+ | SolverBadHttpData Pkg.Name V.Version String
905+ | SolverBadHttp Pkg.Name V.Version Http.Error
906+
907+
908+toSolverReport :: Solver -> Help.Report
909+toSolverReport problem =
910+ case problem of
911+ SolverBadCacheData pkg vsn ->
912+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
913+ (
914+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
915+ \ help me search for a set of compatible packages. I had it cached locally, but\
916+ \ it looks like the file was corrupted!"
917+ )
918+ [ D.reflow $
919+ "I deleted the cached version, so the next run should download a fresh copy.\
920+ \ Hopefully that will get you unstuck, but it will not resolve the root\
921+ \ problem if a 3rd party tool is modifing cached files for some reason."
922+ ]
923+
924+ SolverBadHttpData pkg vsn url ->
925+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
926+ (
927+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
928+ \ help me search for a set of compatible packages, but I ran into corrupted\
929+ \ information from:"
930+ )
931+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
932+ , D.reflow $
933+ "Is something weird with your internet connection. We have gotten reports that\
934+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\
935+ \ to the body or change its contents entirely. Could that be the problem?"
936+ ]
937+
938+ SolverBadHttp pkg vsn httpError ->
939+ toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
940+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
941+ ++ " to help me search for a set of compatible packages"
942+
943+
944+
945+-- OUTLINE
946+
947+
948+data Outline
949+ = OutlineHasBadStructure (Decode.Error OutlineProblem)
950+ | OutlineHasMissingSrcDirs FilePath [FilePath]
951+ | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952+ | OutlineNoPkgCore
953+ | OutlineNoAppCore
954+ | OutlineNoAppJson
955+
956+
957+data OutlineProblem
958+ = OP_BadType
959+ | OP_BadPkgName Row Col
960+ | OP_BadVersion Row Col
961+ | OP_BadConstraint C.Error
962+ | OP_BadModuleName Row Col
963+ | OP_BadModuleHeaderTooLong
964+ | OP_BadDependencyName Row Col
965+ | OP_BadLicense Json.String [Json.String]
966+ | OP_BadSummaryTooLong
967+ | OP_NoSrcDirs
968+
969+
970+toOutlineReport :: Outline -> Help.Report
971+toOutlineReport problem =
972+ case problem of
973+ OutlineHasBadStructure decodeError ->
974+ Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
975+ Json.ExplicitReason "I ran into a problem with your elm.json file."
976+
977+ OutlineHasMissingSrcDirs dir dirs ->
978+ case dirs of
979+ [] ->
980+ Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
981+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
982+ [ D.indent 4 $ D.red $ D.fromChars dir
983+ , D.reflow $
984+ "I cannot find it though. Is it missing? Is there a typo?"
985+ ]
986+
987+ _:_ ->
988+ Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
989+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
990+ [ D.indent 4 $ D.vcat $
991+ map (D.red . D.fromChars) (dir:dirs)
992+ , D.reflow $
993+ "I cannot find them though. Are they missing? Are there typos?"
994+ ]
995+
996+ OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
997+ if dir1 == dir2 then
998+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
999+ "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
1000+ [ D.indent 4 $ D.vcat $
1001+ map (D.red . D.fromChars) [dir1,dir2]
1002+ , D.reflow $
1003+ "Remove one of the entries!"
1004+ ]
1005+ else
1006+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
1007+ "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
1008+ [ D.indent 4 $ D.vcat $
1009+ map (D.red . D.fromChars) [dir1,dir2]
1010+ , D.reflow $
1011+ "These are two different ways of refering to the same directory:"
1012+ , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
1013+ , D.reflow $
1014+ "Remove one of the redundant entries from your \"source-directories\" field."
1015+ ]
1016+
1017+ OutlineNoPkgCore ->
1018+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1019+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1020+ \ of `List` and `Maybe` do not work without it."
1021+ [ D.reflow $
1022+ "If you modified your elm.json by hand, try to change it back! And if you are\
1023+ \ having trouble getting back to a working elm.json, it may be easier to find a\
1024+ \ working package and start fresh with their elm.json file."
1025+ ]
1026+
1027+ OutlineNoAppCore ->
1028+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1029+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1030+ \ of `List` and `Maybe` do not work without it."
1031+ [ D.reflow $
1032+ "If you modified your elm.json by hand, try to change it back! And if you are\
1033+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1034+ \ and use `elm init` to start fresh."
1035+ ]
1036+
1037+ OutlineNoAppJson ->
1038+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1039+ "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
1040+ \ flags and ports."
1041+ [ D.reflow $
1042+ "If you modified your elm.json by hand, try to change it back! And if you are\
1043+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1044+ \ and use `elm init` to start fresh."
1045+ ]
1046+
1047+
1048+toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
1049+toOutlineProblemReport path source _ region problem =
1050+ let
1051+ toHighlight row col =
1052+ Just $ A.Region (A.Position row col) (A.Position row col)
1053+
1054+ toSnippet title highlight pair =
1055+ Help.jsonReport title (Just path) $
1056+ Code.toSnippet source region highlight pair
1057+ in
1058+ case problem of
1059+ OP_BadType ->
1060+ toSnippet "UNEXPECTED TYPE" Nothing
1061+ ( D.reflow $
1062+ "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
1063+ , D.fillSep
1064+ ["Try","changing","the","\"type\"","to"
1065+ ,D.green "\"application\"","or",D.green "\"package\"","instead."
1066+ ]
1067+ )
1068+
1069+ OP_BadPkgName row col ->
1070+ toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
1071+ ( D.reflow $
1072+ "I got stuck while reading your elm.json file. I ran into trouble with the package name:"
1073+ , D.stack
1074+ [ D.fillSep
1075+ ["Package","names","are","always","written","as"
1076+ ,D.green "\"author/project\""
1077+ ,"so","I","am","expecting","to","see","something","like:"
1078+ ]
1079+ , D.dullyellow $ D.indent 4 $ D.vcat $
1080+ [ "\"mdgriffith/elm-ui\""
1081+ , "\"w0rm/elm-physics\""
1082+ , "\"Microsoft/elm-json-tree-view\""
1083+ , "\"FordLabs/elm-star-rating\""
1084+ , "\"1602/json-schema\""
1085+ ]
1086+ , D.reflow
1087+ "The author name should match your GitHub name exactly, and the project name\
1088+ \ needs to follow these rules:"
1089+ , D.indent 4 $ D.vcat $
1090+ [ "+--------------------------------------+-----------+-----------+"
1091+ , "| RULE | BAD | GOOD |"
1092+ , "+--------------------------------------+-----------+-----------+"
1093+ , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
1094+ , "| no leading digits | 3D | elm-3d |"
1095+ , "| no non-ASCII characters | elm-bjørn | elm-bear |"
1096+ , "| no underscores | elm_ui | elm-ui |"
1097+ , "| no double hyphens | elm--hash | elm-hash |"
1098+ , "| no starting or ending hyphen | -elm-tar- | elm-tar |"
1099+ , "+--------------------------------------+-----------+-----------+"
1100+ ]
1101+ , D.toSimpleNote $
1102+ "These rules only apply to the project name, so you should never need\
1103+ \ to change your GitHub name!"
1104+ ]
1105+ )
1106+
1107+ OP_BadVersion row col ->
1108+ toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
1109+ ( D.reflow $
1110+ "I got stuck while reading your elm.json file. I was expecting a version number here:"
1111+ , D.fillSep
1112+ ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
1113+ ,"that","explicitly","states","all","three","numbers!"
1114+ ]
1115+ )
1116+
1117+ OP_BadConstraint constraintError ->
1118+ case constraintError of
1119+ C.BadFormat row col ->
1120+ toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
1121+ ( D.reflow $
1122+ "I got stuck while reading your elm.json file. I do not understand this version constraint:"
1123+ , D.stack
1124+ [ D.fillSep
1125+ ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
1126+ ,"that","explicitly","lists","the","lower","and","upper","bounds."
1127+ ]
1128+ , D.toSimpleNote $
1129+ "The spaces in there are required! Taking them out will confuse me. Adding\
1130+ \ extra spaces confuses me too. I recommend starting with a valid example\
1131+ \ and just changing the version numbers."
1132+ ]
1133+ )
1134+
1135+ C.InvalidRange before after ->
1136+ if before == after then
1137+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1138+ ( D.reflow $
1139+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1140+ , D.fillSep
1141+ ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
1142+ ,"so","it","is","best","to","use","wide","constraints.","I","recommend"
1143+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
1144+ ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
1145+ ,"happen","in","any","of","the","versions","in","that","range."
1146+ ]
1147+ )
1148+
1149+ else
1150+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1151+ ( D.reflow $
1152+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1153+ , D.fillSep
1154+ ["Maybe","you","want","something","like"
1155+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
1156+ ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
1157+ ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
1158+ ,"cannot","happen","in","any","of","the","versions","in","that","range."
1159+ ]
1160+ )
1161+
1162+ OP_BadModuleName row col ->
1163+ toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
1164+ ( D.reflow $
1165+ "I got stuck while reading your elm.json file. I was expecting a module name here:"
1166+ , D.fillSep
1167+ ["I","need","something","like",D.green "\"Html.Events\""
1168+ ,"or",D.green "\"Browser.Navigation\""
1169+ ,"where","each","segment","starts","with","a","capital"
1170+ ,"letter","and","the","segments","are","separated","by","dots."
1171+ ]
1172+ )
1173+
1174+ OP_BadModuleHeaderTooLong ->
1175+ toSnippet "HEADER TOO LONG" Nothing
1176+ ( D.reflow $
1177+ "I got stuck while reading your elm.json file. This section header is too long:"
1178+ , D.stack
1179+ [ D.fillSep
1180+ ["I","need","it","to","be"
1181+ ,D.green "under",D.green "20",D.green "bytes"
1182+ ,"so","it","renders","nicely","on","the","package","website!"
1183+ ]
1184+ , D.toSimpleNote
1185+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1186+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1187+ \ overly restrictive for your needs."
1188+ ]
1189+ )
1190+
1191+ OP_BadDependencyName row col ->
1192+ toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
1193+ ( D.reflow $
1194+ "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
1195+ , D.stack
1196+ [ D.fillSep
1197+ ["Package","names","always","include","the","name","of","the","author,"
1198+ ,"so","I","am","expecting","to","see","dependencies","like"
1199+ ,D.dullyellow "\"mdgriffith/elm-ui\"","and"
1200+ ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
1201+ ]
1202+ , D.fillSep $
1203+ ["I","generally","recommend","finding","the","package","you","want","on"
1204+ ,"the","package","website,","and","installing","it","with","the"
1205+ ,D.green "elm install","command!"
1206+ ]
1207+ ]
1208+ )
1209+
1210+ OP_BadLicense _ suggestions ->
1211+ toSnippet "UNKNOWN LICENSE" Nothing
1212+ ( D.reflow $
1213+ "I got stuck while reading your elm.json file. I do not know about this type of license:"
1214+ ,
1215+ D.stack
1216+ [ D.fillSep
1217+ ["Elm","packages","generally","use"
1218+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
1219+ ,"but","I","accept","any","OSI","approved","SPDX","license."
1220+ ,"Here","some","that","seem","close","to","what","you","wrote:"
1221+ ]
1222+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
1223+ , D.reflow $
1224+ "Check out https://spdx.org/licenses/ for the full list of options."
1225+ ]
1226+ )
1227+
1228+ OP_BadSummaryTooLong ->
1229+ toSnippet "SUMMARY TOO LONG" Nothing
1230+ ( D.reflow $
1231+ "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
1232+ , D.stack
1233+ [ D.fillSep
1234+ ["I","need","it","to","be"
1235+ ,D.green "under",D.green "80",D.green "bytes"
1236+ ,"so","it","renders","nicely","on","the","package","website!"
1237+ ]
1238+ , D.toSimpleNote
1239+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1240+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1241+ \ overly restrictive for your needs."
1242+ ]
1243+ )
1244+
1245+ OP_NoSrcDirs ->
1246+ toSnippet "NO SOURCE DIRECTORIES" Nothing
1247+ ( D.reflow $
1248+ "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
1249+ , D.fillSep
1250+ ["I","need","something","like",D.green "[\"src\"]"
1251+ ,"so","I","know","where","to","look","for","your","modules!"
1252+ ]
1253+ )
1254+
1255+
1256+
1257+-- DETAILS
1258+
1259+
1260+data Details
1261+ = DetailsNoSolution
1262+ | DetailsNoOfflineSolution
1263+ | DetailsSolverProblem Solver
1264+ | DetailsBadElmInPkg C.Constraint
1265+ | DetailsBadElmInAppOutline V.Version
1266+ | DetailsHandEditedDependencies
1267+ | DetailsBadOutline Outline
1268+ | DetailsCannotGetRegistry RegistryProblem
1269+ | DetailsBadDeps FilePath [DetailsBadDep]
1270+
1271+
1272+data DetailsBadDep
1273+ = BD_BadDownload Pkg.Name V.Version PackageProblem
1274+ | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)
1275+
1276+
1277+toDetailsReport :: Details -> Help.Report
1278+toDetailsReport details =
670 case details of
1279 case details of
671− DetailsCorrupt ->
1280+ DetailsNoSolution ->
672− 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
673
1308
674 DetailsBadElmInPkg constraint ->
1309 DetailsBadElmInPkg constraint ->
675 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1310 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
676 "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:"
677− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ C.toString constraint
1312+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
678 , D.fillSep
1313 , D.fillSep
679 [ "But", "you", "are", "using", "Elm"
1314 [ "But", "you", "are", "using", "Elm"
680− , D.red (D.fromUtf8 (V.toString V.compiler))
1315+ , D.red (D.fromVersion V.compiler)
681 , "right", "now."
1316 , "right", "now."
682 ]
1317 ]
683 ]
1318 ]
@@ -687,40 +1322,286 @@ detailsToReport details =
687 "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."
688 [ D.fillSep
1323 [ D.fillSep
689 [ "It", "requires"
1324 [ "It", "requires"
690− , D.green (D.fromUtf8 (V.toString version)) <> ","
1325+ , D.green (D.fromVersion version) <> ","
691 , "but", "you", "are", "using"
1326 , "but", "you", "are", "using"
692− , D.red (D.fromUtf8 (V.toString V.compiler))
1327+ , D.red (D.fromVersion V.compiler)
693 , "right", "now."
1328 , "right", "now."
694 ]
1329 ]
695 ]
1330 ]
696
1331
697 DetailsHandEditedDependencies ->
1332 DetailsHandEditedDependencies ->
698− error "TODO DetailsHandEditedDependencies"
1333+ Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
1334+ "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
1335+ \ party tool) leaving them in an invalid state."
1336+ [ D.fillSep
1337+ ["Try","to","change","them","back","to","what","they","were","before!"
1338+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1339+ ]
1340+ , D.reflow $
1341+ "Please ask for help on the community forums if you try those paths and are still\
1342+ \ having problems!"
1343+ ]
699
1344
700− DetailsBadOutline problem ->
1345+ DetailsBadOutline outline ->
701− error "TODO DetailsBadOutline" problem
1346+ toOutlineReport outline
702
1347
703 DetailsCannotGetRegistry problem ->
1348 DetailsCannotGetRegistry problem ->
704− error "TODO DetailsCannotGetRegistry" problem
1349+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
1350+ "I need the list of published packages to verify your dependencies"
1351+
1352+ DetailsBadDeps cacheDir deps ->
1353+ case List.sortOn toBadDepRank deps of
1354+ [] ->
1355+ Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1356+ "I am not sure what is going wrong though."
1357+ [ D.reflow $
1358+ "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
1359+ \ trying to build again. That will work if some cached files got corrupted\
1360+ \ somehow."
1361+ , D.reflow $
1362+ "If that does not work, go to https://elm-lang.org/community and ask for\
1363+ \ help. This is a weird case!"
1364+ ]
705
1365
706− DetailsCannotBuildPackage name version problem ->
1366+ d:_ ->
707− error "TODO DetailsCannotBuildPackage" name version problem
1367+ case d of
1368+ BD_BadDownload pkg vsn packageProblem ->
1369+ toPackageProblemReport pkg vsn packageProblem
708
1370
709− DetailsNoSolution ->
1371+ BD_BadBuild pkg vsn fingerprint ->
710− 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+ ]
711
1391
712− DetailsNoOfflineSolution ->
713− error "TODO DetailsNoOfflineSolution"
714
1392
715− DetailsSolverProblem _ ->
1393+toBadDepRank :: DetailsBadDep -> Int -- lower is better
716− 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+ ]
1434+
1435+ PP_BadArchiveRequest httpError ->
1436+ toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1437+ "I was trying to download the source code for " ++ thePackage
717
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
718
1599
719
1600
720makeToReport :: Make -> Help.Report
1601makeToReport :: Make -> Help.Report
721makeToReport make =
1602makeToReport make =
722 case make of
1603 case make of
723− MakeNeedsOutline ->
1604+ MakeNoOutline ->
724 Help.report "NO elm.json FILE" Nothing
1605 Help.report "NO elm.json FILE" Nothing
725 "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:"
726 [ D.indent 4 $ D.green $ "elm init"
1607 [ D.indent 4 $ D.green $ "elm init"
@@ -741,27 +1622,344 @@ makeToReport make =
741 \ 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!"
742 ]
1623 ]
743
1624
744− MakeBlockedByDetailsProblem detailsProblem ->
1625+ MakeBadDetails detailsProblem ->
745− detailsToReport detailsProblem
1626+ toDetailsReport detailsProblem
746
1627
747 MakeAppNeedsFileNames ->
1628 MakeAppNeedsFileNames ->
748 Help.report "NO INPUT" Nothing
1629 Help.report "NO INPUT" Nothing
749− "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
750− [ 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+ ]
751− , D.reflow
1635+ , D.reflow $
752− "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!"
753 ]
1638 ]
754
1639
755 MakePkgNeedsExposing ->
1640 MakePkgNeedsExposing ->
756− error "TODO MakePkgNeedsExposing"
1641+ Help.report "NO INPUT" Nothing
1642+ "What should I make though? I need specific files like:"
1643+ [ D.vcat
1644+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1645+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1646+ ]
1647+ , D.reflow $
1648+ "You can also entries to the \"exposed-modules\" list in your elm.json file, and\
1649+ \ I will try to compile the relevant files."
1650+ ]
757
1651
758 MakeMultipleFilesIntoHtml ->
1652 MakeMultipleFilesIntoHtml ->
759− error "TODO MakeMultipleFilesIntoHtml"
1653+ Help.report "TOO MANY FILES" Nothing
1654+ (
1655+ "When producing an HTML file, I can only handle one file."
1656+ )
1657+ [ D.fillSep
1658+ ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"
1659+ ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"
1660+ ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."
1661+ ]
1662+ , D.fillSep
1663+ ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"
1664+ ,"`main`","values","available","in","a","single","JavaScript","file.","Then"
1665+ ,"you","can","make","your","own","customized","HTML","file","that","embeds"
1666+ ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"
1667+ ,"dependencies","between","modules,","so","it","should","be","smaller","than"
1668+ ,"compiling","each","module","separately."
1669+ ]
1670+ ]
760
1671
761− MakeNonMainFilesIntoJavaScript _ _ ->
1672+ MakeNoMain ->
762− error "TODO MakeNonMainFilesIntoJavaScript"
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+ ]
763
1695
764− MakeCannotOptimizeDebugValues m ms ->
1696+ MakeNonMainFilesIntoJavaScript m ms ->
1697+ case ms of
1698+ [] ->
1699+ Help.report "NO MAIN" Nothing
1700+ (
1701+ "When producing a JS file, I require that the given file has a `main` value. That\
1702+ \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\
1703+ \ resulting file!"
1704+ )
1705+ [ D.reflow $
1706+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1707+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1708+ \ altogether."
1709+ , D.toSimpleNote $
1710+ "Adding a `main` value can be as brief as adding something like this:"
1711+ , D.vcat
1712+ [ D.fillSep [D.cyan "import","Html"]
1713+ , ""
1714+ , D.fillSep [D.green "main","="]
1715+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1716+ ]
1717+ , D.reflow $
1718+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1719+ \ make a `main` with no user interface."
1720+ ]
1721+
1722+ _:_ ->
1723+ Help.report "NO MAIN" Nothing
1724+ (
1725+ "When producing a JS file, I require that given files all have `main` values.\
1726+ \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\
1727+ \ definitely defined in the resulting file. I am missing `main` values in:"
1728+ )
1729+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)
1730+ , D.reflow $
1731+ "Try adding a `main` value to them? Or if you just want to verify that these\
1732+ \ modules compile, switch to --output=/dev/null to skip the code gen phase\
1733+ \ altogether."
1734+ , D.toSimpleNote $
1735+ "Adding a `main` value can be as brief as adding something like this:"
1736+ , D.vcat
1737+ [ D.fillSep [D.cyan "import","Html"]
1738+ , ""
1739+ , D.fillSep [D.green "main","="]
1740+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1741+ ]
1742+ , D.reflow $
1743+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1744+ \ make a `main` with no user interface."
1745+ ]
1746+
1747+ MakeCannotBuild buildProblem ->
1748+ toBuildProblemReport buildProblem
1749+
1750+ MakeBadGenerate generateProblem ->
1751+ toGenerateReport generateProblem
1752+
1753+
1754+
1755+-- BUILD PROBLEM
1756+
1757+
1758+data BuildProblem
1759+ = BuildBadModules FilePath Error.Module [Error.Module]
1760+ | BuildProjectProblem BuildProjectProblem
1761+
1762+
1763+data BuildProjectProblem
1764+ = BP_PathUnknown FilePath
1765+ | BP_WithBadExtension FilePath
1766+ | BP_WithAmbiguousSrcDir FilePath FilePath FilePath
1767+ | BP_MainPathDuplicate FilePath FilePath
1768+ | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath
1769+ | BP_RootNameInvalid FilePath FilePath [String]
1770+ | BP_CannotLoadDependencies
1771+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]
1772+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
1773+
1774+
1775+toBuildProblemReport :: BuildProblem -> Help.Report
1776+toBuildProblemReport problem =
1777+ case problem of
1778+ BuildBadModules root e es ->
1779+ Help.compilerReport root e es
1780+
1781+ BuildProjectProblem projectProblem ->
1782+ toProjectProblemReport projectProblem
1783+
1784+
1785+toProjectProblemReport :: BuildProjectProblem -> Help.Report
1786+toProjectProblemReport projectProblem =
1787+ case projectProblem of
1788+ BP_PathUnknown path ->
1789+ Help.report "FILE NOT FOUND" Nothing
1790+ "I cannot find this file:"
1791+ [ D.indent 4 $ D.red $ D.fromChars path
1792+ , D.reflow $ "Is there a typo?"
1793+ , D.toSimpleNote $
1794+ "If you are just getting started, try working through the examples in the\
1795+ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\
1796+ \ that typically go in a src/Main.elm file."
1797+ ]
1798+
1799+ BP_WithBadExtension path ->
1800+ Help.report "UNEXPECTED FILE EXTENSION" Nothing
1801+ "I can only compile Elm files (with a .elm extension) but you want me to compile:"
1802+ [ D.indent 4 $ D.red $ D.fromChars path
1803+ , D.reflow $ "Is there a typo? Can the file extension be changed?"
1804+ ]
1805+
1806+ BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->
1807+ Help.report "CONFUSING FILE" Nothing
1808+ "I am getting confused when I try to compile this file:"
1809+ [ D.indent 4 $ D.red $ D.fromChars path
1810+ , D.reflow $
1811+ "I always check if files appear in any of the \"source-directories\" listed in\
1812+ \ your elm.json to see if there might be some cached information about them. That\
1813+ \ can help me compile faster! But in this case, it looks like this file may be in\
1814+ \ either of these directories:"
1815+ , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]
1816+ , D.reflow $
1817+ "Try to make it so no source directory contains another source directory!"
1818+ ]
1819+
1820+ BP_MainPathDuplicate path1 path2 ->
1821+ Help.report "CONFUSING FILES" Nothing
1822+ "You are telling me to compile these two files:"
1823+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]
1824+ , D.reflow $
1825+ if path1 == path2 then
1826+ "Why are you telling me twice? Is something weird going on with a script?\
1827+ \ I figured I would let you know about it just in case something is wrong.\
1828+ \ Only list it once and you should be all set!"
1829+ else
1830+ "But seem to be the same file though... It makes me think something tricky is\
1831+ \ going on with symlinks in your project, so I figured I would let you know\
1832+ \ about it just in case. Remove one of these files from your command to get\
1833+ \ unstuck!"
1834+ ]
1835+
1836+ BP_RootNameDuplicate name outsidePath otherPath ->
1837+ Help.report "MODULE NAME CLASH" Nothing
1838+ "These two files are causing a module name clash:"
1839+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]
1840+ , D.reflow $
1841+ "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\
1842+ \ at the top, but they cannot have the same name!"
1843+ , D.reflow $
1844+ "Try changing to a different module name in one of them!"
1845+ ]
1846+
1847+ BP_RootNameInvalid givenPath srcDir _ ->
1848+ Help.report "UNEXPECTED FILE NAME" Nothing
1849+ "I am having trouble with this file name:"
1850+ [ D.indent 4 $ D.red $ D.fromChars givenPath
1851+ , D.reflow $
1852+ "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\
1853+ \ which is good, but I expect all of the files in there to use the following\
1854+ \ module naming convention:"
1855+ , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]
1856+ , D.reflow $
1857+ "Notice that the names always start with capital letters! Can you make your file\
1858+ \ use this naming convention?"
1859+ , D.toSimpleNote $
1860+ "Having a strict naming convention like this makes it a lot easier to find\
1861+ \ things in large projects. If you see a module imported, you know where to look\
1862+ \ for the corresponding file every time!"
1863+ ]
1864+
1865+ BP_CannotLoadDependencies ->
1866+ corruptCacheReport
1867+
1868+ BP_Cycle name names ->
1869+ Help.report "IMPORT CYCLE" Nothing
1870+ "Your module imports form a cycle:"
1871+ [ D.cycle 4 name names
1872+ , D.reflow $
1873+ "Learn more about why this is disallowed and how to break cycles here:"
1874+ ++ D.makeLink "import-cycles"
1875+ ]
1876+
1877+ BP_MissingExposed (NE.List (name, problem) _) ->
1878+ case problem of
1879+ Import.NotFound ->
1880+ Help.report "MISSING MODULE" (Just "elm.json")
1881+ "The \"exposed-modules\" of your elm.json lists the following module:"
1882+ [ D.indent 4 $ D.red $ D.fromName name
1883+ , D.reflow $
1884+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1885+ ]
1886+
1887+ Import.Ambiguous _ _ pkg _ ->
1888+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1889+ "The \"exposed-modules\" of your elm.json lists the following module:"
1890+ [ D.indent 4 $ D.red $ D.fromName name
1891+ , D.reflow $
1892+ "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\
1893+ \ choosing a different name for your local file."
1894+ ]
1895+
1896+ Import.AmbiguousLocal path1 path2 paths ->
1897+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1898+ "The \"exposed-modules\" of your elm.json lists the following module:"
1899+ [ D.indent 4 $ D.red $ D.fromName name
1900+ , D.reflow $
1901+ "But I found multiple files with that name:"
1902+ , D.dullyellow $ D.indent 4 $ D.vcat $
1903+ map D.fromChars (path1:path2:paths)
1904+ , D.reflow $
1905+ "Change the module names to be distinct!"
1906+ ]
1907+
1908+ Import.AmbiguousForeign _ _ _ ->
1909+ Help.report "MISSING MODULE" (Just "elm.json")
1910+ "The \"exposed-modules\" of your elm.json lists the following module:"
1911+ [ D.indent 4 $ D.red $ D.fromName name
1912+ , D.reflow $
1913+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1914+ , D.toSimpleNote $
1915+ "It is not possible to \"re-export\" modules from other packages. You can only\
1916+ \ expose modules that you define in your own code."
1917+ ]
1918+
1919+
1920+toModuleNameConventionTable :: FilePath -> [String] -> D.Doc
1921+toModuleNameConventionTable srcDir names =
1922+ let
1923+ toPair name =
1924+ ( name
1925+ , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"
1926+ )
1927+
1928+ namePairs = map toPair names
1929+ nameWidth = maximum (11 : map (length . fst) namePairs)
1930+ pathWidth = maximum ( 9 : map (length . snd) namePairs)
1931+
1932+ padded width str =
1933+ str ++ replicate (width - length str) ' '
1934+
1935+ toRow (name, path) =
1936+ D.fromChars $
1937+ "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"
1938+
1939+ bar =
1940+ D.fromChars $
1941+ "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"
1942+ in
1943+ D.indent 4 $ D.vcat $
1944+ [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]
1945+
1946+
1947+
1948+-- GENERATE
1949+
1950+
1951+data Generate
1952+ = GenerateCannotLoadArtifacts
1953+ | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
1954+
1955+
1956+toGenerateReport :: Generate -> Help.Report
1957+toGenerateReport problem =
1958+ case problem of
1959+ GenerateCannotLoadArtifacts ->
1960+ corruptCacheReport
1961+
1962+ GenerateCannotOptimizeDebugValues m ms ->
765 Help.report "DEBUG REMNANTS" Nothing
1963 Help.report "DEBUG REMNANTS" Nothing
766 "There are uses of the `Debug` module in the following modules:"
1964 "There are uses of the `Debug` module in the following modules:"
767 [ 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)
@@ -770,7 +1968,7 @@ makeToReport make =
770 "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.\
771 \ Here are two examples:"
1969 \ Here are two examples:"
772 , D.indent 4 $ D.reflow $
1970 , D.indent 4 $ D.reflow $
773− "(1) It shortens record field names. This makes the generated JavaScript is\
1971+ "(1) It shortens record field names. This makes the generated JavaScript\
774 \ smaller, but `Debug.toString` cannot know the real field names anymore."
1972 \ smaller, but `Debug.toString` cannot know the real field names anymore."
775 , D.indent 4 $ D.reflow $
1973 , D.indent 4 $ D.reflow $
776 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
1974 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
@@ -783,28 +1981,89 @@ makeToReport make =
783 \ exists!"
1981 \ exists!"
784 ]
1982 ]
785
1983
786− MakeCannotBuild buildProblem ->
787− case buildProblem of
788− BuildProjectProblem bp ->
789− case bp of
790− BP_PathUnknown _ -> error "TODO BP_PathUnknown"
791− BP_WithBadExtension _ -> error "TODO BP_WithBadExtension"
792− BP_WithAmbiguousSrcDir _ _ -> error "TODO BP_WithAmbiguousSrcDir"
793− BP_MainPathDuplicate _ _ -> error "TODO BP_MainPathDuplicate"
794− BP_MainNameDuplicate _ _ _ -> error "TODO BP_MainNameDuplicate"
795− BP_CannotLoadDependencies -> error "TODO BP_CannotLoadDependencies"
796− BP_Cycle name names ->
797− Help.report "IMPORT CYCLE" Nothing
798− "Your module imports form a cycle:"
799− [ D.cycle 4 name names
800− , D.reflow $
801− "Learn more about why this is disallowed and how to break cycles here:"
802− ++ D.makeLink "import-cycles"
803− ]
804
1984
805
1985
806− BuildModuleProblems p ps ->
1986+-- CORRUPT CACHE
807− error "TODO MakeCannotBuild" p ps
1987+
1988+
1989+corruptCacheReport :: Help.Report
1990+corruptCacheReport =
1991+ Help.report "CORRUPT CACHE" Nothing
1992+ "It looks like some of the information cached in elm-stuff/ has been corrupted."
1993+ [ D.reflow $
1994+ "Try deleting your elm-stuff/ directory to get unstuck."
1995+ , D.toSimpleNote $
1996+ "This almost certainly means that a 3rd party tool (or editor plugin) is\
1997+ \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\
1998+ \ one by one until you figure out which it is!"
1999+ ]
2000+
2001+
2002+
2003+-- REACTOR
2004+
2005+
2006+data Reactor
2007+ = ReactorNoOutline
2008+ | ReactorBadDetails Details
2009+ | ReactorBadBuild BuildProblem
2010+ | ReactorBadGenerate Generate
2011+
2012+
2013+reactorToReport :: Reactor -> Help.Report
2014+reactorToReport problem =
2015+ case problem of
2016+ ReactorNoOutline ->
2017+ Help.report "NEW PROJECT?" Nothing
2018+ "Are you trying to start a new project? Try this command in the terminal:"
2019+ [ D.indent 4 $ D.green "elm init"
2020+ , D.reflow "It will help you get started!"
2021+ ]
2022+
2023+ ReactorBadDetails details ->
2024+ toDetailsReport details
2025+
2026+ ReactorBadBuild buildProblem ->
2027+ toBuildProblemReport buildProblem
2028+
2029+ ReactorBadGenerate generate ->
2030+ toGenerateReport generate
2031+
2032+
2033+
2034+-- REPL
2035+
2036+
2037+data Repl
2038+ = ReplBadDetails Details
2039+ | ReplBadInput BS.ByteString Error.Error
2040+ | ReplBadLocalDeps FilePath Error.Module [Error.Module]
2041+ | ReplProjectProblem BuildProjectProblem
2042+ | ReplBadGenerate Generate
2043+ | ReplBadCache
2044+ | ReplBlocked
2045+
2046+
2047+replToReport :: Repl -> Help.Report
2048+replToReport problem =
2049+ case problem of
2050+ ReplBadDetails details ->
2051+ toDetailsReport details
2052+
2053+ ReplBadInput source err ->
2054+ Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
2055+
2056+ ReplBadLocalDeps root e es ->
2057+ Help.compilerReport root e es
2058+
2059+ ReplProjectProblem projectProblem ->
2060+ toProjectProblemReport projectProblem
2061+
2062+ ReplBadGenerate generate ->
2063+ toGenerateReport generate
2064+
2065+ ReplBadCache ->
2066+ corruptCacheReport
808
2067
809− MakeCannotLoadArtifacts ->
2068+ ReplBlocked ->
810− 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+11−12
@@ -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
@@ -22,7 +21,7 @@ import qualified Json.Encode as E
22import Json.Encode ((==>))
21import Json.Encode ((==>))
23import Reporting.Doc ((<+>))
22import Reporting.Doc ((<+>))
24import qualified Reporting.Doc as D
23import qualified Reporting.Doc as D
25−import qualified Reporting.Exit.Compile as Compile
24+import qualified Reporting.Error as Error
26
25
27
26
28
27
@@ -30,7 +29,7 @@ import qualified Reporting.Exit.Compile as Compile
30
29
31
30
32data Report
31data Report
33− = CompilerReport Compile.Exit [Compile.Exit]
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 :: Compile.Exit -> [Compile.Exit] -> 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− Compile.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 Compile.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+11−8
@@ -56,12 +56,14 @@ import Data.Binary
56import qualified Data.List as List
56import qualified Data.List as List
57import qualified Data.Map as Map
57import qualified Data.Map as Map
58import Data.Name (Name)
58import Data.Name (Name)
59−import qualified Data.Utf8 as Utf8
60
59
60+import qualified AST.Source as Src
61import qualified AST.Utils.Binop as Binop
61import qualified AST.Utils.Binop as Binop
62import qualified AST.Utils.Shader as Shader
62import qualified AST.Utils.Shader as Shader
63import qualified Data.Index as Index
63import qualified Data.Index as Index
64+import qualified Elm.Float as EF
64import qualified Elm.ModuleName as ModuleName
65import qualified Elm.ModuleName as ModuleName
66+import qualified Elm.String as ES
65import qualified Reporting.Annotation as A
67import qualified Reporting.Annotation as A
66
68
67
69
@@ -82,10 +84,10 @@ data Expr_
82 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
84 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
83 | VarDebug ModuleName.Canonical Name Annotation
85 | VarDebug ModuleName.Canonical Name Annotation
84 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
86 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
85− | Chr Utf8.String
87+ | Chr ES.String
86− | Str Utf8.String
88+ | Str ES.String
87 | Int Int
89 | Int Int
88− | Float (Utf8.Under256 Float)
90+ | Float EF.Float
89 | List [Expr]
91 | List [Expr]
90 | Negate Expr
92 | Negate Expr
91 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
93 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
@@ -150,8 +152,8 @@ data Pattern_
150 | PList [Pattern]
152 | PList [Pattern]
151 | PCons Pattern Pattern
153 | PCons Pattern Pattern
152 | PBool Union Bool
154 | PBool Union Bool
153− | PChr Utf8.String
155+ | PChr ES.String
154− | PStr Utf8.String
156+ | PStr ES.String
155 | PInt Int
157 | PInt Int
156 | PCtor
158 | PCtor
157 { _p_home :: ModuleName.Canonical
159 { _p_home :: ModuleName.Canonical
@@ -231,6 +233,7 @@ data Module =
231 Module
233 Module
232 { _name :: ModuleName.Canonical
234 { _name :: ModuleName.Canonical
233 , _exports :: Exports
235 , _exports :: Exports
236+ , _docs :: Src.Docs
234 , _decls :: Decls
237 , _decls :: Decls
235 , _unions :: Map.Map Name Union
238 , _unions :: Map.Map Name Union
236 , _aliases :: Map.Map Name Alias
239 , _aliases :: Map.Map Name Alias
@@ -339,7 +342,7 @@ instance Binary CtorOpts where
339 0 -> return Normal
342 0 -> return Normal
340 1 -> return Enum
343 1 -> return Enum
341 2 -> return Unbox
344 2 -> return Unbox
342− _ -> error "binary encoding of CtorOpts was corrupted"
345+ _ -> fail "binary encoding of CtorOpts was corrupted"
343
346
344
347
345instance Binary Annotation where
348instance Binary Annotation where
@@ -390,7 +393,7 @@ instance Binary AliasType where
390 case n of
393 case n of
391 0 -> liftM Holey get
394 0 -> liftM Holey get
392 1 -> liftM Filled get
395 1 -> liftM Filled get
393− _ -> error "binary encoding of AliasType was corrupted"
396+ _ -> fail "binary encoding of AliasType was corrupted"
394
397
395
398
396instance Binary FieldType where
399instance Binary FieldType where
compiler/src/AST/Optimized.hs+14−13
@@ -27,14 +27,15 @@ import qualified Data.Map as Map
27import qualified Data.Name as Name
27import qualified Data.Name as Name
28import Data.Name (Name)
28import Data.Name (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 AST.Utils.Shader as Shader
32import qualified AST.Utils.Shader as Shader
34import qualified Data.Index as Index
33import qualified Data.Index as Index
34+import qualified Elm.Float as EF
35import qualified Elm.Kernel as K
35import qualified Elm.Kernel as K
36import qualified Elm.ModuleName as ModuleName
36import qualified Elm.ModuleName as ModuleName
37import qualified Elm.Package as Pkg
37import qualified Elm.Package as Pkg
38+import qualified Elm.String as ES
38import qualified Optimize.DecisionTree as DT
39import qualified Optimize.DecisionTree as DT
39import qualified Reporting.Annotation as A
40import qualified Reporting.Annotation as A
40
41
@@ -45,10 +46,10 @@ import qualified Reporting.Annotation as A
45
46
46data Expr
47data Expr
47 = Bool Bool
48 = Bool Bool
48− | Chr Utf8.String
49+ | Chr ES.String
49− | Str Utf8.String
50+ | Str ES.String
50 | Int Int
51 | Int Int
51− | Float (Utf8.Under256 Float)
52+ | Float EF.Float
52 | VarLocal Name
53 | VarLocal Name
53 | VarGlobal Global
54 | VarGlobal Global
54 | VarEnum Global Index.ZeroBased
55 | VarEnum Global Index.ZeroBased
@@ -134,7 +135,7 @@ data GlobalGraph =
134data LocalGraph =
135data LocalGraph =
135 LocalGraph
136 LocalGraph
136 { _l_main :: Maybe Main
137 { _l_main :: Maybe Main
137− , _l_nodes :: Map.Map Global Node -- TODO profile switching Global to Name
138+ , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
138 , _l_fields :: Map.Map Name Int
139 , _l_fields :: Map.Map Name Int
139 }
140 }
140
141
@@ -307,7 +308,7 @@ instance Binary Expr where
307 24 -> pure Unit
308 24 -> pure Unit
308 25 -> liftM3 Tuple get get get
309 25 -> liftM3 Tuple get get get
309 26 -> liftM3 Shader get get get
310 26 -> liftM3 Shader get get get
310− _ -> error "problem getting Opt.Expr binary"
311+ _ -> fail "problem getting Opt.Expr binary"
311
312
312
313
313instance Binary Def where
314instance Binary Def where
@@ -321,7 +322,7 @@ instance Binary Def where
321 case word of
322 case word of
322 0 -> liftM2 Def get get
323 0 -> liftM2 Def get get
323 1 -> liftM3 TailDef get get get
324 1 -> liftM3 TailDef get get get
324− _ -> error "problem getting Opt.Def binary"
325+ _ -> fail "problem getting Opt.Def binary"
325
326
326
327
327instance Binary Destructor where
328instance Binary Destructor where
@@ -344,7 +345,7 @@ instance Binary Path where
344 1 -> liftM2 Field get get
345 1 -> liftM2 Field get get
345 2 -> liftM Unbox get
346 2 -> liftM Unbox get
346 3 -> liftM Root get
347 3 -> liftM Root get
347− _ -> error "problem getting Opt.Path binary"
348+ _ -> fail "problem getting Opt.Path binary"
348
349
349
350
350instance (Binary a) => Binary (Decider a) where
351instance (Binary a) => Binary (Decider a) where
@@ -360,7 +361,7 @@ instance (Binary a) => Binary (Decider a) where
360 0 -> liftM Leaf get
361 0 -> liftM Leaf get
361 1 -> liftM3 Chain get get get
362 1 -> liftM3 Chain get get get
362 2 -> liftM3 FanOut get get get
363 2 -> liftM3 FanOut get get get
363− _ -> error "problem getting Opt.Decider binary"
364+ _ -> fail "problem getting Opt.Decider binary"
364
365
365
366
366instance Binary Choice where
367instance Binary Choice where
@@ -374,7 +375,7 @@ instance Binary Choice where
374 case word of
375 case word of
375 0 -> liftM Inline get
376 0 -> liftM Inline get
376 1 -> liftM Jump get
377 1 -> liftM Jump get
377− _ -> error "problem getting Opt.Choice binary"
378+ _ -> fail "problem getting Opt.Choice binary"
378
379
379
380
380
381
@@ -399,7 +400,7 @@ instance Binary Main where
399 case word of
400 case word of
400 0 -> return Static
401 0 -> return Static
401 1 -> liftM2 Dynamic get get
402 1 -> liftM2 Dynamic get get
402− _ -> error "problem getting Opt.Main binary"
403+ _ -> fail "problem getting Opt.Main binary"
403
404
404
405
405instance Binary Node where
406instance Binary Node where
@@ -431,7 +432,7 @@ instance Binary Node where
431 8 -> liftM2 Kernel get get
432 8 -> liftM2 Kernel get get
432 9 -> liftM2 PortIncoming get get
433 9 -> liftM2 PortIncoming get get
433 10 -> liftM2 PortOutgoing get get
434 10 -> liftM2 PortOutgoing get get
434− _ -> error "problem getting Opt.Node binary"
435+ _ -> fail "problem getting Opt.Node binary"
435
436
436
437
437instance Binary EffectsType where
438instance Binary EffectsType where
@@ -447,4 +448,4 @@ instance Binary EffectsType where
447 0 -> return Cmd
448 0 -> return Cmd
448 1 -> return Sub
449 1 -> return Sub
449 2 -> return Fx
450 2 -> return Fx
450− _ -> error "problem getting Opt.EffectsType binary"
451+ _ -> fail "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hs+35−24
@@ -1,5 +1,4 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3module AST.Source
2module AST.Source
4 ( Expr, Expr_(..), VarType(..)
3 ( Expr, Expr_(..), VarType(..)
5 , Def(..)
4 , Def(..)
@@ -12,10 +11,12 @@ module AST.Source
12 , Value(..)
11 , Value(..)
13 , Union(..)
12 , Union(..)
14 , Alias(..)
13 , Alias(..)
15− , Binop(..)
14+ , Infix(..)
16 , Port(..)
15 , Port(..)
17 , Effects(..)
16 , Effects(..)
18 , Manager(..)
17 , Manager(..)
18+ , Docs(..)
19+ , Comment(..)
19 , Exposing(..)
20 , Exposing(..)
20 , Exposed(..)
21 , Exposed(..)
21 , Privacy(..)
22 , Privacy(..)
@@ -24,10 +25,13 @@ module AST.Source
24
25
25
26
26import Data.Name (Name)
27import Data.Name (Name)
27−import qualified Data.Utf8 as Utf8
28+import qualified Data.Name as Name
28
29
29import qualified AST.Utils.Binop as Binop
30import qualified AST.Utils.Binop as Binop
30import qualified AST.Utils.Shader as Shader
31import qualified AST.Utils.Shader as Shader
32+import qualified Elm.Float as EF
33+import qualified Elm.String as ES
34+import qualified Parse.Primitives as P
31import qualified Reporting.Annotation as A
35import qualified Reporting.Annotation as A
32
36
33
37
@@ -39,10 +43,10 @@ type Expr = A.Located Expr_
39
43
40
44
41data Expr_
45data Expr_
42− = Chr Utf8.String
46+ = Chr ES.String
43− | Str Utf8.String
47+ | Str ES.String
44 | Int Int
48 | Int Int
45− | Float (Utf8.Under256 Float)
49+ | Float EF.Float
46 | Var VarType Name
50 | Var VarType Name
47 | VarQual VarType Name Name
51 | VarQual VarType Name Name
48 | List [Expr]
52 | List [Expr]
@@ -93,8 +97,8 @@ data Pattern_
93 | PCtorQual A.Region Name Name [Pattern]
97 | PCtorQual A.Region Name Name [Pattern]
94 | PList [Pattern]
98 | PList [Pattern]
95 | PCons Pattern Pattern
99 | PCons Pattern Pattern
96− | PChr Utf8.String
100+ | PChr ES.String
97− | PStr Utf8.String
101+ | PStr ES.String
98 | PInt Int
102 | PInt Int
99
103
100
104
@@ -122,28 +126,26 @@ data Type_
122
126
123data Module =
127data Module =
124 Module
128 Module
125− { _name :: Maybe Name
129+ { _name :: Maybe (A.Located Name)
126 , _exports :: A.Located Exposing
130 , _exports :: A.Located Exposing
131+ , _docs :: Docs
127 , _imports :: [Import]
132 , _imports :: [Import]
128 , _values :: [A.Located Value]
133 , _values :: [A.Located Value]
129 , _unions :: [A.Located Union]
134 , _unions :: [A.Located Union]
130 , _aliases :: [A.Located Alias]
135 , _aliases :: [A.Located Alias]
131− , _binops :: [A.Located Binop]
136+ , _binops :: [A.Located Infix]
132 , _effects :: Effects
137 , _effects :: Effects
133 }
138 }
134
139
135
140
136getName :: Module -> Name
141getName :: Module -> Name
137−getName (Module maybeName _ _ _ _ _ _ _) =
142+getName (Module maybeName _ _ _ _ _ _ _ _) =
138 case maybeName of
143 case maybeName of
139− Just name -> name
144+ Just (A.At _ name) ->
140− Nothing -> defaultModuleName
145+ name
141
146
142−
147+ Nothing ->
143−{-# NOINLINE defaultModuleName #-}
148+ Name._Main
144−defaultModuleName :: Name
145−defaultModuleName =
146− "Main"
147
149
148
150
149getImportName :: Import -> Name
151getImportName :: Import -> Name
@@ -162,7 +164,7 @@ data Import =
162data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
164data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
163data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
165data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
164data Alias = Alias (A.Located Name) [A.Located Name] Type
166data Alias = Alias (A.Located Name) [A.Located Name] Type
165−data Binop = Binop Name Binop.Associativity Binop.Precedence Name
167+data Infix = Infix Name Binop.Associativity Binop.Precedence Name
166data Port = Port (A.Located Name) Type
168data Port = Port (A.Located Name) Type
167
169
168
170
@@ -178,21 +180,30 @@ data Manager
178 | Fx (A.Located Name) (A.Located Name)
180 | Fx (A.Located Name) (A.Located Name)
179
181
180
182
183+data Docs
184+ = NoDocs A.Region
185+ | YesDocs Comment [(Name, Comment)]
186+
187+
188+newtype Comment =
189+ Comment P.Snippet
190+
191+
181
192
182-- EXPOSING
193-- EXPOSING
183
194
184
195
185data Exposing
196data Exposing
186 = Open
197 = Open
187− | Explicit [A.Located Exposed]
198+ | Explicit [Exposed]
188
199
189
200
190data Exposed
201data Exposed
191− = Lower Name
202+ = Lower (A.Located Name)
192− | Upper Name Privacy
203+ | Upper (A.Located Name) Privacy
193− | Operator Name
204+ | Operator A.Region Name
194
205
195
206
196data Privacy
207data Privacy
197− = Public
208+ = Public A.Region
198 | 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+51−4
@@ -4,22 +4,27 @@ module AST.Utils.Shader
4 ( Source
4 ( Source
5 , Types(..)
5 , Types(..)
6 , Type(..)
6 , Type(..)
7+ , fromChars
8+ , toJsStringBuilder
7 )
9 )
8 where
10 where
9
11
10
12
13+import Control.Monad (liftM)
14+import Data.Binary (Binary, get, put)
15+import qualified Data.ByteString as BS
16+import qualified Data.ByteString.Builder as B
17+import qualified Data.ByteString.UTF8 as BS_UTF8
11import qualified Data.Map as Map
18import qualified Data.Map as Map
12import qualified Data.Name as Name
19import qualified Data.Name as Name
13−import qualified Data.Utf8 as Utf8
14
20
15
21
16
22
17-- SOURCE
23-- SOURCE
18
24
19
25
20−type Source = Utf8.VeryLong SOURCE
26+newtype Source =
21−
27+ Source BS.ByteString
22−data SOURCE
23
28
24
29
25
30
@@ -42,3 +47,45 @@ data Type
42 | V4
47 | V4
43 | M4
48 | M4
44 | Texture
49 | Texture
50+
51+
52+
53+-- TO BUILDER
54+
55+
56+toJsStringBuilder :: Source -> B.Builder
57+toJsStringBuilder (Source src) =
58+ B.byteString src
59+
60+
61+
62+-- FROM CHARS
63+
64+
65+fromChars :: [Char] -> Source
66+fromChars chars =
67+ Source (BS_UTF8.fromString (escape chars))
68+
69+
70+escape :: [Char] -> [Char]
71+escape chars =
72+ case chars of
73+ [] ->
74+ []
75+
76+ c:cs
77+ | c == '\r' -> escape cs
78+ | c == '\n' -> '\\' : 'n' : escape cs
79+ | c == '\"' -> '\\' : '"' : escape cs
80+ | c == '\'' -> '\\' : '\'' : escape cs
81+ | c == '\\' -> '\\' : '\\' : escape cs
82+ | otherwise -> c : escape cs
83+
84+
85+
86+-- BINARY
87+
88+
89+instance Binary Source where
90+ get = liftM Source get
91+ put (Source a) = put a
compiler/src/AST/Utils/Type.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+8−8
@@ -54,7 +54,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
54
54
55
55
56collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
56collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57−collectVars (Src.Module _ _ _ values _ _ _ effects) =
57+collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
58 let
58 let
59 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
59 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
60 Dups.insert name region (Env.TopLevel region) dict
60 Dups.insert name region (Env.TopLevel region) dict
@@ -95,7 +95,7 @@ toEffectDups effects =
95
95
96
96
97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
98−addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
98+addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
99 let
99 let
100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs q
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
@@ -262,7 +262,7 @@ addFreeVars freeVars (A.At region tipe) =
262
262
263
263
264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
265−addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
265+addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266 do unionInfo <- traverse (canonicalizeUnion env) unions
266 do unionInfo <- traverse (canonicalizeUnion env) unions
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
268
268
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs q
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+11−11
@@ -42,7 +42,7 @@ type Result i w a =
42
42
43
43
44canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
44canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
45−canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops effects) =
45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
46 do let home = ModuleName.Canonical pkg (Src.getName modul)
46 do let home = ModuleName.Canonical pkg (Src.getName modul)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
48
48
@@ -54,15 +54,15 @@ canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops ef
54 ceffects <- Effects.canonicalize env values cunions effects
54 ceffects <- Effects.canonicalize env values cunions effects
55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
56
56
57− return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects
57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
58
58
59
59
60
60
61-- CANONICALIZE BINOP
61-- CANONICALIZE BINOP
62
62
63
63
64−canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )
64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65−canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =
65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
66 ( op, Can.Binop_ associativity precedence func )
66 ( op, Can.Binop_ associativity precedence func )
67
67
68
68
@@ -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/Compile.hs+20−11
@@ -20,6 +20,7 @@ import qualified Nitpick.PatternMatches as PatternMatches
20import qualified Optimize.Module as Optimize
20import qualified Optimize.Module as Optimize
21import qualified Reporting.Error as E
21import qualified Reporting.Error as E
22import qualified Reporting.Result as R
22import qualified Reporting.Result as R
23+import qualified Reporting.Render.Type.Localizer as Localizer
23import qualified Type.Constrain.Module as Type
24import qualified Type.Constrain.Module as Type
24import qualified Type.Solve as Type
25import qualified Type.Solve as Type
25
26
@@ -41,9 +42,9 @@ data Artifacts =
41compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
42compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
42compile pkg ifaces modul =
43compile pkg ifaces modul =
43 do canonical <- canonicalize pkg ifaces modul
44 do canonical <- canonicalize pkg ifaces modul
44− annotations <- typeCheck canonical
45+ annotations <- typeCheck modul canonical
45 () <- nitpick canonical
46 () <- nitpick canonical
46− objects <- optimize annotations canonical
47+ objects <- optimize modul annotations canonical
47 return (Artifacts canonical annotations objects)
48 return (Artifacts canonical annotations objects)
48
49
49
50
@@ -53,18 +54,22 @@ compile pkg ifaces modul =
53
54
54canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
55canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
55canonicalize pkg ifaces modul =
56canonicalize pkg ifaces modul =
56− snd $ R.run E.BadNames $
57− Canonicalize.canonicalize pkg ifaces modul
57+ case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of
58+ Right canonical ->
59+ Right canonical
60+
61+ Left errors ->
62+ Left $ E.BadNames errors
58
63
59
64
60−typeCheck :: Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
65+typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
61−typeCheck canonical =
66+typeCheck modul canonical =
62 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
67 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
63 Right annotations ->
68 Right annotations ->
64 Right annotations
69 Right annotations
65
70
66 Left errors ->
71 Left errors ->
67− Left (E.BadTypes errors)
72+ Left (E.BadTypes (Localizer.fromModule modul) errors)
68
73
69
74
70nitpick :: Can.Module -> Either E.Error ()
75nitpick :: Can.Module -> Either E.Error ()
@@ -77,7 +82,11 @@ nitpick canonical =
77 Left (E.BadPatterns errors)
82 Left (E.BadPatterns errors)
78
83
79
84
80−optimize :: Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
85+optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
81−optimize annotations canonical =
86+optimize modul annotations canonical =
82− snd $ R.run E.BadMains $
83− Optimize.optimize annotations canonical
87+ case snd $ R.run $ Optimize.optimize annotations canonical of
88+ Right localGraph ->
89+ Right localGraph
90+
91+ Left errors ->
92+ Left (E.BadMains (Localizer.fromModule modul) errors)
compiler/src/Data/Map/Utils.hs+6
@@ -1,6 +1,7 @@
1module Data.Map.Utils
1module Data.Map.Utils
2 ( fromKeys
2 ( fromKeys
3 , fromKeysA
3 , fromKeysA
4+ , fromValues
4 , any
5 , any
5 )
6 )
6 where
7 where
@@ -25,6 +26,11 @@ fromKeysA toValue keys =
25 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
26 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
26
27
27
28
29+fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v
30+fromValues toKey values =
31+ Map.fromList $ map (\v -> (toKey v, v)) values
32+
33+
28
34
29-- ANY
35-- ANY
30
36
compiler/src/Data/Name.hs+166−177
@@ -1,130 +1,119 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Name
3module Data.Name
4 ( Name
4 ( Name
5− , toUtf8
5+ --
6− , fromUtf8
6+ , toChars
7− , toEscapedBuilder
7+ , toElmString
8− , Utf8.toBuilder
8+ , toBuilder
9+ --
9− , Utf8.fromPtr
10+ , fromPtr
10− , Utf8.fromChars
11+ , fromChars
11− , Utf8.toChars
12− -- misc
12+ --
13 , getKernel
13 , getKernel
14 , hasDot
14 , hasDot
15+ , splitDots
15 , isKernel
16 , isKernel
16 , isNumberType
17 , isNumberType
17 , isComparableType
18 , isComparableType
18 , isAppendableType
19 , isAppendableType
19 , isCompappendType
20 , isCompappendType
20 , fromVarIndex
21 , fromVarIndex
21− , fromReplCount
22 , fromWords
22 , fromWords
23 , fromManyNames
23 , fromManyNames
24 , fromTypeVariable
24 , fromTypeVariable
25 , fromTypeVariableScheme
25 , fromTypeVariableScheme
26 , sepBy
26 , sepBy
27− -- interned
27+ --
28 , int, float, bool, char, string
28 , int, float, bool, char, string
29 , maybe, result, list, array, dict, tuple, jsArray
29 , maybe, result, list, array, dict, tuple, jsArray
30 , task, router, cmd, sub, platform, virtualDom
30 , task, router, cmd, sub, platform, virtualDom
31 , shader, debug, debugger, bitwise, basics
31 , shader, debug, debugger, bitwise, basics
32 , utils, negate, true, false, value
32 , utils, negate, true, false, value
33− , node, program, main, dollar, identity
33+ , node, program, _main, _Main, dollar, identity
34− , replModule
34+ , replModule, replValueToPrint
35 )
35 )
36 where
36 where
37
37
38
38
39import Prelude hiding (length, maybe, negate)
39import Prelude hiding (length, maybe, negate)
40import Control.Exception (assert)
40import Control.Exception (assert)
41+import qualified Data.Binary as Binary
41import qualified Data.ByteString.Builder.Internal as B
42import qualified Data.ByteString.Builder.Internal as B
42−import Data.Coerce (coerce)
43+import qualified Data.Coerce as Coerce
43import qualified Data.List as List
44import qualified Data.List as List
45+import qualified Data.String as Chars
44import qualified Data.Utf8 as Utf8
46import qualified Data.Utf8 as Utf8
45−import Foreign.Ptr (plusPtr, minusPtr)
46import GHC.Exts
47import GHC.Exts
47− ( Int(I#), Ptr(Ptr)
48+ ( Int(I#), Ptr
48− , RealWorld
49 , MutableByteArray#
49 , MutableByteArray#
50 , isTrue#
50 , isTrue#
51 , newByteArray#
51 , newByteArray#
52 , sizeofByteArray#
52 , sizeofByteArray#
53− , writeWord8OffAddr#
54− , copyByteArrayToAddr#
55 , unsafeFreezeByteArray#
53 , unsafeFreezeByteArray#
56 )
54 )
57−import GHC.IO
58import GHC.ST (ST(ST), runST)
55import GHC.ST (ST(ST), runST)
59import GHC.Prim
56import GHC.Prim
60import GHC.Word (Word8(W8#))
57import GHC.Word (Word8(W8#))
61
58
59+import qualified Elm.String as ES
60+
62
61
63
62
64-- NAME
63-- NAME
65
64
66
65
67−type Name = Utf8.Under256 NAME
66+type Name =
67+ Utf8.Utf8 ELM_NAME
68
68
69
69
70−data NAME
70+data ELM_NAME
71
71
72
72
73−toUtf8 :: Name -> Utf8.String
74−toUtf8 =
75− coerce
76
73
74+-- INSTANCES
77
75
78−fromUtf8 :: Utf8.String -> Name
79−fromUtf8 =
80− coerce
81
76
77+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78+ fromString = Utf8.fromChars
82
79
80+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81+ get = Utf8.getUnder256
82+ put = Utf8.putUnder256
83
83
84−-- TO ESCAPED BUILDER
85
84
86
85
87−{-# INLINE toEscapedBuilder #-}
86+-- TO
88−toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
89−toEscapedBuilder before after =
90− \name -> B.builder (toEscapedBuilderHelp before after name)
91
87
92
88
93−{-# INLINE toEscapedBuilderHelp #-}
89+toChars :: Name -> [Char]
94−toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
90+toChars =
95−toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
91+ Utf8.toChars
96− go 0 (I# (sizeofByteArray# ba#))
97− where
98− go !offset !len !(B.BufferRange bOffset bEnd) =
99− let
100− !bLen = minusPtr bEnd bOffset
101− in
102− if len <= bLen then
103− do -- TODO test if writing word-by-word is faster
104− stToIO (copyToPtr name offset bOffset len)
105− stToIO (escape before after bOffset name offset len 0)
106− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
107− k newBufferRange
108− else
109− do stToIO (copyToPtr name offset bOffset bLen)
110− stToIO (escape before after bOffset name offset bLen 0)
111− let !newOffset = offset + bLen
112− let !newLength = len - bLen
113− return $ B.bufferFull 1 bEnd (go newOffset newLength)
114−
115−
116−escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
117−escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
118− if isTrue# (i# <# len#) then
119− if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
120− then
121− do writeWordToPtr ptr i after
122− escape before after ptr name offset len (i + 1)
123− else
124− do escape before after ptr name offset len (i + 1)
125
92
126− else
93+
127− return ()
94+toElmString :: Name -> ES.String
95+toElmString =
96+ Coerce.coerce
97+
98+
99+{-# INLINE toBuilder #-}
100+toBuilder :: Name -> B.Builder
101+toBuilder =
102+ Utf8.toBuilder
103+
104+
105+
106+-- FROM
107+
108+
109+fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110+fromPtr =
111+ Utf8.fromPtr
112+
113+
114+fromChars :: [Char] -> Name
115+fromChars =
116+ Utf8.fromChars
128
117
129
118
130
119
@@ -133,7 +122,12 @@ escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) l
133
122
134hasDot :: Name -> Bool
123hasDot :: Name -> Bool
135hasDot name =
124hasDot name =
136− Utf8.contains 0x2E {- . -} (coerce name)
125+ Utf8.contains 0x2E {- . -} name
126+
127+
128+splitDots :: Name -> [Name]
129+splitDots name =
130+ Utf8.split 0x2E {- . -} name
137
131
138
132
139
133
@@ -181,23 +175,23 @@ isCompappendType = Utf8.startsWith prefix_compappend
181
175
182{-# NOINLINE prefix_kernel #-}
176{-# NOINLINE prefix_kernel #-}
183prefix_kernel :: Name
177prefix_kernel :: Name
184−prefix_kernel = "Elm.Kernel."
178+prefix_kernel = fromChars "Elm.Kernel."
185
179
186{-# NOINLINE prefix_number #-}
180{-# NOINLINE prefix_number #-}
187prefix_number :: Name
181prefix_number :: Name
188−prefix_number = "number"
182+prefix_number = fromChars "number"
189
183
190{-# NOINLINE prefix_comparable #-}
184{-# NOINLINE prefix_comparable #-}
191prefix_comparable :: Name
185prefix_comparable :: Name
192−prefix_comparable = "comparable"
186+prefix_comparable = fromChars "comparable"
193
187
194{-# NOINLINE prefix_appendable #-}
188{-# NOINLINE prefix_appendable #-}
195prefix_appendable :: Name
189prefix_appendable :: Name
196−prefix_appendable = "appendable"
190+prefix_appendable = fromChars "appendable"
197
191
198{-# NOINLINE prefix_compappend #-}
192{-# NOINLINE prefix_compappend #-}
199prefix_compappend :: Name
193prefix_compappend :: Name
200−prefix_compappend = "compappend"
194+prefix_compappend = fromChars "compappend"
201
195
202
196
203
197
@@ -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
@@ -423,22 +418,6 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
423 s -> (# s, () #)
418 s -> (# s, () #)
424
419
425
420
426−{-# INLINE writeWordToPtr #-}
427−writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()
428−writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
429− ST $ \s ->
430− case writeWord8OffAddr# addr# offset# word# s of
431− s -> (# s, () #)
432−
433−
434−{-# INLINE copyToPtr #-}
435−copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
436−copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =
437− ST $ \s ->
438− case copyByteArrayToAddr# ba# offset# addr# len# s of
439− s -> (# s, () #)
440−
441−
442{-# INLINE copyToMBA #-}
421{-# INLINE copyToMBA #-}
443copyToMBA :: Name -> MBA s -> ST s ()
422copyToMBA :: Name -> MBA s -> ST s ()
444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
@@ -453,169 +432,179 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
453
432
454{-# NOINLINE int #-}
433{-# NOINLINE int #-}
455int :: Name
434int :: Name
456−int = "Int"
435+int = fromChars "Int"
457
436
458
437
459{-# NOINLINE float #-}
438{-# NOINLINE float #-}
460float :: Name
439float :: Name
461−float = "Float"
440+float = fromChars "Float"
462
441
463
442
464{-# NOINLINE bool #-}
443{-# NOINLINE bool #-}
465bool :: Name
444bool :: Name
466−bool = "Bool"
445+bool = fromChars "Bool"
467
446
468
447
469{-# NOINLINE char #-}
448{-# NOINLINE char #-}
470char :: Name
449char :: Name
471−char = "Char"
450+char = fromChars "Char"
472
451
473
452
474{-# NOINLINE string #-}
453{-# NOINLINE string #-}
475string :: Name
454string :: Name
476−string = "String"
455+string = fromChars "String"
477
456
478
457
479{-# NOINLINE maybe #-}
458{-# NOINLINE maybe #-}
480maybe :: Name
459maybe :: Name
481−maybe = "Maybe"
460+maybe = fromChars "Maybe"
482
461
483
462
484{-# NOINLINE result #-}
463{-# NOINLINE result #-}
485result :: Name
464result :: Name
486−result = "Result"
465+result = fromChars "Result"
487
466
488
467
489{-# NOINLINE list #-}
468{-# NOINLINE list #-}
490list :: Name
469list :: Name
491−list = "List"
470+list = fromChars "List"
492
471
493
472
494{-# NOINLINE array #-}
473{-# NOINLINE array #-}
495array :: Name
474array :: Name
496−array = "Array"
475+array = fromChars "Array"
497
476
498
477
499{-# NOINLINE dict #-}
478{-# NOINLINE dict #-}
500dict :: Name
479dict :: Name
501−dict = "Dict"
480+dict = fromChars "Dict"
502
481
503
482
504{-# NOINLINE tuple #-}
483{-# NOINLINE tuple #-}
505tuple :: Name
484tuple :: Name
506−tuple = "Tuple"
485+tuple = fromChars "Tuple"
507
486
508
487
509{-# NOINLINE jsArray #-}
488{-# NOINLINE jsArray #-}
510jsArray :: Name
489jsArray :: Name
511−jsArray = "JsArray"
490+jsArray = fromChars "JsArray"
512
491
513
492
514{-# NOINLINE task #-}
493{-# NOINLINE task #-}
515task :: Name
494task :: Name
516−task = "Task"
495+task = fromChars "Task"
517
496
518
497
519{-# NOINLINE router #-}
498{-# NOINLINE router #-}
520router :: Name
499router :: Name
521−router = "Router"
500+router = fromChars "Router"
522
501
523
502
524{-# NOINLINE cmd #-}
503{-# NOINLINE cmd #-}
525cmd :: Name
504cmd :: Name
526−cmd = "Cmd"
505+cmd = fromChars "Cmd"
527
506
528
507
529{-# NOINLINE sub #-}
508{-# NOINLINE sub #-}
530sub :: Name
509sub :: Name
531−sub = "Sub"
510+sub = fromChars "Sub"
532
511
533
512
534{-# NOINLINE platform #-}
513{-# NOINLINE platform #-}
535platform :: Name
514platform :: Name
536−platform = "Platform"
515+platform = fromChars "Platform"
537
516
538
517
539{-# NOINLINE virtualDom #-}
518{-# NOINLINE virtualDom #-}
540virtualDom :: Name
519virtualDom :: Name
541−virtualDom = "VirtualDom"
520+virtualDom = fromChars "VirtualDom"
542
521
543
522
544{-# NOINLINE shader #-}
523{-# NOINLINE shader #-}
545shader :: Name
524shader :: Name
546−shader = "Shader"
525+shader = fromChars "Shader"
547
526
548
527
549{-# NOINLINE debug #-}
528{-# NOINLINE debug #-}
550debug :: Name
529debug :: Name
551−debug = "Debug"
530+debug = fromChars "Debug"
552
531
553
532
554{-# NOINLINE debugger #-}
533{-# NOINLINE debugger #-}
555debugger :: Name
534debugger :: Name
556−debugger = "Debugger"
535+debugger = fromChars "Debugger"
557
536
558
537
559{-# NOINLINE bitwise #-}
538{-# NOINLINE bitwise #-}
560bitwise :: Name
539bitwise :: Name
561−bitwise = "Bitwise"
540+bitwise = fromChars "Bitwise"
562
541
563
542
564{-# NOINLINE basics #-}
543{-# NOINLINE basics #-}
565basics :: Name
544basics :: Name
566−basics = "Basics"
545+basics = fromChars "Basics"
567
546
568
547
569{-# NOINLINE utils #-}
548{-# NOINLINE utils #-}
570utils :: Name
549utils :: Name
571−utils = "Utils"
550+utils = fromChars "Utils"
572
551
573
552
574{-# NOINLINE negate #-}
553{-# NOINLINE negate #-}
575negate :: Name
554negate :: Name
576−negate = "negate"
555+negate = fromChars "negate"
577
556
578
557
579{-# NOINLINE true #-}
558{-# NOINLINE true #-}
580true :: Name
559true :: Name
581−true = "True"
560+true = fromChars "True"
582
561
583
562
584{-# NOINLINE false #-}
563{-# NOINLINE false #-}
585false :: Name
564false :: Name
586−false = "False"
565+false = fromChars "False"
587
566
588
567
589{-# NOINLINE value #-}
568{-# NOINLINE value #-}
590value :: Name
569value :: Name
591−value = "Value"
570+value = fromChars "Value"
592
571
593
572
594{-# NOINLINE node #-}
573{-# NOINLINE node #-}
595node :: Name
574node :: Name
596−node = "Node"
575+node = fromChars "Node"
597
576
598
577
599{-# NOINLINE program #-}
578{-# NOINLINE program #-}
600program :: Name
579program :: Name
601−program = "Program"
580+program = fromChars "Program"
581+
602
582
583+{-# NOINLINE _main #-}
584+_main :: Name
585+_main = fromChars "main"
603
586
587+
604−{-# NOINLINE main #-}
588+{-# NOINLINE _Main #-}
605−main :: Name
589+_Main :: Name
606−main = "main"
590+_Main = fromChars "Main"
607
591
608
592
609{-# NOINLINE dollar #-}
593{-# NOINLINE dollar #-}
610dollar :: Name
594dollar :: Name
611−dollar = "$"
595+dollar = fromChars "$"
612
596
613
597
614{-# NOINLINE identity #-}
598{-# NOINLINE identity #-}
615identity :: Name
599identity :: Name
616−identity = "identity"
600+identity = fromChars "identity"
617
601
618
602
619{-# NOINLINE replModule #-}
603{-# NOINLINE replModule #-}
620replModule :: Name
604replModule :: Name
621−replModule = "Elm_Repl"
605+replModule = fromChars "Elm_Repl"
606+
607+
608+{-# NOINLINE replValueToPrint #-}
609+replValueToPrint :: Name
610+replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hs+23−2
@@ -1,11 +1,14 @@
1module Data.NonEmptyList
1module Data.NonEmptyList
2 ( List(..)
2 ( List(..)
3+ , singleton
3 , toList
4 , toList
4 , sortBy
5 , sortBy
5 )
6 )
6 where
7 where
7
8
8
9
10+import Control.Monad (liftM2)
11+import Data.Binary (Binary, get, put)
9import qualified Data.List as List
12import qualified Data.List as List
10
13
11
14
@@ -17,6 +20,11 @@ data List a =
17 List a [a]
20 List a [a]
18
21
19
22
23+singleton :: a -> List a
24+singleton a =
25+ List a []
26+
27+
20toList :: List a -> [a]
28toList :: List a -> [a]
21toList (List x xs) =
29toList (List x xs) =
22 x:xs
30 x:xs
@@ -44,8 +52,12 @@ instance Foldable List where
44-- SORT BY
52-- SORT BY
45
53
46
54
47−sortBy :: (a -> a -> Ordering) -> List a -> List a
55+sortBy :: (Ord b) => (a -> b) -> List a -> List a
48−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
49 case List.sortBy comparison xs of
61 case List.sortBy comparison xs of
50 [] ->
62 [] ->
51 List x []
63 List x []
@@ -55,3 +67,12 @@ sortBy comparison (List x xs) =
55 LT -> List x (y:ys)
67 LT -> List x (y:ys)
56 EQ -> List x (y:ys)
68 EQ -> List x (y:ys)
57 GT -> List y (List.insertBy comparison x ys)
69 GT -> List y (List.insertBy comparison x ys)
70+
71+
72+
73+-- BINARY
74+
75+
76+instance (Binary a) => Binary (List a) where
77+ put (List x xs) = put x >> put xs
78+ get = liftM2 List get get
compiler/src/Data/Utf8.hs+157−300
@@ -1,37 +1,42 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Utf8
3module Data.Utf8
4− ( String
5− , Utf8(..)
4+ ( Utf8(..)
6− , VeryLong
7− , Under256
8 , isEmpty
5 , isEmpty
9 , empty
6 , empty
10 , size
7 , size
11 , contains
8 , contains
12− , containsDouble
13 , startsWith
9 , startsWith
14 , startsWithChar
10 , startsWithChar
15− , endsWithWord
11+ , endsWithWord8
16 , split
12 , split
17 , join
13 , join
18− , all
14+ --
19− , any
15+ , getUnder256
20− , toWord16
16+ , putUnder256
21− , fromWord16
17+ --
22− -- conversions
18+ , getVeryLong
23− , fromChars
19+ , putVeryLong
20+ --
24 , toChars
21 , toChars
25 , toBuilder
22 , toBuilder
23+ , toEscapedBuilder
24+ --
26 , fromPtr
25 , fromPtr
27− , fromChunks
26+ , fromSnippet
28− , Chunk(..)
27+ , fromChars
28+ --
29+ , MBA
30+ , newByteArray
31+ , copyFromPtr
32+ , writeWord8
33+ , freeze
29 )
34 )
30 where
35 where
31
36
32
37
33import Prelude hiding (String, all, any, concat)
38import Prelude hiding (String, all, any, concat)
34−import Data.Binary (Binary(..), Get, getWord8, putWord8)
39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)
35import Data.Binary.Put (putBuilder)
40import Data.Binary.Put (putBuilder)
36import Data.Binary.Get.Internal (readN)
41import Data.Binary.Get.Internal (readN)
37import Data.Bits ((.&.), shiftR)
42import Data.Bits ((.&.), shiftR)
@@ -39,7 +44,6 @@ import qualified Data.ByteString.Internal as B
39import qualified Data.ByteString.Builder.Internal as B
44import qualified Data.ByteString.Builder.Internal as B
40import qualified Data.Char as Char
45import qualified Data.Char as Char
41import qualified Data.List as List
46import qualified Data.List as List
42−import Data.String (IsString(..))
43import Foreign.ForeignPtr (touchForeignPtr)
47import Foreign.ForeignPtr (touchForeignPtr)
44import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
48import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
45import Foreign.Ptr (minusPtr, plusPtr)
49import Foreign.Ptr (minusPtr, plusPtr)
@@ -54,36 +58,35 @@ import GHC.Exts
54 , copyByteArray#
58 , copyByteArray#
55 , copyAddrToByteArray#
59 , copyAddrToByteArray#
56 , copyByteArrayToAddr#
60 , copyByteArrayToAddr#
57− , writeWord8Array#,
61+ , writeWord8Array#
58 )
62 )
59import GHC.IO
63import GHC.IO
60import GHC.ST (ST(ST), runST)
64import GHC.ST (ST(ST), runST)
61import GHC.Prim
65import GHC.Prim
62−import GHC.Word (Word8(W8#), Word16(W16#))
66+import GHC.Word (Word8(W8#))
67+
68+import qualified Parse.Primitives as P
63
69
64
70
65
71
66-- UTF-8
72-- UTF-8
67
73
68
74
69−data Utf8 size tipe =
75+data Utf8 tipe =
70 Utf8 ByteArray#
76 Utf8 ByteArray#
71
77
72
78
73−type String = Utf8 VERY_LONG STRING
74−type VeryLong t = Utf8 VERY_LONG t
75−type Under256 t = Utf8 UNDER_256 t
76−
77−data STRING
78−data VERY_LONG
79−data UNDER_256
80
79
80+-- EMPTY
81
81
82
82
83−-- IS EMPTY
83+{-# NOINLINE empty #-}
84+empty :: Utf8 t
85+empty =
86+ runST (freeze =<< newByteArray 0)
84
87
85
88
86−isEmpty :: Utf8 l t -> Bool
89+isEmpty :: Utf8 t -> Bool
87isEmpty (Utf8 ba#) =
90isEmpty (Utf8 ba#) =
88 isTrue# (sizeofByteArray# ba# ==# 0#)
91 isTrue# (sizeofByteArray# ba# ==# 0#)
89
92
@@ -92,7 +95,7 @@ isEmpty (Utf8 ba#) =
92-- SIZE
95-- SIZE
93
96
94
97
95−size :: Utf8 l t -> Int
98+size :: Utf8 t -> Int
96size (Utf8 ba#) =
99size (Utf8 ba#) =
97 I# (sizeofByteArray# ba#)
100 I# (sizeofByteArray# ba#)
98
101
@@ -101,7 +104,7 @@ size (Utf8 ba#) =
101-- CONTAINS
104-- CONTAINS
102
105
103
106
104−contains :: Word8 -> Utf8 l t -> Bool
107+contains :: Word8 -> Utf8 t -> Bool
105contains (W8# word#) (Utf8 ba#) =
108contains (W8# word#) (Utf8 ba#) =
106 containsHelp word# ba# 0# (sizeofByteArray# ba#)
109 containsHelp word# ba# 0# (sizeofByteArray# ba#)
107
110
@@ -117,32 +120,11 @@ containsHelp word# ba# !offset# len# =
117
120
118
121
119
122
120−-- CONTAINS DOUBLE
121−
122−
123−containsDouble :: Word8 -> Utf8 l t -> Bool
124−containsDouble (W8# word#) (Utf8 ba#) =
125− containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)
126−
127−
128−containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
129−containsDoubleHelp word# ba# !offset# len# =
130− let !offset1# = offset# +# 1# in
131− if isTrue# (offset1# <# len#) then
132− if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))
133− && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))
134− then True
135− else containsDoubleHelp word# ba# (offset# +# 1#) len#
136− else
137− False
138−
139−
140−
141-- STARTS WITH
123-- STARTS WITH
142
124
143
125
144{-# INLINE startsWith #-}
126{-# INLINE startsWith #-}
145−startsWith :: Utf8 l t -> Utf8 l t -> Bool
127+startsWith :: Utf8 t -> Utf8 t -> Bool
146startsWith (Utf8 ba1#) (Utf8 ba2#) =
128startsWith (Utf8 ba1#) (Utf8 ba2#) =
147 let
129 let
148 !len1# = sizeofByteArray# ba1#
130 !len1# = sizeofByteArray# ba1#
@@ -157,9 +139,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =
157-- STARTS WITH CHAR
139-- STARTS WITH CHAR
158
140
159
141
160−startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
161−startsWithChar isGood str@(Utf8 ba#) =
143+startsWithChar isGood bytes@(Utf8 ba#) =
162− if isEmpty str then
144+ if isEmpty bytes then
163 False
145 False
164 else
146 else
165 let
147 let
@@ -177,8 +159,8 @@ startsWithChar isGood str@(Utf8 ba#) =
177-- ENDS WITH WORD
159-- ENDS WITH WORD
178
160
179
161
180−endsWithWord :: Word8 -> Utf8 l t -> Bool
162+endsWithWord8 :: Word8 -> Utf8 t -> Bool
181−endsWithWord (W8# w#) (Utf8 ba#) =
163+endsWithWord8 (W8# w#) (Utf8 ba#) =
182 let len# = sizeofByteArray# ba# in
164 let len# = sizeofByteArray# ba# in
183 isTrue# (len# ># 0#)
165 isTrue# (len# ># 0#)
184 &&
166 &&
@@ -189,12 +171,12 @@ endsWithWord (W8# w#) (Utf8 ba#) =
189-- SPLIT
171-- SPLIT
190
172
191
173
192−split :: Word8 -> String -> [String]
174+split :: Word8 -> Utf8 t -> [Utf8 t]
193split (W8# divider#) str@(Utf8 ba#) =
175split (W8# divider#) str@(Utf8 ba#) =
194 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
195
177
196
178
197−splitHelp :: String -> Int -> [Int] -> [String]
179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
198splitHelp str start offsets =
180splitHelp str start offsets =
199 case offsets of
181 case offsets of
200 [] ->
182 [] ->
@@ -215,7 +197,7 @@ findDividers divider# ba# !offset# len# revOffsets =
215 reverse revOffsets
197 reverse revOffsets
216
198
217
199
218−unsafeSlice :: String -> Int -> Int -> String
200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
219unsafeSlice str start end =
201unsafeSlice str start end =
220 let !len = end - start in
202 let !len = end - start in
221 if len == 0 then
203 if len == 0 then
@@ -231,7 +213,7 @@ unsafeSlice str start end =
231-- JOIN
213-- JOIN
232
214
233
215
234−join :: Word8 -> [String] -> String
216+join :: Word8 -> [Utf8 t] -> Utf8 t
235join sep strings =
217join sep strings =
236 case strings of
218 case strings of
237 [] ->
219 [] ->
@@ -245,7 +227,7 @@ join sep strings =
245 freeze mba
227 freeze mba
246
228
247
229
248−joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
249joinHelp sep mba offset str strings =
231joinHelp sep mba offset str strings =
250 let
232 let
251 !len = size str
233 !len = size str
@@ -263,46 +245,10 @@ joinHelp sep mba offset str strings =
263
245
264
246
265
247
266−-- ALL
267−
268−
269−all :: (Char -> Bool) -> Utf8 l t -> Bool
270−all isGood utf8 =
271− not (any (not . isGood) utf8)
272−
273−
274−
275−-- ANY
276−
277−
278−any :: (Char -> Bool) -> Utf8 l t -> Bool
279−any isGood (Utf8 ba#) =
280− anyHelp isGood ba# 0# (sizeofByteArray# ba#)
281−
282−
283−anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool
284−anyHelp isGood ba# offset# len# =
285− if isTrue# (offset# >=# len#) then
286− False
287− else
288− let
289− !w# = indexWord8Array# ba# offset#
290− !(# char, width# #)
291− | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
292− | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
293− | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
294− | True = (# chr4 ba# offset# w#, 4# #)
295− in
296− if isGood char
297− then True
298− else anyHelp isGood ba# (offset# +# width#) len#
299−
300−
301−
302-- EQUAL
248-- EQUAL
303
249
304
250
305−instance Eq (Utf8 l t) where
251+instance Eq (Utf8 t) where
306 (==) (Utf8 ba1#) (Utf8 ba2#) =
252 (==) (Utf8 ba1#) (Utf8 ba2#) =
307 let
253 let
308 !len1# = sizeofByteArray# ba1#
254 !len1# = sizeofByteArray# ba1#
@@ -315,9 +261,11 @@ instance Eq (Utf8 l t) where
315
261
316
262
317-- COMPARE
263-- COMPARE
264+--
265+-- TODO: is it fine to sort by length and only compare bytes on length ties?
266+--
318
267
319−
320−instance Ord (Utf8 l t) where
268+instance Ord (Utf8 t) where
321 compare (Utf8 ba1#) (Utf8 ba2#) =
269 compare (Utf8 ba1#) (Utf8 ba2#) =
322 let
270 let
323 !len1# = sizeofByteArray# ba1#
271 !len1# = sizeofByteArray# ba1#
@@ -334,84 +282,20 @@ instance Ord (Utf8 l t) where
334
282
335
283
336
284
337−-- TO WORD16
338−
339−
340−toWord16 :: String -> Maybe Word16
341−toWord16 (Utf8 ba#) =
342− let !len# = sizeofByteArray# ba# in
343− if isTrue# (len# ==# 0#) then
344− Nothing
345− else
346− let !w# = indexWord8Array# ba# 0# in
347− if isTrue# (eqWord# w# 0x30##) then
348− if isTrue# (len# ==# 1#) then Just 0 else Nothing
349− else
350− toWordHelp ba# 0# len# 0##
351−
352−
353−toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16
354−toWordHelp ba# offset# len# number# =
355− if isTrue# (offset# <# len#) then
356− let !w# = indexWord8Array# ba# offset# in
357− if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then
358− let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in
359− toWordHelp ba# (offset# +# 1#) len# newNumber#
360− else
361− Nothing
362− else
363− Just (W16# number#)
364−
365−
366−
367−-- FROM WORD16
368−
369−
370−fromWord16 :: Word16 -> String
371−fromWord16 n =
372− runST $
373− do let !size = getWordSize n
374− mba <- newByteArray size
375− writeDigits mba (size - 1) n
376− freeze mba
377−
378−
379−getWordSize :: Word16 -> Int
380−getWordSize n
381− | n < 10 = 1
382− | n < 100 = 2
383− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
384−
385−
386−writeDigits :: MBA s -> Int -> Word16 -> ST s ()
387−writeDigits !mba !offset !n =
388− do let (q,r) = quotRem n 10
389− writeWord8 mba offset (0x30 + fromIntegral r)
390− if q <= 0
391− then return ()
392− else writeDigits mba (offset-1) q
393−
394−
395−
396-- FROM STRING
285-- FROM STRING
397
286
398
287
399−fromChars :: [Char] -> Utf8 l t
288+fromChars :: [Char] -> Utf8 t
400−fromChars =
289+fromChars chars =
401− fromString
402−
403−
404−instance IsString (Utf8 l t) where
405− fromString str =
406− runST
290+ runST
407− (
291+ (
408− do mba <- newByteArray (sum (map getWidth str))
292+ do mba <- newByteArray (sum (map getWidth chars))
409− writeString mba 0 str
293+ writeChars mba 0 chars
410− )
294+ )
411
295
412
296
413−writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
414−writeString !mba !offset chars =
298+writeChars !mba !offset chars =
415 case chars of
299 case chars of
416 [] ->
300 [] ->
417 freeze mba
301 freeze mba
@@ -419,25 +303,25 @@ writeString !mba !offset chars =
419 char : chars
303 char : chars
420 | n < 0x80 ->
304 | n < 0x80 ->
421 do writeWord8 mba (offset ) (fromIntegral n)
305 do writeWord8 mba (offset ) (fromIntegral n)
422− writeString mba (offset + 1) chars
306+ writeChars mba (offset + 1) chars
423
307
424 | n < 0x800 ->
308 | n < 0x800 ->
425 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
309 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
426 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
310 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
427− writeString mba (offset + 2) chars
311+ writeChars mba (offset + 2) chars
428
312
429 | n < 0x10000 ->
313 | n < 0x10000 ->
430 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
314 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
431 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
315 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
432 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
316 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
433− writeString mba (offset + 3) chars
317+ writeChars mba (offset + 3) chars
434
318
435 | otherwise ->
319 | otherwise ->
436 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
320 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
437 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
321 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
438 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
322 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
439 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
323 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
440− writeString mba (offset + 4) chars
324+ writeChars mba (offset + 4) chars
441
325
442 where
326 where
443 n = Char.ord char
327 n = Char.ord char
@@ -455,10 +339,10 @@ getWidth char
455
339
456
340
457
341
458−-- TO STRING
342+-- TO CHARS
459
343
460
344
461−toChars :: Utf8 l t -> [Char]
345+toChars :: Utf8 t -> [Char]
462toChars (Utf8 ba#) =
346toChars (Utf8 ba#) =
463 toCharsHelp ba# 0# (sizeofByteArray# ba#)
347 toCharsHelp ba# 0# (sizeofByteArray# ba#)
464
348
@@ -528,13 +412,13 @@ chr4 ba# offset# firstWord# =
528
412
529
413
530{-# INLINE toBuilder #-}
414{-# INLINE toBuilder #-}
531−toBuilder :: Utf8 l t -> B.Builder
415+toBuilder :: Utf8 t -> B.Builder
532toBuilder =
416toBuilder =
533 \bytes -> B.builder (toBuilderHelp bytes)
417 \bytes -> B.builder (toBuilderHelp bytes)
534
418
535
419
536{-# INLINE toBuilderHelp #-}
420{-# INLINE toBuilderHelp #-}
537−toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
538toBuilderHelp !bytes@(Utf8 ba#) k =
422toBuilderHelp !bytes@(Utf8 ba#) k =
539 go 0 (I# (sizeofByteArray# ba#))
423 go 0 (I# (sizeofByteArray# ba#))
540 where
424 where
@@ -554,144 +438,109 @@ toBuilderHelp !bytes@(Utf8 ba#) k =
554
438
555
439
556
440
557−-- FROM PTR
441+-- TO ESCAPED BUILDER
558
442
559
443
444+{-# INLINE toEscapedBuilder #-}
560−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
445+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
561−fromPtr pos end =
446+toEscapedBuilder before after =
562− unsafeDupablePerformIO (stToIO (
447+ \name -> B.builder (toEscapedBuilderHelp before after name)
563− do let !len = minusPtr end pos
564− mba <- newByteArray len
565− copyFromPtr pos mba 0 len
566− freeze mba
567− ))
568
448
569
449
450+{-# INLINE toEscapedBuilderHelp #-}
451+toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a
452+toEscapedBuilderHelp before after !name@(Utf8 ba#) k =
453+ go 0 (I# (sizeofByteArray# ba#))
454+ where
455+ go !offset !len !(B.BufferRange bOffset bEnd) =
456+ let
457+ !bLen = minusPtr bEnd bOffset
458+ in
459+ if len <= bLen then
460+ do -- PERF test if writing word-by-word is faster
461+ copyToPtr name offset bOffset len
462+ escape before after bOffset name offset len 0
463+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
464+ k newBufferRange
465+ else
466+ do copyToPtr name offset bOffset bLen
467+ escape before after bOffset name offset bLen 0
468+ let !newOffset = offset + bLen
469+ let !newLength = len - bLen
470+ return $ B.bufferFull 1 bEnd (go newOffset newLength)
471+
472+
473+escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()
474+escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
475+ if isTrue# (i# <# len#) then
476+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
477+ then
478+ do writeWordToPtr ptr i after
479+ escape before after ptr name offset len (i + 1)
480+ else
481+ do escape before after ptr name offset len (i + 1)
482+
483+ else
484+ return ()
570
485
571−-- FROM CHUNKS
572
486
573
487
574−data Chunk
488+-- FROM PTR
575− = Slice (Ptr Word8) Int
576− | Escape Word8
577− | CodePoint Int
578
489
579
490
580−fromChunks :: [Chunk] -> Utf8 l t
491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
581−fromChunks chunks =
492+fromPtr pos end =
582 unsafeDupablePerformIO (stToIO (
493 unsafeDupablePerformIO (stToIO (
583− do let !len = sum (map chunkToWidth chunks)
494+ do let !len = minusPtr end pos
584 mba <- newByteArray len
495 mba <- newByteArray len
585− writeChunks mba 0 chunks
496+ copyFromPtr pos mba 0 len
586 freeze mba
497 freeze mba
587 ))
498 ))
588
499
589
500
590−chunkToWidth :: Chunk -> Int
591−chunkToWidth chunk =
592− case chunk of
593− Slice _ len ->
594− len
595−
596− Escape _ ->
597− 2
598−
599− CodePoint code ->
600− if code < 0xFFFF then 6 else 12
601−
602−
603−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
604−writeChunks mba offset chunks =
605− case chunks of
606− [] ->
607− return ()
608−
609− chunk : chunks ->
610− case chunk of
611− Slice ptr len ->
612− do copyFromPtr ptr mba offset len
613− let !newOffset = offset + len
614− writeChunks mba newOffset chunks
615−
616− Escape word ->
617− do writeWord8 mba offset 0x5C {- \ -}
618− writeWord8 mba (offset + 1) word
619− let !newOffset = offset + 2
620− writeChunks mba newOffset chunks
621−
622− CodePoint code ->
623− if code < 0xFFFF then
624− do writeCode mba offset code
625− let !newOffset = offset + 6
626− writeChunks mba newOffset chunks
627− else
628− do let (hi,lo) = divMod (code - 0x10000) 0x400
629− writeCode mba (offset ) (hi + 0xD800)
630− writeCode mba (offset + 6) (lo + 0xDC00)
631− let !newOffset = offset + 12
632− writeChunks mba newOffset chunks
633−
634−
635−-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
636−writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
637−writeCode mba offset code =
638− do writeWord8 mba offset 0x5C {- \ -}
639− writeWord8 mba offset 0x75 {- u -}
640− writeHex mba (offset + 2) (shiftR code 12)
641− writeHex mba (offset + 3) (shiftR code 8)
642− writeHex mba (offset + 4) (shiftR code 4)
643− writeHex mba (offset + 5) code
644−
645−
646−writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
647−writeHex mba !offset !bits =
648− do let !n = fromIntegral bits .&. 0x0F
649− writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
650
501
502+-- FROM SNIPPET
651
503
652
504
653−-- UNDER 256 BINARY
505+fromSnippet :: P.Snippet -> Utf8 t
654−
506+fromSnippet (P.Snippet fptr off len _ _) =
655−
507+ unsafeDupablePerformIO (stToIO (
656−instance Binary (Utf8 UNDER_256 t) where
508+ do mba <- newByteArray len
657− put bytes@(Utf8 ba#) =
509+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
658− do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
510+ copyFromPtr pos mba 0 len
659− putBuilder (toBuilder bytes)
511+ freeze mba
660− get =
512+ ))
661− getUnder256 =<< getWord8
662
513
663
514
664−{-# INLINE getUnder256 #-}
665−getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
666−getUnder256 w =
667− let !n = fromIntegral w in
668− readN n (copyFromByteString n)
669
515
516+-- BINARY
670
517
671
518
672−-- VERY LONG BINARY
519+putUnder256 :: Utf8 t -> Put
520+putUnder256 bytes =
521+ do putWord8 (fromIntegral (size bytes))
522+ putBuilder (toBuilder bytes)
673
523
674
524
675−instance Binary (Utf8 VERY_LONG t) where
525+getUnder256 :: Get (Utf8 t)
676− put str =
526+getUnder256 =
677− do put (size str)
527+ do word <- getWord8
678− putBuilder (toBuilder str)
528+ let !n = fromIntegral word
679− get =
529+ readN n (copyFromByteString n)
680− getVeryLong =<< get
681
530
682
531
683−{-# INLINE getVeryLong #-}
532+putVeryLong :: Utf8 t -> Put
684−getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
533+putVeryLong bytes =
685−getVeryLong n =
534+ do put (size bytes)
686− if n > 0
535+ putBuilder (toBuilder bytes)
687− then readN n (copyFromByteString n)
688− else return empty
689
536
690
537
691−{-# NOINLINE empty #-}
538+getVeryLong :: Get (Utf8 t)
692−empty :: Utf8 l t
539+getVeryLong =
693−empty =
540+ do n <- get
694− runST (freeze =<< newByteArray 0)
541+ if n > 0
542+ then readN n (copyFromByteString n)
543+ else return empty
695
544
696
545
697
546
@@ -699,7 +548,7 @@ empty =
699
548
700
549
701{-# INLINE copyFromByteString #-}
550{-# INLINE copyFromByteString #-}
702−copyFromByteString :: Int -> B.ByteString -> Utf8 l t
551+copyFromByteString :: Int -> B.ByteString -> Utf8 t
703copyFromByteString len (B.PS fptr offset _) =
552copyFromByteString len (B.PS fptr offset _) =
704 unsafeDupablePerformIO
553 unsafeDupablePerformIO
705 (
554 (
@@ -718,21 +567,21 @@ data MBA s =
718 MBA# (MutableByteArray# s)
567 MBA# (MutableByteArray# s)
719
568
720
569
721−newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
722newByteArray (I# len#) =
571newByteArray (I# len#) =
723 ST $ \s ->
572 ST $ \s ->
724 case newByteArray# len# s of
573 case newByteArray# len# s of
725 (# s, mba# #) -> (# s, MBA# mba# #)
574 (# s, mba# #) -> (# s, MBA# mba# #)
726
575
727
576
728−freeze :: MBA s -> ST s (Utf8 l t)
577+freeze :: MBA s -> ST s (Utf8 t)
729freeze (MBA# mba#) =
578freeze (MBA# mba#) =
730 ST $ \s ->
579 ST $ \s ->
731 case unsafeFreezeByteArray# mba# s of
580 case unsafeFreezeByteArray# mba# s of
732 (# s, ba# #) -> (# s, Utf8 ba# #)
581 (# s, ba# #) -> (# s, Utf8 ba# #)
733
582
734
583
735−copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
736copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
585copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
737 ST $ \s ->
586 ST $ \s ->
738 case copyByteArray# ba# offset# mba# i# len# s of
587 case copyByteArray# ba# offset# mba# i# len# s of
@@ -746,11 +595,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
746 s -> (# s, () #)
595 s -> (# s, () #)
747
596
748
597
749−copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
750copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
599copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
751− IO $ \s ->
600+ IO $ \s ->
752− case copyByteArrayToAddr# ba# offset# mba# len# s of
601+ case copyByteArrayToAddr# ba# offset# mba# len# s of
753− s -> (# s, () #)
602+ s -> (# s, () #)
754
603
755
604
756{-# INLINE writeWord8 #-}
605{-# INLINE writeWord8 #-}
@@ -759,3 +608,11 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
759 ST $ \s ->
608 ST $ \s ->
760 case writeWord8Array# mba# offset# w# s of
609 case writeWord8Array# mba# offset# w# s of
761 s -> (# s, () #)
610 s -> (# s, () #)
611+
612+
613+{-# INLINE writeWordToPtr #-}
614+writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()
615+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
616+ IO $ \s ->
617+ case writeWord8OffAddr# addr# offset# word# s of
618+ s -> (# s, () #)
compiler/src/Elm/Compiler/Imports.hs+4−13
@@ -1,7 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Imports
3module Elm.Compiler.Imports
4− ( addDefaults
4+ ( defaults
5 )
5 )
6 where
6 where
7
7
@@ -14,15 +14,6 @@ import qualified Reporting.Annotation as A
14
14
15
15
16
16
17−-- ADD DEFAULTS
18−
19−
20−addDefaults :: [Src.Import] -> [Src.Import]
21−addDefaults imports =
22− defaults ++ imports
23−
24−
25−
26-- DEFAULTS
17-- DEFAULTS
27
18
28
19
@@ -58,14 +49,14 @@ closed =
58
49
59typeOpen :: Name.Name -> Src.Exposing
50typeOpen :: Name.Name -> Src.Exposing
60typeOpen name =
51typeOpen name =
61− Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]
52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
62
53
63
54
64typeClosed :: Name.Name -> Src.Exposing
55typeClosed :: Name.Name -> Src.Exposing
65typeClosed name =
56typeClosed name =
66− Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
67
58
68
59
69operator :: Name.Name -> Src.Exposing
60operator :: Name.Name -> Src.Exposing
70operator op =
61operator op =
71− Src.Explicit [ A.At A.zero (Src.Operator op) ]
62+ Src.Explicit [ Src.Operator A.zero op ]
compiler/src/Elm/Compiler/Type.hs+26−27
@@ -15,9 +15,12 @@ module Elm.Compiler.Type
15
15
16
16
17import qualified Data.Name as Name
17import qualified Data.Name as Name
18−import qualified Data.Utf8 as Utf8
19
18
20import qualified AST.Source as Src
19import qualified AST.Source as Src
20+import qualified Json.Decode as D
21+import qualified Json.Encode as E
22+import Json.Encode ((==>))
23+import qualified Json.String as Json
21import qualified Parse.Primitives as P
24import qualified Parse.Primitives as P
22import qualified Parse.Type as Type
25import qualified Parse.Type as Type
23import qualified Reporting.Annotation as A
26import qualified Reporting.Annotation as A
@@ -25,10 +28,6 @@ import qualified Reporting.Doc as D
25import qualified Reporting.Render.Type as RT
28import qualified Reporting.Render.Type as RT
26import qualified Reporting.Render.Type.Localizer as L
29import qualified Reporting.Render.Type.Localizer as L
27
30
28−import qualified Json.Decode as D
29−import qualified Json.Encode as E
30−import Json.Encode ((==>))
31−
32
31
33
32
34-- TYPES
33-- TYPES
@@ -114,18 +113,16 @@ collectLambdas tipe =
114
113
115encode :: Type -> E.Value
114encode :: Type -> E.Value
116encode tipe =
115encode tipe =
117− E.string $ Utf8.fromChars $ D.toLine (toDoc L.empty RT.None tipe)
116+ E.chars $ D.toLine (toDoc L.empty RT.None tipe)
118
117
119
118
120decoder :: D.Decoder () Type
119decoder :: D.Decoder () Type
121decoder =
120decoder =
122− do str <- D.string
121+ let
123− case P.fromByteString Type.expression (error "TODO turn Utf8 to something that can be parsed" str) of
122+ parser =
124− P.Ok (tipe, _, _) _ ->
123+ P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
125− return (fromRawType tipe)
124+ in
126−
125+ D.customString parser (\_ _ -> ())
127− P.Err _ _ _ _ ->
128− D.failure ()
129
126
130
127
131fromRawType :: Src.Type -> Type
128fromRawType :: Src.Type -> Type
@@ -167,29 +164,31 @@ encodeMetadata :: DebugMetadata -> E.Value
167encodeMetadata (DebugMetadata msg aliases unions) =
164encodeMetadata (DebugMetadata msg aliases unions) =
168 E.object
165 E.object
169 [ "message" ==> encode msg
166 [ "message" ==> encode msg
170− , "aliases" ==> E.object (map toAliasField aliases)
167+ , "aliases" ==> E.object (map toTypeAliasField aliases)
171− , "unions" ==> E.object (map toUnionField unions)
168+ , "unions" ==> E.object (map toCustomTypeField unions)
172 ]
169 ]
173
170
174
171
175−toAliasField :: Alias -> ( Utf8.String, E.Value )
172+toTypeAliasField :: Alias -> ( Json.String, E.Value )
176−toAliasField (Alias name args tipe) =
173+toTypeAliasField (Alias name args tipe) =
177− Name.toUtf8 name ==>
174+ ( Json.fromName name
178− E.object
175+ , E.object
179 [ "args" ==> E.list E.name args
176 [ "args" ==> E.list E.name args
180 , "type" ==> encode tipe
177 , "type" ==> encode tipe
181 ]
178 ]
179+ )
182
180
183
181
184−toUnionField :: Union -> ( Utf8.String, E.Value )
182+toCustomTypeField :: Union -> ( Json.String, E.Value )
185−toUnionField (Union name args constructors) =
183+toCustomTypeField (Union name args constructors) =
186− Name.toUtf8 name ==>
184+ ( Json.fromName name
187− E.object
185+ , E.object
188 [ "args" ==> E.list E.name args
186 [ "args" ==> E.list E.name args
189− , "tags" ==> E.object (map toCtorObject constructors)
187+ , "tags" ==> E.object (map toVariantObject constructors)
190 ]
188 ]
189+ )
191
190
192
191
193−toCtorObject :: (Name.Name, [Type]) -> ( Utf8.String, E.Value )
192+toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )
194−toCtorObject (name, args) =
193+toVariantObject (name, args) =
195− Name.toUtf8 name ==> E.list encode args
194+ ( Json.fromName name, E.list encode args )
compiler/src/Elm/Compiler/Type/Extract.hs+1−1
@@ -87,7 +87,7 @@ toPublicName (ModuleName.Canonical _ home) name =
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+55−77
@@ -5,9 +5,6 @@ module Elm.Constraint
5 , exactly
5 , exactly
6 , anything
6 , anything
7 , toChars
7 , toChars
8− , toString
9− , Error(..)
10− , fromString
11 , satisfies
8 , satisfies
12 , check
9 , check
13 , intersect
10 , intersect
@@ -16,6 +13,8 @@ module Elm.Constraint
16 , untilNextMajor
13 , untilNextMajor
17 , untilNextMinor
14 , untilNextMinor
18 , expand
15 , expand
16+ --
17+ , Error(..)
19 , decoder
18 , decoder
20 , encode
19 , encode
21 )
20 )
@@ -24,11 +23,12 @@ module Elm.Constraint
24
23
25import Control.Monad (liftM4)
24import Control.Monad (liftM4)
26import Data.Binary (Binary, get, put, getWord8, putWord8)
25import Data.Binary (Binary, get, put, getWord8, putWord8)
27−import qualified Data.Utf8 as Utf8
28
26
29import qualified Elm.Version as V
27import qualified Elm.Version as V
30import qualified Json.Decode as D
28import qualified Json.Decode as D
31import qualified Json.Encode as E
29import qualified Json.Encode as E
30+import qualified Parse.Primitives as P
31+import Parse.Primitives (Row, Col)
32
32
33
33
34
34
@@ -61,78 +61,21 @@ anything =
61
61
62
62
63
63
64−-- TO STRING
64+-- TO CHARS
65
65
66
66
67−toChars :: Constraint -> String
67+toChars :: Constraint -> [Char]
68toChars constraint =
68toChars constraint =
69− Utf8.toChars (toString constraint)
70−
71−
72−toString :: Constraint -> Utf8.String
73−toString constraint =
74 case constraint of
69 case constraint of
75 Range lower lowerOp upperOp upper ->
70 Range lower lowerOp upperOp upper ->
76− Utf8.join 0x20 {- -}
71+ V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper
77− [ V.toString lower
78− , toStringHelp lowerOp
79− , "v"
80− , toStringHelp upperOp
81− , V.toString upper
82− ]
83
72
84
73
85−toStringHelp :: Op -> Utf8.String
74+opToChars :: Op -> [Char]
86−toStringHelp op =
75+opToChars op =
87 case op of
76 case op of
88− Less -> "<"
77+ Less -> " < "
89− LessOrEqual -> "<="
78+ LessOrEqual -> " <= "
90−
91−
92−
93−-- FROM STRING
94−
95−
96−data Error
97− = BadLower Utf8.String
98− | BadUpper Utf8.String
99− | BadFormat
100− | InvalidOp
101− | InvalidRange V.Version V.Version
102−
103−
104−fromString :: Utf8.String -> Either Error Constraint
105−fromString string =
106− case Utf8.split 0x20 {- -} string of
107− [lower, lowerOp, "v", upperOp, upper] ->
108− do lo <- versionFromString lower BadLower
109− lop <- opFromString lowerOp
110− hop <- opFromString upperOp
111− hi <- versionFromString upper BadUpper
112− if lo < hi
113− then Right (Range lo lop hop hi)
114− else Left (InvalidRange lo hi)
115−
116− _ ->
117− Left BadFormat
118−
119−
120−versionFromString :: Utf8.String -> (Utf8.String -> Error) -> Either Error V.Version
121−versionFromString string toError =
122− case V.fromString string of
123− Just vsn ->
124− Right vsn
125−
126− Nothing ->
127− Left (toError string)
128−
129−
130−opFromString :: Utf8.String -> Either Error Op
131−opFromString text =
132− case text of
133− "<=" -> Right LessOrEqual
134− "<" -> Right Less
135− _ -> Left InvalidOp
136
79
137
80
138
81
@@ -245,18 +188,12 @@ expand constraint@(Range lower lowerOp upperOp upper) version
245
188
246encode :: Constraint -> E.Value
189encode :: Constraint -> E.Value
247encode constraint =
190encode constraint =
248− E.string (toString constraint)
191+ E.chars (toChars constraint)
249
192
250
193
251decoder :: D.Decoder Error Constraint
194decoder :: D.Decoder Error Constraint
252decoder =
195decoder =
253− do str <- D.string
196+ D.customString parser BadFormat
254− case fromString str of
255− Right constraint ->
256− return constraint
257−
258− Left err ->
259− D.failure err
260
197
261
198
262
199
@@ -279,4 +216,45 @@ instance Binary Op where
279 case n of
216 case n of
280 0 -> return Less
217 0 -> return Less
281 1 -> return LessOrEqual
218 1 -> return LessOrEqual
282− _ -> error "binary encoding of Op was corrupted"
219+ _ -> fail "binary encoding of Op was corrupted"
220+
221+
222+
223+-- PARSER
224+
225+
226+data Error
227+ = BadFormat Row Col
228+ | InvalidRange V.Version V.Version
229+
230+
231+parser :: P.Parser Error Constraint
232+parser =
233+ do lower <- parseVersion
234+ P.word1 0x20 {- -} BadFormat
235+ loOp <- parseOp
236+ P.word1 0x20 {- -} BadFormat
237+ P.word1 0x76 {-v-} BadFormat
238+ P.word1 0x20 {- -} BadFormat
239+ hiOp <- parseOp
240+ P.word1 0x20 {- -} BadFormat
241+ higher <- parseVersion
242+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
243+ if lower < higher
244+ then eok (Range lower loOp hiOp higher) state
245+ else eerr row col (\_ _ -> InvalidRange lower higher)
246+
247+
248+parseVersion :: P.Parser Error V.Version
249+parseVersion =
250+ P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser
251+
252+
253+parseOp :: P.Parser Error Op
254+parseOp =
255+ do P.word1 0x3C {-<-} BadFormat
256+ P.oneOfWithFallback
257+ [ do P.word1 0x3D {-=-} BadFormat
258+ return LessOrEqual
259+ ]
260+ Less
compiler/src/Elm/Docs.hs+218−158
@@ -1,8 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
3module Elm.Docs
3module Elm.Docs
4 ( Documentation
4 ( Documentation
5− , toDict
6 , Module(..)
5 , Module(..)
7 , fromModule
6 , fromModule
8 , Union(..)
7 , Union(..)
@@ -18,33 +17,35 @@ module Elm.Docs
18 where
17 where
19
18
20
19
21−import qualified Data.ByteString as B
20+import qualified Data.Coerce as Coerce
22import qualified Data.List as List
21import qualified Data.List as List
23import Data.Map ((!))
22import Data.Map ((!))
24import qualified Data.Map as Map
23import qualified Data.Map as Map
24+import qualified Data.Map.Merge.Strict as Map
25import qualified Data.Name as Name
25import qualified Data.Name as Name
26−import qualified Data.Text as Text
26+import qualified Data.NonEmptyList as NE
27−import qualified Data.Text.Encoding as Text
27+import qualified Data.OneOrMore as OneOrMore
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr)
28
30
29import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
32+import qualified AST.Source as Src
30import qualified AST.Utils.Binop as Binop
33import qualified AST.Utils.Binop as Binop
31−import qualified Data.OneOrMore as OneOrMore
32import qualified Elm.Compiler.Type as Type
34import qualified Elm.Compiler.Type as Type
33import qualified Elm.Compiler.Type.Extract as Extract
35import qualified Elm.Compiler.Type.Extract as Extract
34import qualified Elm.ModuleName as ModuleName
36import qualified Elm.ModuleName as ModuleName
35import qualified Json.Decode as D
37import qualified Json.Decode as D
36import qualified Json.Encode as E
38import qualified Json.Encode as E
37import Json.Encode ((==>))
39import Json.Encode ((==>))
40+import qualified Json.String as Json
41+import Parse.Primitives (Row, Col, word1)
42+import qualified Parse.Primitives as P
43+import qualified Parse.Space as Space
44+import qualified Parse.Symbol as Symbol
45+import qualified Parse.Variable as Var
38import qualified Reporting.Annotation as A
46import qualified Reporting.Annotation as A
39−import qualified Reporting.Error as Error
40import qualified Reporting.Error.Docs as E
47import qualified Reporting.Error.Docs as E
41−import qualified Reporting.Region as R
42import qualified Reporting.Result as Result
48import qualified Reporting.Result as Result
43−import Parse.Primitives (Parser)
44−import qualified Parse.Primitives as P
45−import qualified Parse.Primitives.Symbol as Symbol
46−import qualified Parse.Primitives.Variable as Var
47−import qualified Parse.Primitives.Whitespace as W
48
49
49
50
50
51
@@ -55,21 +56,6 @@ type Documentation =
55 Map.Map Name.Name Module
56 Map.Map Name.Name Module
56
57
57
58
58−toDict :: [Module] -> Documentation
59−toDict modules =
60− Map.fromList (map toPair modules)
61−
62−
63−
64−toPair :: Module -> (Name.Name, Module)
65−toPair modul@(Module name _ _ _ _ _) =
66− (name, modul)
67−
68−
69−
70−-- MODULES
71−
72−
73data Module =
59data Module =
74 Module
60 Module
75 { _name :: Name.Name
61 { _name :: Name.Name
@@ -80,9 +66,7 @@ data Module =
80 , _binops :: Map.Map Name.Name Binop
66 , _binops :: Map.Map Name.Name Binop
81 }
67 }
82
68
83−
84−type Comment = Text.Text
69+type Comment = Json.String
85−
86
70
87data Alias = Alias Comment [Name.Name] Type.Type
71data Alias = Alias Comment [Name.Name] Type.Type
88data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
72data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -91,14 +75,19 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
91
75
92
76
93
77
94−-- JSON ENCODE / DECODE
78+-- JSON
79+
80+
81+encode :: Documentation -> E.Value
82+encode docs =
83+ E.list encodeModule (Map.elems docs)
95
84
96
85
97−encode :: Module -> E.Value
86+encodeModule :: Module -> E.Value
98−encode (Module name comment unions aliases values binops) =
87+encodeModule (Module name comment unions aliases values binops) =
99 E.object $
88 E.object $
100 [ "name" ==> ModuleName.encode name
89 [ "name" ==> ModuleName.encode name
101− , "comment" ==> E.text comment
90+ , "comment" ==> E.string comment
102 , "unions" ==> E.list encodeUnion (Map.toList unions)
91 , "unions" ==> E.list encodeUnion (Map.toList unions)
103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
92 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
104 , "values" ==> E.list encodeValue (Map.toList values)
93 , "values" ==> E.list encodeValue (Map.toList values)
@@ -107,16 +96,31 @@ encode (Module name comment unions aliases values binops) =
107
96
108
97
109data Error
98data Error
110− = BadAssociativity Text.Text
99+ = BadAssociativity
111− | BadName
100+ | BadModuleName
112 | BadType
101 | BadType
113
102
114
103
115−decoder :: D.Decoder Error Module
104+decoder :: D.Decoder Error Documentation
116decoder =
105decoder =
106+ toDict <$> D.list moduleDecoder
107+
108+
109+toDict :: [Module] -> Documentation
110+toDict modules =
111+ Map.fromList (map toDictHelp modules)
112+
113+
114+toDictHelp :: Module -> (Name.Name, Module)
115+toDictHelp modul@(Module name _ _ _ _ _) =
116+ (name, modul)
117+
118+
119+moduleDecoder :: D.Decoder Error Module
120+moduleDecoder =
117 Module
121 Module
118− <$> D.field "name" nameDecoder
122+ <$> D.field "name" moduleNameDecoder
119− <*> D.field "comment" D.text
123+ <*> D.field "comment" D.string
120 <*> D.field "unions" (dictDecoder union)
124 <*> D.field "unions" (dictDecoder union)
121 <*> D.field "aliases" (dictDecoder alias)
125 <*> D.field "aliases" (dictDecoder alias)
122 <*> D.field "values" (dictDecoder value)
126 <*> D.field "values" (dictDecoder value)
@@ -131,13 +135,18 @@ dictDecoder entryDecoder =
131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
132named entryDecoder =
136named entryDecoder =
133 (,)
137 (,)
134− <$> D.field "name" D.name
138+ <$> D.field "name" nameDecoder
135 <*> entryDecoder
139 <*> entryDecoder
136
140
137
141
138−nameDecoder :: D.Decoder Error Name.Name
142+nameDecoder :: D.Decoder e Name.Name
139nameDecoder =
143nameDecoder =
144+ fmap Coerce.coerce D.string
145+
146+
147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148+moduleNameDecoder =
140− D.mapError (const BadName) ModuleName.decoder
149+ D.mapError (const BadModuleName) ModuleName.decoder
141
150
142
151
143typeDecoder :: D.Decoder Error Type.Type
152typeDecoder :: D.Decoder Error Type.Type
@@ -153,7 +162,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
153encodeUnion (name, Union comment args cases) =
162encodeUnion (name, Union comment args cases) =
154 E.object
163 E.object
155 [ "name" ==> E.name name
164 [ "name" ==> E.name name
156− , "comment" ==> E.text comment
165+ , "comment" ==> E.string comment
157 , "args" ==> E.list E.name args
166 , "args" ==> E.list E.name args
158 , "cases" ==> E.list encodeCase cases
167 , "cases" ==> E.list encodeCase cases
159 ]
168 ]
@@ -162,8 +171,8 @@ encodeUnion (name, Union comment args cases) =
162union :: D.Decoder Error Union
171union :: D.Decoder Error Union
163union =
172union =
164 Union
173 Union
165− <$> D.field "comment" D.text
174+ <$> D.field "comment" D.string
166− <*> D.field "args" (D.list D.name)
175+ <*> D.field "args" (D.list nameDecoder)
167 <*> D.field "cases" (D.list caseDecoder)
176 <*> D.field "cases" (D.list caseDecoder)
168
177
169
178
@@ -174,7 +183,7 @@ encodeCase ( tag, args ) =
174
183
175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
176caseDecoder =
185caseDecoder =
177− D.pair D.name (D.list typeDecoder)
186+ D.pair nameDecoder (D.list typeDecoder)
178
187
179
188
180
189
@@ -185,7 +194,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
185encodeAlias ( name, Alias comment args tipe) =
194encodeAlias ( name, Alias comment args tipe) =
186 E.object
195 E.object
187 [ "name" ==> E.name name
196 [ "name" ==> E.name name
188− , "comment" ==> E.text comment
197+ , "comment" ==> E.string comment
189 , "args" ==> E.list E.name args
198 , "args" ==> E.list E.name args
190 , "type" ==> Type.encode tipe
199 , "type" ==> Type.encode tipe
191 ]
200 ]
@@ -194,8 +203,8 @@ encodeAlias ( name, Alias comment args tipe) =
194alias :: D.Decoder Error Alias
203alias :: D.Decoder Error Alias
195alias =
204alias =
196 Alias
205 Alias
197− <$> D.field "comment" D.text
206+ <$> D.field "comment" D.string
198− <*> D.field "args" (D.list D.name)
207+ <*> D.field "args" (D.list nameDecoder)
199 <*> D.field "type" typeDecoder
208 <*> D.field "type" typeDecoder
200
209
201
210
@@ -207,7 +216,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
207encodeValue (name, Value comment tipe) =
216encodeValue (name, Value comment tipe) =
208 E.object
217 E.object
209 [ "name" ==> E.name name
218 [ "name" ==> E.name name
210− , "comment" ==> E.text comment
219+ , "comment" ==> E.string comment
211 , "type" ==> Type.encode tipe
220 , "type" ==> Type.encode tipe
212 ]
221 ]
213
222
@@ -215,7 +224,7 @@ encodeValue (name, Value comment tipe) =
215value :: D.Decoder Error Value
224value :: D.Decoder Error Value
216value =
225value =
217 Value
226 Value
218− <$> D.field "comment" D.text
227+ <$> D.field "comment" D.string
219 <*> D.field "type" typeDecoder
228 <*> D.field "type" typeDecoder
220
229
221
230
@@ -227,7 +236,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
227encodeBinop (name, Binop comment tipe assoc prec) =
236encodeBinop (name, Binop comment tipe assoc prec) =
228 E.object
237 E.object
229 [ "name" ==> E.name name
238 [ "name" ==> E.name name
230− , "comment" ==> E.text comment
239+ , "comment" ==> E.string comment
231 , "type" ==> Type.encode tipe
240 , "type" ==> Type.encode tipe
232 , "associativity" ==> encodeAssoc assoc
241 , "associativity" ==> encodeAssoc assoc
233 , "precedence" ==> encodePrec prec
242 , "precedence" ==> encodePrec prec
@@ -237,7 +246,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
237binop :: D.Decoder Error Binop
246binop :: D.Decoder Error Binop
238binop =
247binop =
239 Binop
248 Binop
240− <$> D.field "comment" D.text
249+ <$> D.field "comment" D.string
241 <*> D.field "type" typeDecoder
250 <*> D.field "type" typeDecoder
242 <*> D.field "associativity" assocDecoder
251 <*> D.field "associativity" assocDecoder
243 <*> D.field "precedence" precDecoder
252 <*> D.field "precedence" precDecoder
@@ -250,19 +259,23 @@ binop =
250encodeAssoc :: Binop.Associativity -> E.Value
259encodeAssoc :: Binop.Associativity -> E.Value
251encodeAssoc assoc =
260encodeAssoc assoc =
252 case assoc of
261 case assoc of
253− Binop.Left -> E.text "left"
262+ Binop.Left -> E.chars "left"
254− Binop.Non -> E.text "non"
263+ Binop.Non -> E.chars "non"
255− Binop.Right -> E.text "right"
264+ Binop.Right -> E.chars "right"
256
265
257
266
258assocDecoder :: D.Decoder Error Binop.Associativity
267assocDecoder :: D.Decoder Error Binop.Associativity
259assocDecoder =
268assocDecoder =
260− do txt <- D.text
269+ let
261− case txt of
270+ left = Json.fromChars "left"
271+ non = Json.fromChars "non"
272+ right = Json.fromChars "right"
273+ in
274+ do str <- D.string
262− "left" -> D.succeed Binop.Left
275+ if | str == left -> return Binop.Left
263− "non" -> D.succeed Binop.Non
276+ | str == non -> return Binop.Non
264− "right" -> D.succeed Binop.Right
277+ | str == right -> return Binop.Right
265− _ -> D.fail (BadAssociativity txt)
278+ | otherwise -> D.failure BadAssociativity
266
279
267
280
268
281
@@ -283,142 +296,190 @@ precDecoder =
283-- FROM MODULE
296-- FROM MODULE
284
297
285
298
286−fromModule :: Can.Module -> Result.Result i w Error.Error Module
299+fromModule :: Can.Module -> Either E.Error Module
287−fromModule (Can.Module name docs exports decls unions aliases binops effects) =
300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
288 case exports of
301 case exports of
289 Can.ExportEverything region ->
302 Can.ExportEverything region ->
290− Result.throw $ Error.Docs $ E.ImplicitExposing region
303+ Left (E.ImplicitExposing region)
291
304
292 Can.Export exportDict ->
305 Can.Export exportDict ->
293 case docs of
306 case docs of
294− Can.NoDocs region ->
307+ Src.NoDocs region ->
295− Result.throw $ Error.Docs $ E.NoDocs region
308+ Left (E.NoDocs region)
296
309
297− Can.YesDocs region overview comments ->
310+ Src.YesDocs overview comments ->
298− do names <- parseOverview region overview
311+ do names <- parseOverview overview
299− Result.mapError Error.Docs $
300− do checkNames exportDict names
312+ checkNames exportDict names
301− let types = gatherTypes decls Map.empty
313+ checkDefs exportDict overview (Map.fromList comments) modul
302− let info = Info comments types unions aliases binops effects
303− inserters <- Map.traverseWithKey (checkExport info) exportDict
304− return $ foldr ($) (emptyModule name overview) inserters
305−
306−
307−emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
308−emptyModule (ModuleName.Canonical _ name) overview =
309− Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
310
314
311
315
312
316
313-- PARSE OVERVIEW
317-- PARSE OVERVIEW
314
318
315
319
316−parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
320+parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
317−parseOverview (R.Region (R.Position row col) _) overview =
321+parseOverview (Src.Comment snippet) =
318− case P.runAt row (col + 3) (chompOverview []) overview of
322+ case P.fromSnippet (chompOverview []) E.BadEnd snippet of
319 Left err ->
323 Left err ->
320− Result.throw (Error.Syntax err)
324+ Left (E.SyntaxProblem err)
321
325
322 Right names ->
326 Right names ->
323− Result.ok names
327+ Right names
328+
329+
330+type Parser a =
331+ P.Parser E.SyntaxProblem a
324
332
325
333
326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
327chompOverview names =
335chompOverview names =
328− do isDocs <- W.chompUntilDocs
336+ do isDocs <- chompUntilDocs
329 if isDocs
337 if isDocs
330− then chompOverviewHelp names
338+ then
331− else return names
339+ do Space.chomp E.Space
332−
333−
334−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335−chompOverviewHelp names =
336− do pos <- P.getPosition
337− (W.SPos spos) <- W.whitespace
338− if pos == spos
339− then chompOverview names
340− else chompOverview =<< chompDocs names
340+ chompOverview =<< chompDocs names
341+ else
342+ return names
341
343
342
344
343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
344chompDocs names =
346chompDocs names =
345− do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
347+ do name <-
346− spos <- W.whitespace
348+ P.addLocation $
347− P.oneOf
349+ P.oneOf E.Name
348− [ do P.checkSpace spos
350+ [ Var.lower E.Name
349− Symbol.comma
351+ , Var.upper E.Name
350− P.spaces
352+ , chompOperator
353+ ]
354+
355+ Space.chomp E.Space
356+
357+ P.oneOfWithFallback
358+ [ do pos <- P.getPosition
359+ Space.checkIndent pos E.Comma
360+ word1 0x2C {-,-} E.Comma
361+ Space.chomp E.Space
351 chompDocs (name:names)
362 chompDocs (name:names)
352− , return (name:names)
353 ]
363 ]
354−
364+ (name:names)
355−
365+
366+
356−chompBinop :: Parser Name.Name
367+chompOperator :: Parser Name.Name
357−chompBinop =
368+chompOperator =
358− do Symbol.leftParen
369+ do word1 0x28 {-(-} E.Op
359− name <- Symbol.binop
370+ op <- Symbol.operator E.Op E.OpBad
360− Symbol.rightParen
371+ word1 0x29 {-)-} E.Op
361− return name
372+ return op
373+
374+
375+-- TODO add rule that @docs must be after newline in 0.20
376+--
377+chompUntilDocs :: Parser Bool
378+chompUntilDocs =
379+ P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
380+ let
381+ (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col
382+ !newState = P.State src newPos end indent newRow newCol
383+ in
384+ cok isDocs newState
385+
386+
387+untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)
388+untilDocs pos end row col =
389+ if pos >= end then
390+ (# False, pos, row, col #)
391+ else
392+ let !word = P.unsafeIndex pos in
393+ if word == 0x0A {-\n-} then
394+ untilDocs (plusPtr pos 1) end (row + 1) 1
395+ else
396+ let !pos5 = plusPtr pos 5 in
397+ if pos5 <= end
398+ && P.unsafeIndex ( pos ) == 0x40 {-@-}
399+ && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}
400+ && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}
401+ && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}
402+ && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}
403+ && Var.getInnerWidth pos5 end == 0
404+ then
405+ (# True, pos5, row, col + 5 #)
406+ else
407+ let !newPos = plusPtr pos (P.getCharWidth word) in
408+ untilDocs newPos end row (col + 1)
362
409
363
410
364
411
365-- CHECK NAMES
412-- CHECK NAMES
366
413
367
414
368−type Result i w a =
415+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
369− Result.Result i w E.Error a
416+checkNames exports names =
370−
417+ let
371−
418+ docs = List.foldl' addName Map.empty names
372−type Dups =
419+ loneDoc = Map.traverseMissing onlyInDocs
373− Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
420+ loneExport = Map.traverseMissing onlyInExports
421+ checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)
422+ in
423+ case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of
424+ (_, Right _) -> Right ()
425+ (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))
374
426
375
427
376−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
428+type DocNameRegions =
377−checkNames exports names =
429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
378− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
379− let overlap = Map.size (Map.intersection docs exports)
380− if Map.size exports == overlap && overlap == Map.size docs
381− then Result.ok ()
382− else
383− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
385− Result.ok ()
386
430
387
431
388−addName :: Dups -> A.Located Name.Name -> Dups
432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
389addName dict (A.At region name) =
433addName dict (A.At region name) =
390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
391
435
392
436
393−isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
437+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
394isUnique name regions =
438isUnique name regions =
395 case regions of
439 case regions of
396 OneOrMore.One region ->
440 OneOrMore.One region ->
397 Result.ok region
441 Result.ok region
398
442
399− OneOrMore.More _ _ ->
443+ OneOrMore.More left right ->
400− let (r1:r2:_) = OneOrMore.toList regions in
444+ let (r1, r2) = OneOrMore.getFirstTwo left right in
401− Result.throw (E.Duplicate name r1 r2)
445+ Result.throw (E.NameDuplicate name r1 r2)
402
446
403
447
404−onlyInDocs :: Name.Name -> R.Region -> Result i w a
448+onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
405−onlyInDocs name region =
449+onlyInDocs name regions =
450+ do region <- isUnique name regions
406− Result.throw $ E.OnlyInDocs name region
451+ Result.throw $ E.NameOnlyInDocs name region
407
452
408
453
409−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
454+onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
410onlyInExports name (A.At region _) =
455onlyInExports name (A.At region _) =
411− Result.throw $ E.OnlyInExports name region
456+ Result.throw $ E.NameOnlyInExports name region
457+
458+
459+
460+-- CHECK DEFS
461+
412
462
463+checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module
464+checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =
465+ let
466+ types = gatherTypes decls Map.empty
467+ info = Info comments types unions aliases infixes effects
468+ in
469+ case Result.run (Map.traverseWithKey (checkExport info) exportDict) of
470+ (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)
471+ (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters
413
472
414
473
415−-- CHECK EXPORTS
474+emptyModule :: ModuleName.Canonical -> Src.Comment -> Module
475+emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =
476+ Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty
416
477
417
478
418data Info =
479data Info =
419 Info
480 Info
420− { _iComments :: Map.Map Name.Name Comment
481+ { _iComments :: Map.Map Name.Name Src.Comment
421− , _iValues :: Types
482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
422 , _iUnions :: Map.Map Name.Name Can.Union
483 , _iUnions :: Map.Map Name.Name Can.Union
423 , _iAliases :: Map.Map Name.Name Can.Alias
484 , _iAliases :: Map.Map Name.Name Can.Alias
424 , _iBinops :: Map.Map Name.Name Can.Binop
485 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -426,7 +487,7 @@ data Info =
426 }
487 }
427
488
428
489
429−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
490+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
430checkExport info name (A.At region export) =
491checkExport info name (A.At region export) =
431 case export of
492 case export of
432 Can.ExportValue ->
493 Can.ExportValue ->
@@ -467,23 +528,23 @@ checkExport info name (A.At region export) =
467 m { _values = Map.insert name (Value comment tipe) (_values m) }
528 m { _values = Map.insert name (Value comment tipe) (_values m) }
468
529
469
530
470−getComment :: R.Region -> Name.Name -> Info -> Result i w Comment
531+getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
471getComment region name info =
532getComment region name info =
472 case Map.lookup name (_iComments info) of
533 case Map.lookup name (_iComments info) of
473 Nothing ->
534 Nothing ->
474 Result.throw (E.NoComment name region)
535 Result.throw (E.NoComment name region)
475
536
476− Just comment ->
537+ Just (Src.Comment snippet) ->
477− Result.ok comment
538+ Result.ok (Json.fromComment snippet)
478
539
479
540
480−getType :: Name.Name -> Info -> Result i w Type.Type
541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
481getType name info =
542getType name info =
482 case _iValues info ! name of
543 case _iValues info ! name of
483− A.At defRegion Nothing ->
544+ Left region ->
484− Result.throw (E.NoAnnotation name defRegion)
545+ Result.throw (E.NoAnnotation name region)
485
546
486− A.At _ (Just tipe) ->
547+ Right tipe ->
487 Result.ok (Extract.fromType tipe)
548 Result.ok (Extract.fromType tipe)
488
549
489
550
@@ -497,7 +558,7 @@ dector (Can.Ctor name _ _ args) =
497
558
498
559
499type Types =
560type Types =
500− Map.Map Name.Name (A.Located (Maybe Can.Type))
561+ Map.Map Name.Name (Either A.Region Can.Type)
501
562
502
563
503gatherTypes :: Can.Decls -> Types -> Types
564gatherTypes :: Can.Decls -> Types -> Types
@@ -506,8 +567,8 @@ gatherTypes decls types =
506 Can.Declare def subDecls ->
567 Can.Declare def subDecls ->
507 gatherTypes subDecls (addDef types def)
568 gatherTypes subDecls (addDef types def)
508
569
509− Can.DeclareRec defs subDecls ->
570+ Can.DeclareRec def defs subDecls ->
510− gatherTypes subDecls (List.foldl' addDef types defs)
571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
511
572
512 Can.SaveTheEnvironment ->
573 Can.SaveTheEnvironment ->
513 types
574 types
@@ -517,11 +578,10 @@ addDef :: Types -> Can.Def -> Types
517addDef types def =
578addDef types def =
518 case def of
579 case def of
519 Can.Def (A.At region name) _ _ ->
580 Can.Def (A.At region name) _ _ ->
520− Map.insert name (A.At region Nothing) types
581+ Map.insert name (Left region) types
521
582
522− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
523 let
584 let
524− tipe =
525− foldr Can.TLambda resultType (map snd typedArgs)
585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)
526 in
586 in
527− Map.insert name (A.At region (Just tipe)) types
587+ Map.insert name (Right tipe) types
compiler/src/Elm/Float.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}
3+module Elm.Float
4+ ( Float
5+ , fromPtr
6+ , toBuilder
7+ )
8+ where
9+
10+
11+import Prelude hiding (Float)
12+import Data.Binary (Binary, get, put)
13+import qualified Data.ByteString.Builder as B
14+import qualified Data.Utf8 as Utf8
15+import Data.Word (Word8)
16+import Foreign.Ptr (Ptr)
17+
18+
19+
20+-- FLOATS
21+
22+
23+type Float =
24+ Utf8.Utf8 ELM_FLOAT
25+
26+
27+data ELM_FLOAT
28+
29+
30+
31+-- HELPERS
32+
33+
34+fromPtr :: Ptr Word8 -> Ptr Word8 -> Float
35+fromPtr =
36+ Utf8.fromPtr
37+
38+
39+{-# INLINE toBuilder #-}
40+toBuilder :: Float -> B.Builder
41+toBuilder =
42+ Utf8.toBuilder
43+
44+
45+
46+-- BINARY
47+
48+
49+instance Binary (Utf8.Utf8 ELM_FLOAT) where
50+ get = Utf8.getUnder256
51+ put = Utf8.putUnder256
compiler/src/Elm/Interface.hs+4−4
@@ -73,7 +73,7 @@ data Binop =
73
73
74
74
75fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
75fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
76−fromModule home (Can.Module _ exports _ unions aliases binops _) annotations =
76+fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =
77 Interface
77 Interface
78 { _home = home
78 { _home = home
79 , _values = restrict exports annotations
79 , _values = restrict exports annotations
@@ -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+48−46
@@ -11,14 +11,14 @@ module Elm.Kernel
11
11
12import Control.Monad (liftM, liftM2)
12import Control.Monad (liftM, liftM2)
13import Data.Binary (Binary, get, put, getWord8, putWord8)
13import Data.Binary (Binary, get, put, getWord8, putWord8)
14−import qualified Data.ByteString as BS
14+import qualified Data.ByteString.Internal as B
15−import Data.Coerce (coerce)
16import qualified Data.List as List
15import qualified Data.List as List
17import qualified Data.Map as Map
16import qualified Data.Map as Map
18import qualified Data.Name as Name
17import qualified Data.Name as Name
19−import qualified Data.Utf8 as Utf8
20−import Data.Word (Word8, Word16)
18+import Data.Word (Word8)
21−import Foreign.Ptr (Ptr, plusPtr)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20+import Foreign.ForeignPtr (ForeignPtr)
21+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
22
22
23import qualified AST.Source as Src
23import qualified AST.Source as Src
24import qualified Elm.ModuleName as ModuleName
24import qualified Elm.ModuleName as ModuleName
@@ -36,7 +36,7 @@ import qualified Reporting.Annotation as A
36
36
37
37
38data Chunk
38data Chunk
39− = JS (Utf8.VeryLong UNCHECKED)
39+ = JS B.ByteString
40 | ElmVar ModuleName.Canonical Name.Name
40 | ElmVar ModuleName.Canonical Name.Name
41 | JsVar Name.Name Name.Name
41 | JsVar Name.Name Name.Name
42 | ElmField Name.Name
42 | ElmField Name.Name
@@ -46,9 +46,6 @@ data Chunk
46 | Prod
46 | Prod
47
47
48
48
49−data UNCHECKED
50−
51−
52
49
53-- COUNT FIELDS
50-- COUNT FIELDS
54
51
@@ -83,13 +80,13 @@ type Foreigns =
83 Map.Map ModuleName.Raw Pkg.Name
80 Map.Map ModuleName.Raw Pkg.Name
84
81
85
82
86−fromByteString :: Pkg.Name -> Foreigns -> BS.ByteString -> Maybe Content
83+fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content
87fromByteString pkg foreigns bytes =
84fromByteString pkg foreigns bytes =
88− case P.fromByteString (parser pkg foreigns) bytes of
85+ case P.fromByteString (parser pkg foreigns) toError bytes of
89− P.Ok content _ ->
86+ Right content ->
90 Just content
87 Just content
91
88
92− P.Err () ->
89+ Left () ->
93 Nothing
90 Nothing
94
91
95
92
@@ -120,21 +117,21 @@ ignoreError _ _ _ =
120
117
121parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
118parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
122parseChunks vtable enums fields =
119parseChunks vtable enums fields =
123− P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
120+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
124 let
121 let
125 (# chunks, newPos, newRow, newCol #) =
122 (# chunks, newPos, newRow, newCol #) =
126− chompChunks vtable enums fields pos end row col pos []
123+ chompChunks vtable enums fields src pos end row col pos []
127 in
124 in
128 if newPos == end then
125 if newPos == end then
129− cok chunks (P.State newPos end indent newRow newCol)
126+ cok chunks (P.State src newPos end indent newRow newCol)
130 else
127 else
131 cerr row col toError
128 cerr row col toError
132
129
133
130
134−chompChunks :: VarTable -> Enums -> Fields -> 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 #)
135−chompChunks vs es fs pos end row col lastPos revChunks =
132+chompChunks vs es fs src pos end row col lastPos revChunks =
136 if pos >= end then
133 if pos >= end then
137− let !js = Utf8.fromPtr lastPos end in
134+ let !js = toByteString src lastPos end in
138 (# reverse (JS js : revChunks), pos, row, col #)
135 (# reverse (JS js : revChunks), pos, row, col #)
139
136
140 else
137 else
@@ -145,24 +142,34 @@ chompChunks vs es fs pos end row col lastPos revChunks =
145 !pos3 = plusPtr pos 3
142 !pos3 = plusPtr pos 3
146 in
143 in
147 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
148− let !js = Utf8.fromPtr lastPos pos in
145+ let !js = toByteString src lastPos pos in
149− chompTag vs es fs pos3 end row (col + 3) (JS js : revChunks)
146+ chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)
150 else
147 else
151− chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks
148+ chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks
152
149
153 else if word == 0x0A {-\n-} then
150 else if word == 0x0A {-\n-} then
154− chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
151+ chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
155
152
156 else
153 else
157 let
154 let
158− !newPos = plusPtr pos (getCharWidth pos end word)
155+ !newPos = plusPtr pos (getCharWidth word)
159 in
156 in
160− chompChunks vs es fs newPos end row (col + 1) lastPos revChunks
157+ chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
158+
159+
160+toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString
161+toByteString src pos end =
162+ let
163+ !off = minusPtr pos (unsafeForeignPtrToPtr src)
164+ !len = minusPtr end pos
165+ in
166+ B.PS src off len
167+
161
168
162
169
163-- relies on external checks in chompChunks
170-- relies on external checks in chompChunks
164−chompTag :: VarTable -> Enums -> Fields -> 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 #)
165−chompTag vs es fs pos end row col revChunks =
172+chompTag vs es fs src pos end row col revChunks =
166 let
173 let
167 (# newPos, newCol #) = Var.chompInnerChars pos end col
174 (# newPos, newCol #) = Var.chompInnerChars pos end col
168 !tagPos = plusPtr pos (-1)
175 !tagPos = plusPtr pos (-1)
@@ -172,7 +179,7 @@ chompTag vs es fs pos end row col revChunks =
172 let
179 let
173 !name = Name.fromPtr pos newPos
180 !name = Name.fromPtr pos newPos
174 in
181 in
175− chompChunks vs es fs newPos end row newCol newPos $
182+ chompChunks vs es fs src newPos end row newCol newPos $
176 ElmField name : revChunks
183 ElmField name : revChunks
177 else
184 else
178 let
185 let
@@ -183,7 +190,7 @@ chompTag vs es fs pos end row col revChunks =
183 (enum, newEnums) =
190 (enum, newEnums) =
184 lookupEnum (word - 0x30) name es
191 lookupEnum (word - 0x30) name es
185 in
192 in
186− chompChunks vs newEnums fs newPos end row newCol newPos $
193+ chompChunks vs newEnums fs src newPos end row newCol newPos $
187 JsEnum enum : revChunks
194 JsEnum enum : revChunks
188
195
189 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
@@ -191,19 +198,19 @@ chompTag vs es fs pos end row col revChunks =
191 (field, newFields) =
198 (field, newFields) =
192 lookupField name fs
199 lookupField name fs
193 in
200 in
194− chompChunks vs es newFields newPos end row newCol newPos $
201+ chompChunks vs es newFields src newPos end row newCol newPos $
195 JsField field : revChunks
202 JsField field : revChunks
196
203
197 else if name == "DEBUG" then
204 else if name == "DEBUG" then
198− chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)
205+ chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)
199
206
200 else if name == "PROD" then
207 else if name == "PROD" then
201− chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)
208+ chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)
202
209
203 else
210 else
204 case Map.lookup name vs of
211 case Map.lookup name vs of
205 Just chunk ->
212 Just chunk ->
206− chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)
213+ chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)
207
214
208 Nothing ->
215 Nothing ->
209 (# revChunks, pos, row, col #)
216 (# revChunks, pos, row, col #)
@@ -312,19 +319,19 @@ toNames exposing =
312 map toName exposedList
319 map toName exposedList
313
320
314
321
315−toName :: A.Located Src.Exposed -> Name.Name
322+toName :: Src.Exposed -> Name.Name
316−toName (A.At _ exposed) =
323+toName exposed =
317 case exposed of
324 case exposed of
318− Src.Lower name ->
325+ Src.Lower (A.At _ name) ->
319 name
326 name
320
327
321− Src.Upper name Src.Private ->
328+ Src.Upper (A.At _ name) Src.Private ->
322 name
329 name
323
330
324− Src.Upper _ Src.Public ->
331+ Src.Upper _ (Src.Public _) ->
325 error "cannot have Maybe(..) syntax in kernel code header"
332 error "cannot have Maybe(..) syntax in kernel code header"
326
333
327− Src.Operator _ ->
334+ Src.Operator _ _ ->
328 error "cannot use binops in kernel code"
335 error "cannot use binops in kernel code"
329
336
330
337
@@ -335,7 +342,7 @@ toName (A.At _ exposed) =
335instance Binary Chunk where
342instance Binary Chunk where
336 put chunk =
343 put chunk =
337 case chunk of
344 case chunk of
338− JS a -> putWord8 0 >> put (coerce a :: Utf8.String)
345+ JS a -> putWord8 0 >> put a
339 ElmVar a b -> putWord8 1 >> put a >> put b
346 ElmVar a b -> putWord8 1 >> put a >> put b
340 JsVar a b -> putWord8 2 >> put a >> put b
347 JsVar a b -> putWord8 2 >> put a >> put b
341 ElmField a -> putWord8 3 >> put a
348 ElmField a -> putWord8 3 >> put a
@@ -347,7 +354,7 @@ instance Binary Chunk where
347 get =
354 get =
348 do word <- getWord8
355 do word <- getWord8
349 case word of
356 case word of
350− 0 -> liftM toJS get
357+ 0 -> liftM JS get
351 1 -> liftM2 ElmVar get get
358 1 -> liftM2 ElmVar get get
352 2 -> liftM2 JsVar get get
359 2 -> liftM2 JsVar get get
353 3 -> liftM ElmField get
360 3 -> liftM ElmField get
@@ -356,8 +363,3 @@ instance Binary Chunk where
356 6 -> return Debug
363 6 -> return Debug
357 7 -> return Prod
364 7 -> return Prod
358 _ -> error "problem deserializing Elm.Kernel.Chunk"
365 _ -> error "problem deserializing Elm.Kernel.Chunk"
359−
360−
361−toJS :: Utf8.String -> Chunk
362−toJS str =
363− JS (coerce str)
compiler/src/Elm/Licenses.hs+48−65
@@ -9,14 +9,12 @@ module Elm.Licenses
9 where
9 where
10
10
11
11
12−import Control.Monad (liftM2)
13−import Data.Binary (Binary, get, put)
14−import Data.Map ((!))
15import qualified Data.Map as Map
12import qualified Data.Map as Map
16import qualified Data.Utf8 as Utf8
13import qualified Data.Utf8 as Utf8
17
14
18import qualified Json.Decode as D
15import qualified Json.Decode as D
19import qualified Json.Encode as E
16import qualified Json.Encode as E
17+import qualified Json.String as Json
20import qualified Reporting.Suggest as Suggest
18import qualified Reporting.Suggest as Suggest
21
19
22
20
@@ -24,25 +22,21 @@ import qualified Reporting.Suggest as Suggest
24-- LICENCES
22-- LICENCES
25
23
26
24
27−data License =
25+newtype License =
28− License
26+ License Json.String
29− { _name :: Utf8.String
30− , _code :: Utf8.String
31− }
32− deriving (Eq, Ord)
33
27
34
28
35bsd3 :: License
29bsd3 :: License
36bsd3 =
30bsd3 =
37− osiApprovedSpdxLicenses ! "BSD-3-Clause"
31+ License (Json.fromChars "BSD-3-Clause")
38
32
39
33
40encode :: License -> E.Value
34encode :: License -> E.Value
41−encode (License _ code) =
35+encode (License code) =
42 E.string code
36 E.string code
43
37
44
38
45−decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License
39+decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License
46decoder toError =
40decoder toError =
47 do str <- D.string
41 do str <- D.string
48 case check str of
42 case check str of
@@ -57,97 +51,93 @@ decoder toError =
57-- CHECK
51-- CHECK
58
52
59
53
60−check :: Utf8.String -> Either [Utf8.String] License
54+check :: Json.String -> Either [Json.String] License
61−check rawName =
55+check givenCode =
62− case Map.lookup rawName osiApprovedSpdxLicenses of
56+ if Map.member givenCode osiApprovedSpdxLicenses then
63− Just license ->
57+ Right (License givenCode)
64− Right license
65
58
66− Nothing ->
59+ else
67− let
60+ let
68− toPairs (License name code) =
61+ pairs =
69− [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]
62+ map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)
70−
63+ ++
71− pairs =
72− concatMap toPairs (Map.elems osiApprovedSpdxLicenses)
64+ Map.toList osiApprovedSpdxLicenses
73− in
65+ in
74− Left $ map snd $
66+ Left $ map fst $ take 4 $
75− Suggest.sort (Utf8.toChars rawName) fst pairs
67+ Suggest.sort (Utf8.toChars givenCode) snd pairs
76
68
77
69
78
70
79-- LIST OF LICENCES
71-- LIST OF LICENCES
80
72
81
73
82−(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)
74+(==>) :: [Char] -> [Char] -> (Json.String, [Char])
83−(==>) code name =
75+(==>) code fullName =
84− ( code, License name code )
76+ ( Json.fromChars code, fullName )
85
77
86
78
87--
79--
88-- OSI approved licenses in SPDX format.
80-- OSI approved licenses in SPDX format.
89-- <https://spdx.org/licenses/>
81-- <https://spdx.org/licenses/>
90--
82--
91−osiApprovedSpdxLicenses :: Map.Map Utf8.String License
83+osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
92osiApprovedSpdxLicenses =
84osiApprovedSpdxLicenses =
93 Map.fromList
85 Map.fromList
86+ [ "0BSD" ==> "BSD Zero Clause License"
87+ , "AAL" ==> "Attribution Assurance License"
94− [ "AFL-1.1" ==> "Academic Free License v1.1"
88+ , "AFL-1.1" ==> "Academic Free License v1.1"
95 , "AFL-1.2" ==> "Academic Free License v1.2"
89 , "AFL-1.2" ==> "Academic Free License v1.2"
96 , "AFL-2.0" ==> "Academic Free License v2.0"
90 , "AFL-2.0" ==> "Academic Free License v2.0"
97 , "AFL-2.1" ==> "Academic Free License v2.1"
91 , "AFL-2.1" ==> "Academic Free License v2.1"
98 , "AFL-3.0" ==> "Academic Free License v3.0"
92 , "AFL-3.0" ==> "Academic Free License v3.0"
99− , "APL-1.0" ==> "Adaptive Public License 1.0"
93+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
100 , "Apache-1.1" ==> "Apache License 1.1"
94 , "Apache-1.1" ==> "Apache License 1.1"
101 , "Apache-2.0" ==> "Apache License 2.0"
95 , "Apache-2.0" ==> "Apache License 2.0"
96+ , "APL-1.0" ==> "Adaptive Public License 1.0"
102 , "APSL-1.0" ==> "Apple Public Source License 1.0"
97 , "APSL-1.0" ==> "Apple Public Source License 1.0"
103 , "APSL-1.1" ==> "Apple Public Source License 1.1"
98 , "APSL-1.1" ==> "Apple Public Source License 1.1"
104 , "APSL-1.2" ==> "Apple Public Source License 1.2"
99 , "APSL-1.2" ==> "Apple Public Source License 1.2"
105 , "APSL-2.0" ==> "Apple Public Source License 2.0"
100 , "APSL-2.0" ==> "Apple Public Source License 2.0"
106 , "Artistic-1.0" ==> "Artistic License 1.0"
101 , "Artistic-1.0" ==> "Artistic License 1.0"
107− , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
108 , "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)"
109 , "Artistic-2.0" ==> "Artistic License 2.0"
104 , "Artistic-2.0" ==> "Artistic License 2.0"
110− , "AAL" ==> "Attribution Assurance License"
111− , "BSL-1.0" ==> "Boost Software License 1.0"
112 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
113 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
114− , "0BSD" ==> "BSD Zero Clause License"
107+ , "BSL-1.0" ==> "Boost Software License 1.0"
108+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
115 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
116 , "CNRI-Python" ==> "CNRI Python License"
111 , "CNRI-Python" ==> "CNRI Python License"
117− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
118 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
119 , "CPL-1.0" ==> "Common Public License 1.0"
113 , "CPL-1.0" ==> "Common Public License 1.0"
120− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
121 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
122− , "EPL-1.0" ==> "Eclipse Public License 1.0"
123 , "ECL-1.0" ==> "Educational Community License v1.0"
115 , "ECL-1.0" ==> "Educational Community License v1.0"
124 , "ECL-2.0" ==> "Educational Community License v2.0"
116 , "ECL-2.0" ==> "Educational Community License v2.0"
125 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
126 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
127 , "Entessa" ==> "Entessa Public License v1.0"
119 , "Entessa" ==> "Entessa Public License v1.0"
120+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
128 , "EUDatagrid" ==> "EU DataGrid Software License"
121 , "EUDatagrid" ==> "EU DataGrid Software License"
129 , "EUPL-1.1" ==> "European Union Public License 1.1"
122 , "EUPL-1.1" ==> "European Union Public License 1.1"
130 , "Fair" ==> "Fair License"
123 , "Fair" ==> "Fair License"
131 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
132− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
133 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
134 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
135− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
136− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
137− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
138 , "HPND" ==> "Historic Permission Notice and Disclaimer"
127 , "HPND" ==> "Historic Permission Notice and Disclaimer"
139− , "IPL-1.0" ==> "IBM Public License v1.0"
140 , "Intel" ==> "Intel Open Source License"
128 , "Intel" ==> "Intel Open Source License"
141 , "IPA" ==> "IPA Font License"
129 , "IPA" ==> "IPA Font License"
130+ , "IPL-1.0" ==> "IBM Public License v1.0"
142 , "ISC" ==> "ISC License"
131 , "ISC" ==> "ISC License"
143− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
132+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
133+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
144 , "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"
145− , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
146 , "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"
147− , "LPL-1.02" ==> "Lucent Public License v1.02"
137+ , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
148 , "LPL-1.0" ==> "Lucent Public License Version 1.0"
138 , "LPL-1.0" ==> "Lucent Public License Version 1.0"
149− , "MS-PL" ==> "Microsoft Public License"
139+ , "LPL-1.02" ==> "Lucent Public License v1.02"
150− , "MS-RL" ==> "Microsoft Reciprocal License"
140+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
151 , "MirOS" ==> "MirOS Licence"
141 , "MirOS" ==> "MirOS Licence"
152 , "MIT" ==> "MIT License"
142 , "MIT" ==> "MIT License"
153 , "Motosoto" ==> "Motosoto License"
143 , "Motosoto" ==> "Motosoto License"
@@ -155,48 +145,41 @@ osiApprovedSpdxLicenses =
155 , "MPL-1.1" ==> "Mozilla Public License 1.1"
145 , "MPL-1.1" ==> "Mozilla Public License 1.1"
156 , "MPL-2.0" ==> "Mozilla Public License 2.0"
146 , "MPL-2.0" ==> "Mozilla Public License 2.0"
157 , "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"
158 , "Multics" ==> "Multics License"
150 , "Multics" ==> "Multics License"
159 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
160 , "Naumen" ==> "Naumen Public License"
152 , "Naumen" ==> "Naumen Public License"
153+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
161 , "NGPL" ==> "Nethack General Public License"
154 , "NGPL" ==> "Nethack General Public License"
162 , "Nokia" ==> "Nokia Open Source License"
155 , "Nokia" ==> "Nokia Open Source License"
163 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
164 , "NTP" ==> "NTP License"
157 , "NTP" ==> "NTP License"
165 , "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"
166 , "OGTSL" ==> "Open Group Test Suite License"
160 , "OGTSL" ==> "Open Group Test Suite License"
161+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
167 , "OSL-1.0" ==> "Open Software License 1.0"
162 , "OSL-1.0" ==> "Open Software License 1.0"
168 , "OSL-2.0" ==> "Open Software License 2.0"
163 , "OSL-2.0" ==> "Open Software License 2.0"
169 , "OSL-2.1" ==> "Open Software License 2.1"
164 , "OSL-2.1" ==> "Open Software License 2.1"
170 , "OSL-3.0" ==> "Open Software License 3.0"
165 , "OSL-3.0" ==> "Open Software License 3.0"
171− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
172 , "PHP-3.0" ==> "PHP License v3.0"
166 , "PHP-3.0" ==> "PHP License v3.0"
173 , "PostgreSQL" ==> "PostgreSQL License"
167 , "PostgreSQL" ==> "PostgreSQL License"
174 , "Python-2.0" ==> "Python License 2.0"
168 , "Python-2.0" ==> "Python License 2.0"
175 , "QPL-1.0" ==> "Q Public License 1.0"
169 , "QPL-1.0" ==> "Q Public License 1.0"
176− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
177 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
178 , "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"
179 , "RSCPL" ==> "Ricoh Source Code Public License"
173 , "RSCPL" ==> "Ricoh Source Code Public License"
180− , "OFL-1.1" ==> "SIL Open Font License 1.1"
181 , "SimPL-2.0" ==> "Simple Public License 2.0"
174 , "SimPL-2.0" ==> "Simple Public License 2.0"
182− , "Sleepycat" ==> "Sleepycat License"
183 , "SISSL" ==> "Sun Industry Standards Source License v1.1"
175 , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176+ , "Sleepycat" ==> "Sleepycat License"
184 , "SPL-1.0" ==> "Sun Public License v1.0"
177 , "SPL-1.0" ==> "Sun Public License v1.0"
185− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
186 , "UPL-1.0" ==> "Universal Permissive License v1.0"
178 , "UPL-1.0" ==> "Universal Permissive License v1.0"
187− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
188 , "VSL-1.0" ==> "Vovida Software License v1.0"
179 , "VSL-1.0" ==> "Vovida Software License v1.0"
189 , "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"
190 , "Xnet" ==> "X.Net License"
182 , "Xnet" ==> "X.Net License"
191 , "Zlib" ==> "zlib License"
183 , "Zlib" ==> "zlib License"
192 , "ZPL-2.0" ==> "Zope Public License 2.0"
184 , "ZPL-2.0" ==> "Zope Public License 2.0"
193 ]
185 ]
194−
195−
196−
197−-- BINARY
198−
199−
200−instance Binary License where
201− get = liftM2 License get get
202− put (License a b) = put a >> put b
compiler/src/Elm/ModuleName.hs+65−39
@@ -1,18 +1,19 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}
2module Elm.ModuleName
2module Elm.ModuleName
3 ( Raw
3 ( Raw
4 , toChars
4 , toChars
5− , toString
6 , toFilePath
5 , toFilePath
7 , toHyphenPath
6 , toHyphenPath
8− , fromHyphenPath
7+ --
9 , encode
8 , encode
10 , decoder
9 , decoder
10+ , parser
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,15 +23,19 @@ 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
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
28import Prelude hiding (maybe)
30import Prelude hiding (maybe)
29import qualified System.FilePath as FP
31import qualified System.FilePath as FP
30
32
31import qualified Elm.Package as Pkg
33import qualified Elm.Package as Pkg
32−import qualified Json.Decode as Decode
34+import qualified Json.Decode as D
33−import qualified Json.Encode as Encode
35+import qualified Json.Encode as E
36+import qualified Parse.Variable as Var
37+import qualified Parse.Primitives as P
38+import Parse.Primitives (Row, Col)
34
39
35
40
36
41
@@ -45,11 +50,6 @@ toChars =
45 Name.toChars
50 Name.toChars
46
51
47
52
48−toString :: Raw -> Utf8.String
49−toString =
50− Name.toUtf8
51−
52−
53toFilePath :: Raw -> FilePath
53toFilePath :: Raw -> FilePath
54toFilePath name =
54toFilePath name =
55 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)
55 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)
@@ -60,38 +60,68 @@ toHyphenPath name =
60 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
60 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
61
61
62
62
63−fromHyphenPath :: Utf8.String -> Maybe Raw
64−fromHyphenPath str =
65− let
66− chunks =
67− Utf8.split 0x2D {- - -} str
68− in
69− if all isGoodChunk chunks
70− then Just (Name.fromUtf8 (Utf8.join 0x2E {- . -} chunks))
71− else Nothing
72−
73−
74
63
75-- JSON
64-- JSON
76
65
77
66
78−encode :: Raw -> Encode.Value
67+encode :: Raw -> E.Value
79encode =
68encode =
80− Encode.name
69+ E.name
81
70
82
71
83−decoder :: Decode.Decoder Utf8.String Raw
72+decoder :: D.Decoder (Row, Col) Raw
84decoder =
73decoder =
85− do str <- Decode.string
74+ D.customString parser (,)
86− if all isGoodChunk (Utf8.split 0x2E {- . -} str)
75+
87− then return (Name.fromUtf8 str)
76+
88− else Decode.failure str
77+
78+-- PARSER
89
79
90
80
91−isGoodChunk :: Utf8.String -> Bool
81+parser :: P.Parser (Row, Col) Raw
92−isGoodChunk chunk =
82+parser =
93− Utf8.startsWithChar Char.isUpper chunk
83+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
94− && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk
84+ let
85+ (# isGood, newPos, newCol #) = chompStart pos end col
86+ in
87+ if isGood && minusPtr newPos pos < 256 then
88+ let !newState = P.State src newPos end indent row newCol in
89+ cok (Utf8.fromPtr pos newPos) newState
90+
91+ else if col == newCol then
92+ eerr row newCol (,)
93+
94+ else
95+ cerr row newCol (,)
96+
97+
98+chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
99+chompStart pos end col =
100+ let
101+ !width = Var.getUpperWidth pos end
102+ in
103+ if width == 0 then
104+ (# False, pos, col #)
105+ else
106+ chompInner (plusPtr pos width) end (col + 1)
107+
108+
109+chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
110+chompInner pos end col =
111+ if pos >= end then
112+ (# True, pos, col #)
113+ else
114+ let
115+ !word = P.unsafeIndex pos
116+ !width = Var.getInnerWidthHelp pos end word
117+ in
118+ if width == 0 then
119+ if word == 0x2E {-.-} then
120+ chompStart (plusPtr pos 1) end (col + 1)
121+ else
122+ (# True, pos, col #)
123+ else
124+ chompInner (plusPtr pos width) end (col + 1)
95
125
96
126
97
127
@@ -105,6 +135,7 @@ data Canonical =
105 }
135 }
106
136
107
137
138+
108-- INSTANCES
139-- INSTANCES
109
140
110
141
@@ -195,11 +226,6 @@ debug :: Canonical
195debug = Canonical Pkg.core Name.debug
226debug = Canonical Pkg.core Name.debug
196
227
197
228
198−{-# NOINLINE bitwise #-}
199−bitwise :: Canonical
200−bitwise = Canonical Pkg.core Name.bitwise
201−
202−
203
229
204-- HTML
230-- HTML
205
231
compiler/src/Elm/Package.hs+205−83
@@ -1,38 +1,52 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}
3module Elm.Package
3module Elm.Package
4 ( Name(..)
4 ( Name(..)
5+ , Author
6+ , Project
5 , Canonical(..)
7 , Canonical(..)
6 , isKernel
8 , isKernel
7− , toString
8 , toChars
9 , toChars
9 , toUrl
10 , toUrl
10 , toFilePath
11 , toFilePath
11− , BadName(..)
12+ , toJsonString
12− , fromString
13+ --
13 , dummyName, kernel, core
14 , dummyName, kernel, core
14 , browser, virtualDom, html
15 , browser, virtualDom, html
15 , json, http, url
16 , json, http, url
16 , webgl, linearAlgebra
17 , webgl, linearAlgebra
18+ --
17 , suggestions
19 , suggestions
20+ , nearbyNames
21+ --
18 , decoder
22 , decoder
19 , encode
23 , encode
24+ , keyDecoder
25+ --
26+ , parser
20 )
27 )
21 where
28 where
22
29
23
30
24import Control.Monad (liftM2)
31import Control.Monad (liftM2)
25import Data.Binary (Binary, get, put)
32import Data.Binary (Binary, get, put)
26−import qualified Data.Char as Char
33+import qualified Data.Coerce as Coerce
27−import qualified Data.Name as Name
34+import qualified Data.List as List
28import qualified Data.Map as Map
35import qualified Data.Map as Map
36+import qualified Data.Name as Name
29import Data.Monoid ((<>))
37import Data.Monoid ((<>))
30import qualified Data.Utf8 as Utf8
38import qualified Data.Utf8 as Utf8
39+import Data.Word (Word8)
40+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
31import System.FilePath ((</>))
41import System.FilePath ((</>))
32
42
33import qualified Elm.Version as V
43import qualified Elm.Version as V
34−import qualified Json.Decode as Decode
44+import qualified Json.Decode as D
35−import qualified Json.Encode as Encode
45+import qualified Json.Encode as E
46+import qualified Json.String as Json
47+import qualified Parse.Primitives as P
48+import Parse.Primitives (Row, Col)
49+import qualified Reporting.Suggest as Suggest
36
50
37
51
38
52
@@ -41,9 +55,17 @@ import qualified Json.Encode as Encode
41
55
42data Name =
56data Name =
43 Name
57 Name
44− { _author :: !Name.Name
58+ { _author :: !Author
45− , _project :: !Name.Name
59+ , _project :: !Project
46 }
60 }
61+ deriving (Ord)
62+
63+
64+type Author = Utf8.Utf8 AUTHOR
65+type Project = Utf8.Utf8 PROJECT
66+
67+data AUTHOR
68+data PROJECT
47
69
48
70
49data Canonical =
71data Canonical =
@@ -60,127 +82,114 @@ data Canonical =
60
82
61isKernel :: Name -> Bool
83isKernel :: Name -> Bool
62isKernel (Name author _) =
84isKernel (Name author _) =
63− author == "elm" || author == "elm-explorations"
85+ author == elm || author == elm_explorations
64−
65−
66−toString :: Name -> Utf8.String
67−toString (Name author project) =
68− Utf8.join 0x2F [ Name.toUtf8 author, Name.toUtf8 project ]
69
86
70
87
71toChars :: Name -> String
88toChars :: Name -> String
72toChars (Name author project) =
89toChars (Name author project) =
73− Name.toChars author <> "/" <> Name.toChars project
90+ Utf8.toChars author <> "/" <> Utf8.toChars project
74
91
75
92
76toUrl :: Name -> String
93toUrl :: Name -> String
77toUrl (Name author project) =
94toUrl (Name author project) =
78− Name.toChars author ++ "/" ++ Name.toChars project
95+ Utf8.toChars author ++ "/" ++ Utf8.toChars project
79
96
80
97
81toFilePath :: Name -> FilePath
98toFilePath :: Name -> FilePath
82toFilePath (Name author project) =
99toFilePath (Name author project) =
83− Name.toChars author </> Name.toChars project
100+ Utf8.toChars author </> Utf8.toChars project
84
101
85
102
86−fromString :: Utf8.String -> Either BadName Name
103+toJsonString :: Name -> Json.String
87−fromString str =
104+toJsonString (Name author project) =
88− case Utf8.split 0x2F {- / -} str of
89− [author, project]
105+ Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]
90− | Utf8.isEmpty author -> Left BadStructure
91− | Utf8.isEmpty project -> Left BadStructure
92− | Utf8.size project >= 256 -> Left TooLong
93− | Utf8.containsDouble 0x2D {- - -} project -> Left HasDoubleDash
94− | Utf8.contains 0x5F {- _ -} project -> Left HasUnderscore
95− | Utf8.contains 0x2E {- . -} project -> Left HasDot
96− | Utf8.any Char.isUpper project -> Left HasUppercase
97− | Utf8.endsWithWord 0x2D {- - -} project -> Left HasDashEnd
98− | Utf8.startsWithChar Char.isLower project -> Right (Name (Name.fromUtf8 author) (Name.fromUtf8 project))
99− | True -> Left HasNonLowercaseStart
100
106
101− _ ->
102− Left BadStructure
103
107
104
108
105−data BadName
109+-- COMMON PACKAGE NAMES
106− = BadStructure
107− | TooLong
108− | HasDoubleDash
109− | HasUnderscore
110− | HasDot
111− | HasUppercase
112− | HasDashEnd
113− | HasNonLowercaseStart
114−
115
110
116
111
117−-- COMMON PACKAGE NAMES
112+toName :: Author -> [Char] -> Name
113+toName author project =
114+ Name author (Utf8.fromChars project)
118
115
119
116
120{-# NOINLINE dummyName #-}
117{-# NOINLINE dummyName #-}
121dummyName :: Name
118dummyName :: Name
122dummyName =
119dummyName =
123− Name "author" "project"
120+ toName (Utf8.fromChars "author") "project"
124
121
125
122
126{-# NOINLINE kernel #-}
123{-# NOINLINE kernel #-}
127kernel :: Name
124kernel :: Name
128kernel =
125kernel =
129− Name "elm" "kernel"
126+ toName elm "kernel"
130
127
131
128
132{-# NOINLINE core #-}
129{-# NOINLINE core #-}
133core :: Name
130core :: Name
134core =
131core =
135− Name "elm" "core"
132+ toName elm "core"
136
133
137
134
138{-# NOINLINE browser #-}
135{-# NOINLINE browser #-}
139browser :: Name
136browser :: Name
140browser =
137browser =
141− Name "elm" "browser"
138+ toName elm "browser"
142
139
143
140
144{-# NOINLINE virtualDom #-}
141{-# NOINLINE virtualDom #-}
145virtualDom :: Name
142virtualDom :: Name
146virtualDom =
143virtualDom =
147− Name "elm" "virtual-dom"
144+ toName elm "virtual-dom"
148
145
149
146
150{-# NOINLINE html #-}
147{-# NOINLINE html #-}
151html :: Name
148html :: Name
152html =
149html =
153− Name "elm" "html"
150+ toName elm "html"
154
151
155
152
156{-# NOINLINE json #-}
153{-# NOINLINE json #-}
157json :: Name
154json :: Name
158json =
155json =
159− Name "elm" "json"
156+ toName elm "json"
160
157
161
158
162{-# NOINLINE http #-}
159{-# NOINLINE http #-}
163http :: Name
160http :: Name
164http =
161http =
165− Name "elm" "http"
162+ toName elm "http"
166
163
167
164
168{-# NOINLINE url #-}
165{-# NOINLINE url #-}
169url :: Name
166url :: Name
170url =
167url =
171− Name "elm" "url"
168+ toName elm "url"
172
169
173
170
174{-# NOINLINE webgl #-}
171{-# NOINLINE webgl #-}
175webgl :: Name
172webgl :: Name
176webgl =
173webgl =
177− Name "elm-explorations" "webgl"
174+ toName elm_explorations "webgl"
178
175
179
176
180{-# NOINLINE linearAlgebra #-}
177{-# NOINLINE linearAlgebra #-}
181linearAlgebra :: Name
178linearAlgebra :: Name
182linearAlgebra =
179linearAlgebra =
183− Name "elm-explorations" "linear-algebra"
180+ toName elm_explorations "linear-algebra"
181+
182+
183+{-# NOINLINE elm #-}
184+elm :: Author
185+elm =
186+ Utf8.fromChars "elm"
187+
188+
189+{-# NOINLINE elm_explorations #-}
190+elm_explorations :: Author
191+elm_explorations =
192+ Utf8.fromChars "elm-explorations"
184
193
185
194
186
195
@@ -189,17 +198,62 @@ linearAlgebra =
189
198
190suggestions :: Map.Map Name.Name Name
199suggestions :: Map.Map Name.Name Name
191suggestions =
200suggestions =
201+ let
202+ random = toName elm "random"
203+ time = toName elm "time"
204+ file = toName elm "file"
205+ in
192 Map.fromList
206 Map.fromList
193− [ ("Browser", browser)
207+ [ "Browser" ==> browser
208+ , "File" ==> file
209+ , "File.Download" ==> file
210+ , "File.Select" ==> file
194− , ("Html", html)
211+ , "Html" ==> html
212+ , "Html.Attributes" ==> html
213+ , "Html.Events" ==> html
195− , ("Http", http)
214+ , "Http" ==> http
196− , ("Json.Decode", json)
215+ , "Json.Decode" ==> json
197− , ("Json.Encode", json)
216+ , "Json.Encode" ==> json
217+ , "Random" ==> random
218+ , "Time" ==> time
198− , ("Url.Parser", url)
219+ , "Url.Parser" ==> url
199− , ("Url", url)
220+ , "Url" ==> url
200 ]
221 ]
201
222
202
223
224+(==>) :: [Char] -> Name -> (Name.Name, Name)
225+(==>) moduleName package =
226+ ( Utf8.fromChars moduleName, package )
227+
228+
229+
230+-- NEARBY NAMES
231+
232+
233+nearbyNames :: Name -> [Name] -> [Name]
234+nearbyNames (Name author1 project1) possibleNames =
235+ let
236+ authorDist = authorDistance (Utf8.toChars author1)
237+ projectDist = projectDistance (Utf8.toChars project1)
238+
239+ nameDistance (Name author2 project2) =
240+ authorDist author2 + projectDist project2
241+ in
242+ take 4 $ List.sortOn nameDistance possibleNames
243+
244+
245+authorDistance :: [Char] -> Author -> Int
246+authorDistance given possibility =
247+ if possibility == elm || possibility == elm_explorations
248+ then 0
249+ else abs (Suggest.distance given (Utf8.toChars possibility))
250+
251+
252+projectDistance :: [Char] -> Project -> Int
253+projectDistance given possibility =
254+ abs (Suggest.distance given (Utf8.toChars possibility))
255+
256+
203
257
204-- INSTANCES
258-- INSTANCES
205
259
@@ -214,17 +268,13 @@ instance Eq Canonical where
214 version1 == version2 && package1 == package2
268 version1 == version2 && package1 == package2
215
269
216
270
217−instance Ord Name where
271+
218− compare (Name author1 project1) (Name author2 project2) =
272+-- BINARY
219− case compare project1 project2 of
220− LT -> LT
221− EQ -> compare author1 author2
222− GT -> GT
223
273
224
274
225−instance Binary Name where
275+instance Binary Name where -- PERF try storing as a Word16
226− get = liftM2 Name get get
276+ get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
227− put (Name a b) = put a >> put b
277+ put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
228
278
229
279
230instance Binary Canonical where
280instance Binary Canonical where
@@ -236,17 +286,89 @@ instance Binary Canonical where
236-- JSON
286-- JSON
237
287
238
288
239−decoder :: Decode.Decoder BadName Name
289+decoder :: D.Decoder (Row, Col) Name
240decoder =
290decoder =
241− do str <- Decode.string
291+ D.customString parser (,)
242− case fromString str of
243− Right name ->
244− return name
245−
246− Left err ->
247− Decode.failure err
248
292
249
293
250−encode :: Name -> Encode.Value
294+encode :: Name -> E.Value
251encode name =
295encode name =
252− Encode.string (toString name)
296+ E.chars (toChars name)
297+
298+
299+keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name
300+keyDecoder toError =
301+ let
302+ keyParser =
303+ P.specialize (\(r,c) _ _ -> toError r c) parser
304+ in
305+ D.KeyDecoder keyParser toError
306+
307+
308+
309+-- PARSER
310+
311+
312+parser :: P.Parser (Row, Col) Name
313+parser =
314+ do author <- parseName isAlphaOrDigit isAlphaOrDigit
315+ P.word1 0x2F {-/-} (,)
316+ project <- parseName isLower isLowerOrDigit
317+ return (Name author project)
318+
319+
320+parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)
321+parseName isGoodStart isGoodInner =
322+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
323+ if pos >= end then
324+ eerr row col (,)
325+ else
326+ let !word = P.unsafeIndex pos in
327+ if not (isGoodStart word) then
328+ eerr row col (,)
329+ else
330+ let
331+ (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False
332+ !len = fromIntegral (minusPtr newPos pos)
333+ !newCol = col + len
334+ in
335+ if isGood && len < 256 then
336+ let !newState = P.State src newPos end indent row newCol in
337+ cok (Utf8.fromPtr pos newPos) newState
338+ else
339+ cerr row newCol (,)
340+
341+
342+isLower :: Word8 -> Bool
343+isLower word =
344+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
345+
346+
347+isLowerOrDigit :: Word8 -> Bool
348+isLowerOrDigit word =
349+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
350+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}
351+
352+
353+isAlphaOrDigit :: Word8 -> Bool
354+isAlphaOrDigit word =
355+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
356+ || 0x41 {-A-} <= word && word <= 0x5A {-Z-}
357+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}
358+
359+
360+chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)
361+chompName isGoodChar pos end prevWasDash =
362+ if pos >= end then
363+ (# not prevWasDash, pos #)
364+ else
365+ let !word = P.unsafeIndex pos in
366+ if isGoodChar word then
367+ chompName isGoodChar (plusPtr pos 1) end False
368+ else if word == 0x2D {---} then
369+ if prevWasDash then
370+ (# False, pos #)
371+ else
372+ chompName isGoodChar (plusPtr pos 1) end True
373+ else
374+ (# True, pos #)
compiler/src/Elm/String.hsnew file+133
@@ -0,0 +1,133 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}
3+module Elm.String
4+ ( String
5+ , toChars
6+ , toBuilder
7+ , Chunk(..)
8+ , fromChunks
9+ )
10+ where
11+
12+
13+import Prelude hiding (String)
14+import Data.Binary (Binary, get, put)
15+import Data.Bits ((.&.), shiftR)
16+import qualified Data.ByteString.Builder as B
17+import qualified Data.Utf8 as Utf8
18+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
19+import GHC.Exts (RealWorld, Ptr)
20+import GHC.IO (stToIO, unsafeDupablePerformIO)
21+import GHC.ST (ST)
22+import GHC.Word (Word8)
23+
24+
25+
26+-- STRINGS
27+
28+
29+type String =
30+ Utf8.Utf8 ELM_STRING
31+
32+
33+data ELM_STRING
34+
35+
36+
37+-- HELPERS
38+
39+
40+toChars :: String -> [Char]
41+toChars =
42+ Utf8.toChars
43+
44+
45+{-# INLINE toBuilder #-}
46+toBuilder :: String -> B.Builder
47+toBuilder =
48+ Utf8.toBuilder
49+
50+
51+
52+-- FROM CHUNKS
53+
54+
55+data Chunk
56+ = Slice (Ptr Word8) Int
57+ | Escape Word8
58+ | CodePoint Int
59+
60+
61+fromChunks :: [Chunk] -> String
62+fromChunks chunks =
63+ unsafeDupablePerformIO (stToIO (
64+ do let !len = sum (map chunkToWidth chunks)
65+ mba <- newByteArray len
66+ writeChunks mba 0 chunks
67+ freeze mba
68+ ))
69+
70+
71+chunkToWidth :: Chunk -> Int
72+chunkToWidth chunk =
73+ case chunk of
74+ Slice _ len -> len
75+ Escape _ -> 2
76+ CodePoint c -> if c < 0xFFFF then 6 else 12
77+
78+
79+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
80+writeChunks mba offset chunks =
81+ case chunks of
82+ [] ->
83+ return ()
84+
85+ chunk : chunks ->
86+ case chunk of
87+ Slice ptr len ->
88+ do copyFromPtr ptr mba offset len
89+ let !newOffset = offset + len
90+ writeChunks mba newOffset chunks
91+
92+ Escape word ->
93+ do writeWord8 mba offset 0x5C {- \ -}
94+ writeWord8 mba (offset + 1) word
95+ let !newOffset = offset + 2
96+ writeChunks mba newOffset chunks
97+
98+ CodePoint code ->
99+ if code < 0xFFFF then
100+ do writeCode mba offset code
101+ let !newOffset = offset + 6
102+ writeChunks mba newOffset chunks
103+ else
104+ do let (hi,lo) = divMod (code - 0x10000) 0x400
105+ writeCode mba (offset ) (hi + 0xD800)
106+ writeCode mba (offset + 6) (lo + 0xDC00)
107+ let !newOffset = offset + 12
108+ writeChunks mba newOffset chunks
109+
110+
111+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112+writeCode mba offset code =
113+ do writeWord8 mba offset 0x5C {- \ -}
114+ writeWord8 mba (offset + 1) 0x75 {- u -}
115+ writeHex mba (offset + 2) (shiftR code 12)
116+ writeHex mba (offset + 3) (shiftR code 8)
117+ writeHex mba (offset + 4) (shiftR code 4)
118+ writeHex mba (offset + 5) code
119+
120+
121+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
122+writeHex mba !offset !bits =
123+ do let !n = fromIntegral bits .&. 0x0F
124+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
125+
126+
127+
128+-- BINARY
129+
130+
131+instance Binary (Utf8.Utf8 ELM_STRING) where
132+ get = Utf8.getVeryLong
133+ put = Utf8.putVeryLong
compiler/src/Elm/Version.hs+73−43
@@ -1,3 +1,5 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
1module Elm.Version
3module Elm.Version
2 ( Version(..)
4 ( Version(..)
3 , one
5 , one
@@ -7,10 +9,11 @@ module Elm.Version
7 , bumpMinor
9 , bumpMinor
8 , bumpMajor
10 , bumpMajor
9 , toChars
11 , toChars
10− , toString
12+ --
11− , fromString
12 , decoder
13 , decoder
13 , encode
14 , encode
15+ --
16+ , parser
14 )
17 )
15 where
18 where
16
19
@@ -18,13 +21,15 @@ module Elm.Version
18import Prelude hiding (max)
21import Prelude hiding (max)
19import Control.Monad (liftM3)
22import Control.Monad (liftM3)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
23import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Utf8 as Utf8
22import qualified Data.Version as Version
24import qualified Data.Version as Version
23−import Data.Word (Word16)
25+import Data.Word (Word8, Word16)
26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
24import qualified Paths_elm
27import qualified Paths_elm
25
28
26import qualified Json.Decode as D
29import qualified Json.Decode as D
27import qualified Json.Encode as E
30import qualified Json.Encode as E
31+import qualified Parse.Primitives as P
32+import Parse.Primitives (Row, Col)
28
33
29
34
30
35
@@ -86,58 +91,26 @@ bumpMajor (Version major _minor _patch) =
86
91
87
92
88
93
89−-- TO STRING
94+-- TO CHARS
90
95
91
96
92−toChars :: Version -> String
97+toChars :: Version -> [Char]
93−toChars vsn =
94− Utf8.toChars (toString vsn)
95−
96−
97−toString :: Version -> Utf8.String
98−toString (Version major minor patch) =
98+toChars (Version major minor patch) =
99− Utf8.join 0x2E {- . -}
99+ show major ++ '.' : show minor ++ '.' : show patch
100− [ Utf8.fromWord16 major
101− , Utf8.fromWord16 minor
102− , Utf8.fromWord16 patch
103− ]
104−
105−
106−
107−-- FROM STRING
108−
109−
110−fromString :: Utf8.String -> Maybe Version
111−fromString str =
112− case Utf8.split 0x2E {- . -} str of
113− [major, minor, patch] ->
114− Version
115− <$> Utf8.toWord16 major
116− <*> Utf8.toWord16 minor
117− <*> Utf8.toWord16 patch
118−
119− _ ->
120− Nothing
121
100
122
101
123
102
124-- JSON
103-- JSON
125
104
126
105
127−decoder :: D.Decoder Utf8.String Version
106+decoder :: D.Decoder (Row, Col) Version
128decoder =
107decoder =
129− do str <- D.string
108+ D.customString parser (,)
130− case fromString str of
131− Just version ->
132− return version
133−
134− Nothing ->
135− D.failure str
136
109
137
110
138encode :: Version -> E.Value
111encode :: Version -> E.Value
139encode version =
112encode version =
140− E.string (toString version)
113+ E.chars (toChars version)
141
114
142
115
143
116
@@ -164,3 +137,60 @@ instance Binary Version where
164 put major
137 put major
165 put minor
138 put minor
166 put patch
139 put patch
140+
141+
142+
143+-- PARSER
144+
145+
146+parser :: P.Parser (Row, Col) Version
147+parser =
148+ do major <- numberParser
149+ P.word1 0x2E {-.-} (,)
150+ minor <- numberParser
151+ P.word1 0x2E {-.-} (,)
152+ patch <- numberParser
153+ return (Version major minor patch)
154+
155+
156+numberParser :: P.Parser (Row, Col) Word16
157+numberParser =
158+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
159+ if pos >= end then
160+ eerr row col (,)
161+ else
162+ let !word = P.unsafeIndex pos in
163+ if word == 0x30 {-0-} then
164+
165+ let
166+ !newState = P.State src (plusPtr pos 1) end indent row (col + 1)
167+ in
168+ cok 0 newState
169+
170+ else if isDigit word then
171+
172+ let
173+ (# total, newPos #) = chompWord16 (plusPtr pos 1) end (fromIntegral (word - 0x30))
174+ !newState = P.State src newPos end indent row (col + fromIntegral (minusPtr newPos pos))
175+ in
176+ cok total newState
177+
178+ else
179+ eerr row col (,)
180+
181+
182+chompWord16 :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Word16, Ptr Word8 #)
183+chompWord16 pos end total =
184+ if pos >= end then
185+ (# total, pos #)
186+ else
187+ let !word = P.unsafeIndex pos in
188+ if isDigit word then
189+ chompWord16 (plusPtr pos 1) end (10 * total + fromIntegral (word - 0x30))
190+ else
191+ (# total, pos #)
192+
193+
194+isDigit :: Word8 -> Bool
195+isDigit word =
196+ 0x30 {-0-} <= word && word <= 0x39 {-9-}
compiler/src/Generate/Html.hs+11−10
@@ -29,22 +29,23 @@ sandwich moduleName javascript =
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+76−55
@@ -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
@@ -225,7 +261,7 @@ addKernel (State revKernels revBuilders seen) kernel =
225
261
226var :: Opt.Global -> Expr.Code -> JS.Stmt
262var :: Opt.Global -> Expr.Code -> JS.Stmt
227var (Opt.Global home name) code =
263var (Opt.Global home name) code =
228− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
264+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
229
265
230
266
231isDebugger :: Opt.Global -> Bool
267isDebugger :: Opt.Global -> Bool
@@ -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
@@ -265,10 +301,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
265generateCycleFunc mode home def =
301generateCycleFunc mode home def =
266 case def of
302 case def of
267 Opt.Def name expr ->
303 Opt.Def name expr ->
268− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
304+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
269
305
270 Opt.TailDef name args expr ->
306 Opt.TailDef name args expr ->
271− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
307+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
272
308
273
309
274generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
@@ -284,9 +320,9 @@ generateRealCycle home (name, _) =
284 realName = JsName.fromGlobal home name
320 realName = JsName.fromGlobal home name
285 in
321 in
286 JS.Block
322 JS.Block
287− [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
323+ [ JS.Var realName (JS.Call (JS.Ref safeName) [])
288 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
289− JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
325+ JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
290 ]
326 ]
291
327
292
328
@@ -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
@@ -354,16 +390,13 @@ addChunk mode chunk builder =
354
390
355generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
356generateEnum mode global@(Opt.Global home name) index =
392generateEnum mode global@(Opt.Global home name) index =
357− let
393+ JS.Var (JsName.fromGlobal home name) $
358− definition =
359− case mode of
394+ case mode of
360− Mode.Dev _ ->
395+ Mode.Dev _ ->
361− Expr.codeToExpr (Expr.generateCtor mode global index 0)
396+ Expr.codeToExpr (Expr.generateCtor mode global index 0)
362
397
363− Mode.Prod _ ->
398+ Mode.Prod _ ->
364− JS.Int (Index.toMachine index)
399+ JS.Int (Index.toMachine index)
365− in
366− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
367
400
368
401
369
402
@@ -372,16 +405,13 @@ generateEnum mode global@(Opt.Global home name) index =
372
405
373generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
374generateBox mode global@(Opt.Global home name) =
407generateBox mode global@(Opt.Global home name) =
375− let
408+ JS.Var (JsName.fromGlobal home name) $
376− definition =
377− case mode of
409+ case mode of
378− Mode.Dev _ ->
410+ Mode.Dev _ ->
379− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
411+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
380
412
381− Mode.Prod _ ->
413+ Mode.Prod _ ->
382− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
414+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
383− in
384− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
385
415
386
416
387{-# NOINLINE identity #-}
417{-# NOINLINE identity #-}
@@ -396,14 +426,11 @@ identity =
396
426
397generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
398generatePort mode (Opt.Global home name) makePort converter =
428generatePort mode (Opt.Global home name) makePort converter =
399− let
429+ JS.Var (JsName.fromGlobal home name) $
400− definition =
401− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
430+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
402− [ JS.String (Name.toBuilder name)
431+ [ JS.String (Name.toBuilder name)
403− , Expr.codeToExpr (Expr.generate mode converter)
432+ , Expr.codeToExpr (Expr.generate mode converter)
404− ]
433+ ]
405− in
406− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
407
434
408
435
409
436
@@ -431,11 +458,9 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)
431
458
432generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
433generateLeaf home@(ModuleName.Canonical _ moduleName) name =
460generateLeaf home@(ModuleName.Canonical _ moduleName) name =
434− let
461+ JS.Var (JsName.fromGlobal home name) $
435− definition =
436− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
462+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
437− in
463+
438− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
439
464
440
465
441{-# NOINLINE leaf #-}
466{-# NOINLINE leaf #-}
@@ -509,7 +534,7 @@ generateExports mode (Trie maybeMain subs) =
509 <> List.foldl' (addSubTrie mode) "}" otherSubTries
534 <> List.foldl' (addSubTrie mode) "}" otherSubTries
510
535
511
536
512−addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
537+addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
513addSubTrie mode end (name, trie) =
538addSubTrie mode end (name, trie) =
514 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
515
540
@@ -521,7 +546,7 @@ addSubTrie mode end (name, trie) =
521data Trie =
546data Trie =
522 Trie
547 Trie
523 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
524− , _subs :: Map.Map Utf8.String Trie
549+ , _subs :: Map.Map Name.Name Trie
525 }
550 }
526
551
527
552
@@ -532,14 +557,10 @@ emptyTrie =
532
557
533addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
534addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
535− let
536− segments =
537− Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
538− in
539− merge trie $ segmentsToTrie home segments main
560+ merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
540
561
541
562
542−segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
563+segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
543segmentsToTrie home segments main =
564segmentsToTrie home segments main =
544 case segments of
565 case segments of
545 [] ->
566 [] ->
compiler/src/Generate/JavaScript/Builder.hs+207−217
@@ -16,6 +16,7 @@ module Generate.JavaScript.Builder
16
16
17import Prelude hiding (lines)
17import Prelude hiding (lines)
18import qualified Data.List as List
18import qualified Data.List as List
19+import qualified Data.ByteString as BS
19import Data.ByteString.Builder as B
20import Data.ByteString.Builder as B
20import Data.Monoid ((<>))
21import Data.Monoid ((<>))
21import qualified Generate.JavaScript.Name as Name
22import qualified Generate.JavaScript.Name as Name
@@ -27,6 +28,19 @@ import qualified Json.Encode as Json
27-- EXPRESSIONS
28-- EXPRESSIONS
28
29
29
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+--
30data Expr
44data Expr
31 = String Builder
45 = String Builder
32 | Float Builder
46 | Float Builder
@@ -37,13 +51,13 @@ data Expr
37 | Array [Expr]
51 | Array [Expr]
38 | Object [(Name, Expr)]
52 | Object [(Name, Expr)]
39 | Ref Name
53 | Ref Name
40− | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
54+ | Access Expr Name -- foo.bar
41− | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
55+ | Index Expr Expr -- foo[bar]
42 | Prefix PrefixOp Expr
56 | Prefix PrefixOp Expr
43 | Infix InfixOp Expr Expr
57 | Infix InfixOp Expr Expr
44 | If Expr Expr Expr
58 | If Expr Expr Expr
45 | Assign LValue Expr
59 | Assign LValue Expr
46− | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
60+ | Call Expr [Expr]
47 | Function (Maybe Name) [Name] [Stmt]
61 | Function (Maybe Name) [Name] [Stmt]
48
62
49
63
@@ -58,20 +72,21 @@ data LValue
58
72
59
73
60data Stmt
74data Stmt
61− = Block [Stmt] -- {stmts}
75+ = Block [Stmt]
62− | EmptyStmt -- ;
76+ | EmptyStmt
63− | ExprStmt Expr -- expr;
77+ | ExprStmt Expr
64− | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
78+ | IfStmt Expr Stmt Stmt
65− | Switch Expr [Case] -- switch (e) clauses
79+ | Switch Expr [Case]
66− | While Expr Stmt -- while (e) do stmt
80+ | While Expr Stmt
67− | Break (Maybe Name) -- break lab;
81+ | Break (Maybe Name)
68− | Continue (Maybe Name) -- continue lab;
82+ | Continue (Maybe Name)
69− | Labelled Name Stmt -- lab: stmt
83+ | Labelled Name Stmt
70− | Try Stmt Name Stmt -- try stmt catch (x) stmt
84+ | Try Stmt Name Stmt
71− | Throw Expr -- throw expr;
85+ | Throw Expr
72− | Return (Maybe Expr) -- return expr;
86+ | Return Expr
87+ | Var Name Expr
73− | Var [(Name, Maybe Expr)] -- var x, y=42;
88+ | Vars [(Name, Expr)]
74− | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
89+ | FunctionStmt Name [Name] [Stmt]
75
90
76
91
77data Case
92data Case
@@ -84,37 +99,31 @@ data Case
84
99
85
100
86data InfixOp
101data InfixOp
87− = OpLT -- <
102+ = OpAdd -- +
88− | OpLEq -- <=
103+ | OpSub -- -
89− | OpGT -- >
90− | OpGEq -- >=
91− | OpIn -- in
92− | OpInstanceof -- instanceof
93− | OpEq -- ==
94− | OpNEq -- !=
95− | OpStrictEq -- ===
96− | OpStrictNEq -- !==
97− | OpLAnd -- &&
98− | OpLOr -- ||
99 | OpMul -- *
104 | OpMul -- *
100 | OpDiv -- /
105 | OpDiv -- /
101 | OpMod -- %
106 | OpMod -- %
102− | OpSub -- -
107+ | OpEq -- ===
108+ | OpNe -- !==
109+ | OpLt -- <
110+ | OpLe -- <=
111+ | OpGt -- >
112+ | OpGe -- >=
113+ | OpAnd -- &&
114+ | OpOr -- ||
115+ | OpBitwiseAnd -- &
116+ | OpBitwiseXor -- ^
117+ | OpBitwiseOr -- |
103− | OpLShift -- <<
118+ | OpLShift -- <<
104− | OpSpRShift -- >>
119+ | OpSpRShift -- >>
105− | OpZfRShift -- >>>
120+ | OpZfRShift -- >>>
106− | OpBAnd -- &
107− | OpBXor -- ^
108− | OpBOr -- |
109− | OpAdd -- +
110
121
111
122
112data PrefixOp
123data PrefixOp
113− = PrefixLNot -- !
124+ = PrefixNot -- !
114− | PrefixBNot -- ~
125+ | PrefixNegate -- -
115− | PrefixPlus -- +
126+ | PrefixComplement -- ~
116− | PrefixMinus -- -
117− | PrefixTypeof -- typeof
118
127
119
128
120
129
@@ -123,21 +132,40 @@ data PrefixOp
123
132
124stmtToBuilder :: Stmt -> Builder
133stmtToBuilder :: Stmt -> Builder
125stmtToBuilder stmts =
134stmtToBuilder stmts =
126− fromStmt "" stmts
135+ fromStmt levelZero stmts
127
136
128
137
129exprToBuilder :: Expr -> Builder
138exprToBuilder :: Expr -> Builder
130exprToBuilder expr =
139exprToBuilder expr =
131− snd $ fromExpr "" Whatever expr
140+ snd $ fromExpr levelZero Whatever expr
132
141
133
142
134
143
135−-- HELPERS
144+-- INDENT LEVEL
145+
146+
147+data Level =
148+ Level Builder Level
149+
150+
151+levelZero :: Level
152+levelZero =
153+ Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
154+
155+
156+makeLevel :: Int -> BS.ByteString -> Level
157+makeLevel level oldTabs =
158+ let
159+ tabs =
160+ if level <= BS.length oldTabs
161+ then oldTabs
162+ else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
163+ in
164+ Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
165+
136
166
137
167
138−deeper :: Builder -> Builder
168+-- HELPERS
139−deeper indent =
140− "\t" <> indent
141
169
142
170
143commaSep :: [Builder] -> Builder
171commaSep :: [Builder] -> Builder
@@ -145,52 +173,52 @@ commaSep builders =
145 mconcat (List.intersperse ", " builders)
173 mconcat (List.intersperse ", " builders)
146
174
147
175
148−commaNewlineSep :: Builder -> [Builder] -> Builder
176+commaNewlineSep :: Level -> [Builder] -> Builder
149−commaNewlineSep indent builders =
177+commaNewlineSep (Level _ (Level deeperIndent _)) builders =
150− mconcat (List.intersperse (",\n" <> deeper indent) builders)
178+ mconcat (List.intersperse (",\n" <> deeperIndent) builders)
151
179
152
180
153
181
154-- STATEMENTS
182-- STATEMENTS
155
183
156
184
157−fromStmtBlock :: Builder -> [Stmt] -> Builder
185+fromStmtBlock :: Level -> [Stmt] -> Builder
158−fromStmtBlock indent stmts =
186+fromStmtBlock level stmts =
159− mconcat (map (fromStmt indent) stmts)
187+ mconcat (map (fromStmt level) stmts)
160
188
161
189
162−fromStmt :: Builder -> Stmt -> Builder
190+fromStmt :: Level -> Stmt -> Builder
163−fromStmt indent statement =
191+fromStmt level@(Level indent nextLevel) statement =
164 case statement of
192 case statement of
165 Block stmts ->
193 Block stmts ->
166− fromStmtBlock indent stmts
194+ fromStmtBlock level stmts
167
195
168 EmptyStmt ->
196 EmptyStmt ->
169 mempty
197 mempty
170
198
171 ExprStmt expr ->
199 ExprStmt expr ->
172− indent <> snd (fromExpr indent Whatever expr) <> ";\n"
200+ indent <> snd (fromExpr level Whatever expr) <> ";\n"
173
201
174 IfStmt condition thenStmt elseStmt ->
202 IfStmt condition thenStmt elseStmt ->
175 mconcat
203 mconcat
176− [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
204+ [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
177− , fromStmt (deeper indent) thenStmt
205+ , fromStmt nextLevel thenStmt
178 , indent, "} else {\n"
206 , indent, "} else {\n"
179− , fromStmt (deeper indent) elseStmt
207+ , fromStmt nextLevel elseStmt
180 , indent, "}\n"
208 , indent, "}\n"
181 ]
209 ]
182
210
183 Switch expr clauses ->
211 Switch expr clauses ->
184 mconcat
212 mconcat
185− [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
213+ [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
186− , mconcat (map (fromClause (deeper indent)) clauses)
214+ , mconcat (map (fromClause nextLevel) clauses)
187 , indent, "}\n"
215 , indent, "}\n"
188 ]
216 ]
189
217
190 While expr stmt ->
218 While expr stmt ->
191 mconcat
219 mconcat
192− [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
220+ [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
193− , fromStmt (deeper indent) stmt
221+ , fromStmt nextLevel stmt
194 , indent, "}\n"
222 , indent, "}\n"
195 ]
223 ]
196
224
@@ -209,37 +237,37 @@ fromStmt indent statement =
209 Labelled label stmt ->
237 Labelled label stmt ->
210 mconcat
238 mconcat
211 [ indent, Name.toBuilder label, ":\n"
239 [ indent, Name.toBuilder label, ":\n"
212− , fromStmt indent stmt
240+ , fromStmt level stmt
213 ]
241 ]
214
242
215 Try tryStmt errorName catchStmt ->
243 Try tryStmt errorName catchStmt ->
216 mconcat
244 mconcat
217 [ indent, "try {\n"
245 [ indent, "try {\n"
218− , fromStmt (deeper indent) tryStmt
246+ , fromStmt nextLevel tryStmt
219 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
220− , fromStmt (deeper indent) catchStmt
248+ , fromStmt nextLevel catchStmt
221 , indent, "}\n"
249 , indent, "}\n"
222 ]
250 ]
223
251
224 Throw expr ->
252 Throw expr ->
225− "throw " <> snd (fromExpr indent Whatever expr) <> ";"
253+ indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
226
254
227− Return Nothing ->
255+ Return expr ->
228− indent <> "return;\n"
256+ indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
229
257
230− Return (Just expr) ->
258+ Var name expr ->
231− indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
259+ indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
232
260
233− Var [] ->
261+ Vars [] ->
234 mempty
262 mempty
235
263
236− Var vars ->
264+ Vars vars ->
237− indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
265+ indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
238
266
239 FunctionStmt name args stmts ->
267 FunctionStmt name args stmts ->
240 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
241 <>
269 <>
242− fromStmtBlock (deeper indent) stmts
270+ fromStmtBlock nextLevel stmts
243 <>
271 <>
244 indent <> "}\n"
272 indent <> "}\n"
245
273
@@ -248,30 +276,25 @@ fromStmt indent statement =
248-- SWITCH CLAUSES
276-- SWITCH CLAUSES
249
277
250
278
251−fromClause :: Builder -> Case -> Builder
279+fromClause :: Level -> Case -> Builder
252−fromClause indent clause =
280+fromClause level@(Level indent nextLevel) clause =
253 case clause of
281 case clause of
254 Case expr stmts ->
282 Case expr stmts ->
255− indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
283+ indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
256− <> fromStmtBlock (deeper indent) stmts
284+ <> fromStmtBlock nextLevel stmts
257
285
258 Default stmts ->
286 Default stmts ->
259 indent <> "default:\n"
287 indent <> "default:\n"
260− <> fromStmtBlock (deeper indent) stmts
288+ <> fromStmtBlock nextLevel stmts
261
289
262
290
263
291
264-- VAR DECLS
292-- VAR DECLS
265
293
266
294
267−varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
295+varToBuilder :: Level -> (Name, Expr) -> Builder
268−varToBuilder indent (name, maybeExpr) =
296+varToBuilder level (name, expr) =
269− case maybeExpr of
270− Nothing ->
271− Name.toBuilder name
272−
273− Just expr ->
274− Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
297+ Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
275
298
276
299
277
300
@@ -289,12 +312,11 @@ merge a b =
289linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
290linesMap func xs =
313linesMap func xs =
291 let
314 let
292− pairs =
293− map func xs
315+ pairs = map func xs
294 in
316 in
295− ( any ((==) Many . fst) pairs
317+ ( any ((==) Many . fst) pairs
296− , map snd pairs
318+ , map snd pairs
297− )
319+ )
298
320
299
321
300data Grouping = Atomic | Whatever
322data Grouping = Atomic | Whatever
@@ -310,23 +332,23 @@ parensFor grouping builder =
310 builder
332 builder
311
333
312
334
313−fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
335+fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
314−fromExpr indent grouping expression =
336+fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
315 case expression of
337 case expression of
316 String string ->
338 String string ->
317− (One, "'" <> string <> "'")
339+ ( One, "'" <> string <> "'" )
318
340
319 Float float ->
341 Float float ->
320− (One, float)
342+ ( One, float )
321
343
322 Int n ->
344 Int n ->
323− (One, B.intDec n)
345+ ( One, B.intDec n )
324
346
325 Bool bool ->
347 Bool bool ->
326− (One, if bool then "true" else "false")
348+ ( One, if bool then "true" else "false" )
327
349
328 Null ->
350 Null ->
329− (One, "null")
351+ ( One, "null" )
330
352
331 Json json ->
353 Json json ->
332 ( One, Json.encodeUgly json )
354 ( One, Json.encodeUgly json )
@@ -334,111 +356,90 @@ fromExpr indent grouping expression =
334 Array exprs ->
356 Array exprs ->
335 (,) Many $
357 (,) Many $
336 let
358 let
337− (anyMany, builders) =
338− linesMap (fromExpr indent Whatever) exprs
359+ (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
339 in
360 in
340− if anyMany then
361+ if anyMany then
341− "[\n"
362+ "[\n"
342− <> deeper indent
363+ <> deeperIndent
343− <> commaNewlineSep indent builders
364+ <> commaNewlineSep level builders
344− <> "\n" <> indent <> "]"
365+ <> "\n" <> indent <> "]"
345−
346− else
366+ else
347− "[" <> commaSep builders <> "]"
367+ "[" <> commaSep builders <> "]"
348
368
349 Object fields ->
369 Object fields ->
350 (,) Many $
370 (,) Many $
351 let
371 let
352− deeperIndent =
353− deeper indent
354−
355− (anyMany, builders) =
356− linesMap (fromField deeperIndent) fields
372+ (anyMany, builders) = linesMap (fromField nextLevel) fields
357 in
373 in
358− if anyMany then
374+ if anyMany then
359− "{\n"
375+ "{\n"
360− <> deeperIndent
376+ <> deeperIndent
361− <> commaNewlineSep indent builders
377+ <> commaNewlineSep level builders
362− <> "\n" <> indent <> "}"
378+ <> "\n" <> indent <> "}"
363−
364− else
379+ else
365− "{" <> commaSep builders <> "}"
380+ "{" <> commaSep builders <> "}"
366
381
367 Ref name ->
382 Ref name ->
368− (One, Name.toBuilder name)
383+ ( One, Name.toBuilder name )
369
384
370 Access expr field ->
385 Access expr field ->
371− makeDot indent expr field
386+ makeDot level expr field
372
387
373 Index expr bracketedExpr ->
388 Index expr bracketedExpr ->
374− makeBracketed indent expr bracketedExpr
389+ makeBracketed level expr bracketedExpr
375
390
376 Prefix op expr ->
391 Prefix op expr ->
377 let
392 let
378− (lines, builder) =
379− fromExpr indent Atomic expr
393+ (lines, builder) = fromExpr level Atomic expr
380 in
394 in
381− ( lines
395+ ( lines
382− , parensFor grouping (fromPrefix op <> builder)
396+ , parensFor grouping (fromPrefix op <> builder)
383− )
397+ )
384
398
385 Infix op leftExpr rightExpr ->
399 Infix op leftExpr rightExpr ->
386 let
400 let
387− (leftLines, left) =
388− fromExpr indent Atomic leftExpr
401+ (leftLines , left ) = fromExpr level Atomic leftExpr
389−
390− (rightLines, right) =
391− fromExpr indent Atomic rightExpr
402+ (rightLines, right) = fromExpr level Atomic rightExpr
392 in
403 in
393− ( merge leftLines rightLines
404+ ( merge leftLines rightLines
394− , parensFor grouping (left <> fromInfix op <> right)
405+ , parensFor grouping (left <> fromInfix op <> right)
395− )
406+ )
396
407
397 If condExpr thenExpr elseExpr ->
408 If condExpr thenExpr elseExpr ->
398 let
409 let
399− condB = snd (fromExpr indent Atomic condExpr)
410+ condB = snd (fromExpr level Atomic condExpr)
400− thenB = snd (fromExpr indent Atomic thenExpr)
411+ thenB = snd (fromExpr level Atomic thenExpr)
401− elseB = snd (fromExpr indent Atomic elseExpr)
412+ elseB = snd (fromExpr level Atomic elseExpr)
402 in
413 in
403− ( Many
414+ ( Many
404− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
415+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
405− )
416+ )
406
417
407 Assign lValue expr ->
418 Assign lValue expr ->
408 let
419 let
409− (leftLines, left) =
410− fromLValue indent lValue
420+ (leftLines , left ) = fromLValue level lValue
411−
412− (rightLines, right) =
413− fromExpr indent Whatever expr
421+ (rightLines, right) = fromExpr level Whatever expr
414 in
422 in
415− ( merge leftLines rightLines
423+ ( merge leftLines rightLines
416− , parensFor grouping (left <> " = " <> right)
424+ , parensFor grouping (left <> " = " <> right)
417− )
425+ )
418
426
419 Call function args ->
427 Call function args ->
420 (,) Many $
428 (,) Many $
421 let
429 let
422− deeperIndent =
423− deeper indent
424−
425− funcB =
426− snd (fromExpr indent Atomic function)
430+ (_ , funcB) = fromExpr level Atomic function
427−
428− (anyMany, argsB) =
429− linesMap (fromExpr deeperIndent Whatever) args
431+ (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
430 in
432 in
431− if anyMany then
433+ if anyMany then
432− funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
434+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
433−
434− else
435+ else
435− funcB <> "(" <> commaSep argsB <> ")"
436+ funcB <> "(" <> commaSep argsB <> ")"
436
437
437 Function maybeName args stmts ->
438 Function maybeName args stmts ->
438 (,) Many $
439 (,) Many $
439 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
440 <>
441 <>
441− fromStmtBlock (deeper indent) stmts
442+ fromStmtBlock nextLevel stmts
442 <>
443 <>
443 indent <> "}"
444 indent <> "}"
444
445
@@ -447,55 +448,50 @@ fromExpr indent grouping expression =
447-- FIELDS
448-- FIELDS
448
449
449
450
450−fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
451+fromField :: Level -> (Name, Expr) -> (Lines, Builder)
451−fromField indent (field, expr) =
452+fromField level (field, expr) =
452 let
453 let
453− (lines, builder) =
454− fromExpr indent Whatever expr
454+ (lines, builder) = fromExpr level Whatever expr
455 in
455 in
456− ( lines
456+ ( lines
457− , Name.toBuilder field <> ": " <> builder
457+ , Name.toBuilder field <> ": " <> builder
458− )
458+ )
459
459
460
460
461
461
462-- VALUES
462-- VALUES
463
463
464
464
465−fromLValue :: Builder -> LValue -> (Lines, Builder)
465+fromLValue :: Level -> LValue -> (Lines, Builder)
466−fromLValue indent lValue =
466+fromLValue level lValue =
467 case lValue of
467 case lValue of
468 LRef name ->
468 LRef name ->
469 (One, Name.toBuilder name)
469 (One, Name.toBuilder name)
470
470
471 LDot expr field ->
471 LDot expr field ->
472− makeDot indent expr field
472+ makeDot level expr field
473
473
474 LBracket expr bracketedExpr ->
474 LBracket expr bracketedExpr ->
475− makeBracketed indent expr bracketedExpr
475+ makeBracketed level expr bracketedExpr
476
476
477
477
478−makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
478+makeDot :: Level -> Expr -> Name -> (Lines, Builder)
479−makeDot indent expr field =
479+makeDot level expr field =
480 let
480 let
481− (lines, builder) =
482− fromExpr indent Atomic expr
481+ (lines, builder) = fromExpr level Atomic expr
483 in
482 in
484− (lines, builder <> "." <> Name.toBuilder field)
483+ (lines, builder <> "." <> Name.toBuilder field)
485
484
486
485
487−makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
486+makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
488−makeBracketed indent expr bracketedExpr =
487+makeBracketed level expr bracketedExpr =
489 let
488 let
490− (lines, builder) =
491− fromExpr indent Atomic expr
489+ (lines , builder ) = fromExpr level Atomic expr
492−
493− (bracketedLines, bracketedBuilder) =
490+ (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
494− fromExpr indent Whatever bracketedExpr
495 in
491 in
496− ( merge lines bracketedLines
492+ ( merge lines bracketedLines
497− , builder <> "[" <> bracketedBuilder <> "]"
493+ , builder <> "[" <> bracketedBuilder <> "]"
498− )
494+ )
499
495
500
496
501
497
@@ -505,36 +501,30 @@ makeBracketed indent expr bracketedExpr =
505fromPrefix :: PrefixOp -> Builder
501fromPrefix :: PrefixOp -> Builder
506fromPrefix op =
502fromPrefix op =
507 case op of
503 case op of
508− PrefixLNot -> "!"
504+ PrefixNot -> "!"
509− PrefixBNot -> "~"
505+ PrefixNegate -> "-"
510− PrefixPlus -> "+"
506+ PrefixComplement -> "~"
511− PrefixMinus -> "-"
512− PrefixTypeof -> "typeof "
513
507
514
508
515fromInfix :: InfixOp -> Builder
509fromInfix :: InfixOp -> Builder
516fromInfix op =
510fromInfix op =
517 case op of
511 case op of
518− OpLT -> " < "
512+ OpAdd -> " + "
519− OpLEq -> " <= "
513+ OpSub -> " - "
520− OpGT -> " > "
521− OpGEq -> " >= "
522− OpIn -> " in "
523− OpInstanceof -> " instanceof "
524− OpEq -> " == "
525− OpNEq -> " != "
526− OpStrictEq -> " === "
527− OpStrictNEq -> " !== "
528− OpLAnd -> " && "
529− OpLOr -> " || "
530 OpMul -> " * "
514 OpMul -> " * "
531 OpDiv -> " / "
515 OpDiv -> " / "
532 OpMod -> " % "
516 OpMod -> " % "
533− OpSub -> " - "
517+ OpEq -> " === "
518+ OpNe -> " !== "
519+ OpLt -> " < "
520+ OpLe -> " <= "
521+ OpGt -> " > "
522+ OpGe -> " >= "
523+ OpAnd -> " && "
524+ OpOr -> " || "
525+ OpBitwiseAnd -> " & "
526+ OpBitwiseXor -> " ^ "
527+ OpBitwiseOr -> " | "
534 OpLShift -> " << "
528 OpLShift -> " << "
535 OpSpRShift -> " >> "
529 OpSpRShift -> " >> "
536 OpZfRShift -> " >>> "
530 OpZfRShift -> " >>> "
537− OpBAnd -> " & "
538− OpBXor -> " ^ "
539− OpBOr -> " | "
540− OpAdd -> " + "
compiler/src/Generate/JavaScript/Expression.hs+46−45
@@ -22,6 +22,7 @@ import qualified Data.Utf8 as Utf8
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
@@ -128,8 +130,7 @@ generate mode expression =
128
130
129 Opt.Destruct (Opt.Destructor name path) body ->
131 Opt.Destruct (Opt.Destructor name path) body ->
130 let
132 let
131− pathExpr = generatePath mode path
132− pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]
133+ pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
133 in
134 in
134 JsBlock $ pathDef : codeToStmtList (generate mode body)
135 JsBlock $ pathDef : codeToStmtList (generate mode body)
135
136
@@ -138,7 +139,7 @@ generate mode expression =
138
139
139 Opt.Accessor field ->
140 Opt.Accessor field ->
140 JsExpr $ JS.Function Nothing [JsName.dollar]
141 JsExpr $ JS.Function Nothing [JsName.dollar]
141− [ JS.Return $ Just $
142+ [ JS.Return $
142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
143 ]
144 ]
144
145
@@ -190,7 +191,7 @@ generate mode expression =
190 JS.Object (map toTranlation (Set.toList fields))
191 JS.Object (map toTranlation (Set.toList fields))
191 in
192 in
192 JsExpr $ JS.Object $
193 JsExpr $ JS.Object $
193− [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
194+ [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
196 ]
197 ]
@@ -211,7 +212,7 @@ codeToExpr code =
211 JsExpr expr ->
212 JsExpr expr ->
212 expr
213 expr
213
214
214− JsBlock [ JS.Return (Just expr) ] ->
215+ JsBlock [ JS.Return expr ] ->
215 expr
216 expr
216
217
217 JsBlock stmts ->
218 JsBlock stmts ->
@@ -225,7 +226,7 @@ codeToStmtList code =
225 stmts
226 stmts
226
227
227 JsExpr expr ->
228 JsExpr expr ->
228− [ JS.Return (Just expr) ]
229+ [ JS.Return expr ]
229
230
230 JsBlock stmts ->
231 JsBlock stmts ->
231 stmts
232 stmts
@@ -238,7 +239,7 @@ codeToStmt code =
238 JS.Block stmts
239 JS.Block stmts
239
240
240 JsExpr expr ->
241 JsExpr expr ->
241− JS.Return (Just expr)
242+ JS.Return expr
242
243
243 JsBlock [stmt] ->
244 JsBlock [stmt] ->
244 stmt
245 stmt
@@ -482,17 +483,17 @@ generateBitwiseCall home name args =
482 case args of
483 case args of
483 [arg] ->
484 [arg] ->
484 case name of
485 case name of
485− "complement" -> JS.Prefix JS.PrefixBNot arg
486+ "complement" -> JS.Prefix JS.PrefixComplement arg
486 _ -> generateGlobalCall home name args
487 _ -> generateGlobalCall home name args
487
488
488 [left,right] ->
489 [left,right] ->
489 case name of
490 case name of
490− "and" -> JS.Infix JS.OpBAnd left right
491+ "and" -> JS.Infix JS.OpBitwiseAnd left right
491− "or" -> JS.Infix JS.OpBOr left right
492+ "or" -> JS.Infix JS.OpBitwiseOr left right
492− "xor" -> JS.Infix JS.OpBXor left right
493+ "xor" -> JS.Infix JS.OpBitwiseXor left right
493− "shiftLeftBy" -> JS.Infix JS.OpLShift right left
494+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left
494− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
495+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
495− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
496+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
496 _ -> generateGlobalCall home name args
497 _ -> generateGlobalCall home name args
497
498
498 _ ->
499 _ ->
@@ -505,10 +506,10 @@ generateBasicsCall mode home name args =
505 [elmArg] ->
506 [elmArg] ->
506 let arg = generateJsExpr mode elmArg in
507 let arg = generateJsExpr mode elmArg in
507 case name of
508 case name of
508− "not" -> JS.Prefix JS.PrefixLNot arg
509+ "not" -> JS.Prefix JS.PrefixNot arg
509− "negate" -> JS.Prefix JS.PrefixMinus arg
510+ "negate" -> JS.Prefix JS.PrefixNegate arg
510 "toFloat" -> arg
511 "toFloat" -> arg
511− "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
512+ "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
512 _ -> generateGlobalCall home name [arg]
513 _ -> generateGlobalCall home name [arg]
513
514
514 [elmLeft, elmRight] ->
515 [elmLeft, elmRight] ->
@@ -528,16 +529,16 @@ generateBasicsCall mode home name args =
528 "sub" -> JS.Infix JS.OpSub left right
529 "sub" -> JS.Infix JS.OpSub left right
529 "mul" -> JS.Infix JS.OpMul left right
530 "mul" -> JS.Infix JS.OpMul left right
530 "fdiv" -> JS.Infix JS.OpDiv left right
531 "fdiv" -> JS.Infix JS.OpDiv left right
531− "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
532+ "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
532 "eq" -> equal left right
533 "eq" -> equal left right
533 "neq" -> notEqual left right
534 "neq" -> notEqual left right
534− "lt" -> cmp JS.OpLT JS.OpLT 0 left right
535+ "lt" -> cmp JS.OpLt JS.OpLt 0 left right
535− "gt" -> cmp JS.OpGT JS.OpGT 0 left right
536+ "gt" -> cmp JS.OpGt JS.OpGt 0 left right
536− "le" -> cmp JS.OpLEq JS.OpLT 1 left right
537+ "le" -> cmp JS.OpLe JS.OpLt 1 left right
537− "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
538+ "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
538− "or" -> JS.Infix JS.OpLOr left right
539+ "or" -> JS.Infix JS.OpOr left right
539− "and" -> JS.Infix JS.OpLAnd left right
540+ "and" -> JS.Infix JS.OpAnd left right
540− "xor" -> JS.Infix JS.OpStrictNEq left right
541+ "xor" -> JS.Infix JS.OpNe left right
541 "remainderBy" -> JS.Infix JS.OpMod right left
542 "remainderBy" -> JS.Infix JS.OpMod right left
542 _ -> generateGlobalCall home name [left, right]
543 _ -> generateGlobalCall home name [left, right]
543
544
@@ -558,7 +559,7 @@ notEqual left right =
558 if isLiteral left || isLiteral right then
559 if isLiteral left || isLiteral right then
559 strictNEq left right
560 strictNEq left right
560 else
561 else
561− JS.Prefix JS.PrefixLNot $
562+ JS.Prefix JS.PrefixNot $
562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
563
564
564
565
@@ -647,42 +648,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr
647strictEq left right =
648strictEq left right =
648 case left of
649 case left of
649 JS.Int 0 ->
650 JS.Int 0 ->
650− JS.Prefix JS.PrefixLNot right
651+ JS.Prefix JS.PrefixNot right
651
652
652 JS.Bool bool ->
653 JS.Bool bool ->
653− if bool then right else JS.Prefix JS.PrefixLNot right
654+ if bool then right else JS.Prefix JS.PrefixNot right
654
655
655 _ ->
656 _ ->
656 case right of
657 case right of
657 JS.Int 0 ->
658 JS.Int 0 ->
658− JS.Prefix JS.PrefixLNot left
659+ JS.Prefix JS.PrefixNot left
659
660
660 JS.Bool bool ->
661 JS.Bool bool ->
661− if bool then left else JS.Prefix JS.PrefixLNot left
662+ if bool then left else JS.Prefix JS.PrefixNot left
662
663
663 _ ->
664 _ ->
664− JS.Infix JS.OpStrictEq left right
665+ JS.Infix JS.OpEq left right
665
666
666
667
667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
668strictNEq left right =
669strictNEq left right =
669 case left of
670 case left of
670 JS.Int 0 ->
671 JS.Int 0 ->
671− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)
672+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
672
673
673 JS.Bool bool ->
674 JS.Bool bool ->
674− if bool then JS.Prefix JS.PrefixLNot right else right
675+ if bool then JS.Prefix JS.PrefixNot right else right
675
676
676 _ ->
677 _ ->
677 case right of
678 case right of
678 JS.Int 0 ->
679 JS.Int 0 ->
679− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)
680+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
680
681
681 JS.Bool bool ->
682 JS.Bool bool ->
682− if bool then JS.Prefix JS.PrefixLNot left else left
683+ if bool then JS.Prefix JS.PrefixNot left else left
683
684
684 _ ->
685 _ ->
685− JS.Infix JS.OpStrictNEq left right
686+ JS.Infix JS.OpNe left right
686
687
687
688
688
689
@@ -695,13 +696,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm
695generateTailCall mode name args =
696generateTailCall mode name args =
696 let
697 let
697 toTempVars (argName, arg) =
698 toTempVars (argName, arg) =
698− ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )
699+ ( JsName.makeTemp argName, generateJsExpr mode arg )
699
700
700 toRealVars (argName, _) =
701 toRealVars (argName, _) =
701 JS.ExprStmt $
702 JS.ExprStmt $
702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
703 in
704 in
704− JS.Var (map toTempVars args)
705+ JS.Vars (map toTempVars args)
705 : map toRealVars args
706 : map toRealVars args
706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
707
708
@@ -714,10 +715,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
714generateDef mode def =
715generateDef mode def =
715 case def of
716 case def of
716 Opt.Def name body ->
717 Opt.Def name body ->
717− JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]
718+ JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
718
719
719 Opt.TailDef name argNames body ->
720 Opt.TailDef name argNames body ->
720− JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
721+ JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
721
722
722
723
723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
@@ -850,7 +851,7 @@ generateDecider mode label root decisionTree =
850
851
851 Opt.Chain testChain success failure ->
852 Opt.Chain testChain success failure ->
852 [ JS.IfStmt
853 [ JS.IfStmt
853− (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
854+ (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
854 (JS.Block $ generateDecider mode label root success)
855 (JS.Block $ generateDecider mode label root success)
855 (JS.Block $ generateDecider mode label root failure)
856 (JS.Block $ generateDecider mode label root failure)
856 ]
857 ]
@@ -892,7 +893,7 @@ generateIfTest mode root (path, test) =
892 value
893 value
893
894
894 DT.IsBool False ->
895 DT.IsBool False ->
895− JS.Prefix JS.PrefixLNot value
896+ JS.Prefix JS.PrefixNot value
896
897
897 DT.IsInt int ->
898 DT.IsInt int ->
898 strictEq value (JS.Int int)
899 strictEq value (JS.Int int)
@@ -910,7 +911,7 @@ generateIfTest mode root (path, test) =
910 JS.Access value (JsName.fromLocal "b")
911 JS.Access value (JsName.fromLocal "b")
911
912
912 DT.IsNil ->
913 DT.IsNil ->
913− JS.Prefix JS.PrefixLNot $
914+ JS.Prefix JS.PrefixNot $
914 JS.Access value (JsName.fromLocal "b")
915 JS.Access value (JsName.fromLocal "b")
915
916
916 DT.IsTuple ->
917 DT.IsTuple ->
@@ -1064,6 +1065,6 @@ toDebugMetadata mode msgType =
1064
1065
1065 Mode.Dev (Just interfaces) ->
1066 Mode.Dev (Just interfaces) ->
1066 JS.Json $ Encode.object $
1067 JS.Json $ Encode.object $
1067− [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1068+ [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1068− , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
1069+ , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
1069 ]
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+329−177
@@ -4,68 +4,110 @@ module Json.Decode
4 ( fromByteString
4 ( fromByteString
5 , Decoder
5 , Decoder
6 , string
6 , string
7+ , customString
7 , bool
8 , bool
8 , int
9 , int
9− , list, pair
10+ , list
11+ , nonEmptyList
12+ , pair
13+ --
14+ , KeyDecoder(..)
15+ , dict
10− , dict, pairs, field
16+ , pairs
17+ , field
18+ --
11 , oneOf
19 , oneOf
12 , failure
20 , failure
13 , mapError
21 , mapError
22+ --
23+ , Error(..)
24+ , Problem(..)
25+ , DecodeExpectation(..)
26+ , ParseError(..)
27+ , StringProblem(..)
14 )
28 )
15 where
29 where
16
30
17
31
18−import qualified Data.ByteString as B
32+import qualified Data.ByteString.Internal as B
19−import qualified Data.List as List
20import qualified Data.Map as Map
33import qualified Data.Map as Map
21−import qualified Data.Utf8 as Utf8
34+import qualified Data.NonEmptyList as NE
22−import Data.Word (Word8, Word16)
35+import Data.Word (Word8)
23import Foreign.Ptr (Ptr, plusPtr, minusPtr)
36import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
24
38
39+import qualified Json.String as Json
25import qualified Parse.Keyword as K
40import qualified Parse.Keyword as K
26import qualified Parse.Primitives as P
41import qualified Parse.Primitives as P
42+import Parse.Primitives (Row, Col)
27−import qualified Reporting.Error.Json as E
43+import qualified Reporting.Annotation as A
28
44
29
45
30
46
31-- RUNNERS
47-- RUNNERS
32
48
33
49
34−fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
50+fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
35−fromByteString decoder src =
51+fromByteString (Decoder decode) src =
36− fromAST decoder (P.fromByteString pFile src)
52+ case P.fromByteString pFile BadEnd src of
53+ Right ast ->
54+ decode ast Right (Left . DecodeProblem src)
37
55
38−
56+ Left problem ->
39−fromAST :: Decoder e a -> P.Result E.ParseError AST -> Either (E.Error e) a
40−fromAST (Decoder decode) parserResult =
41− case parserResult of
42− P.Ok ast _ ->
43− decode ast Right (Left . E.DecodeProblem)
44−
45− P.Err err ->
46− Left (E.ParseProblem err)
57+ Left (ParseProblem src problem)
47
58
48
59
49
60
50-- DECODERS
61-- DECODERS
51
62
52
63
53−newtype Decoder e a =
64+newtype Decoder x a =
54 Decoder
65 Decoder
55 (
66 (
56 forall b.
67 forall b.
57 AST
68 AST
58 -> (a -> b)
69 -> (a -> b)
59− -> (E.Problem e -> b)
70+ -> (Problem x -> b)
60 -> b
71 -> b
61 )
72 )
62
73
63
74
64
75
76+-- ERRORS
77+
78+
79+data Error x
80+ = DecodeProblem B.ByteString (Problem x)
81+ | ParseProblem B.ByteString ParseError
82+
83+
84+
85+-- DECODE PROBLEMS
86+
87+
88+data Problem x
89+ = Field B.ByteString (Problem x)
90+ | Index Int (Problem x)
91+ | OneOf (Problem x) [Problem x]
92+ | Failure A.Region x
93+ | Expecting A.Region DecodeExpectation
94+
95+
96+data DecodeExpectation
97+ = TObject
98+ | TArray
99+ | TString
100+ | TBool
101+ | TInt
102+ | TObjectWith B.ByteString
103+ | TArrayPair Int
104+
105+
106+
65-- INSTANCES
107-- INSTANCES
66
108
67
109
68−instance Functor (Decoder e) where
110+instance Functor (Decoder x) where
69 {-# INLINE fmap #-}
111 {-# INLINE fmap #-}
70 fmap func (Decoder decodeA) =
112 fmap func (Decoder decodeA) =
71 Decoder $ \ast ok err ->
113 Decoder $ \ast ok err ->
@@ -75,7 +117,7 @@ instance Functor (Decoder e) where
75 decodeA ast ok' err
117 decodeA ast ok' err
76
118
77
119
78−instance Applicative (Decoder e) where
120+instance Applicative (Decoder x) where
79 {-# INLINE pure #-}
121 {-# INLINE pure #-}
80 pure = return
122 pure = return
81
123
@@ -92,7 +134,7 @@ instance Applicative (Decoder e) where
92 decodeFunc ast okF err
134 decodeFunc ast okF err
93
135
94
136
95−instance Monad (Decoder e) where
137+instance Monad (Decoder x) where
96 {-# INLINE return #-}
138 {-# INLINE return #-}
97 return a =
139 return a =
98 Decoder $ \_ ok _ ->
140 Decoder $ \_ ok _ ->
@@ -113,24 +155,37 @@ instance Monad (Decoder e) where
113-- STRINGS
155-- STRINGS
114
156
115
157
116−string :: Decoder e Utf8.String
158+string :: Decoder x Json.String
117string =
159string =
118− Decoder $ \ast ok err ->
160+ Decoder $ \(A.At region ast) ok err ->
119 case ast of
161 case ast of
120− String bits ->
162+ String snippet ->
121− ok bits
163+ ok (Json.fromSnippet snippet)
122
164
123 _ ->
165 _ ->
166+ err (Expecting region TString)
167+
168+
169+customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
170+customString parser toBadEnd =
171+ Decoder $ \(A.At region ast) ok err ->
172+ case ast of
173+ String snippet ->
174+ case P.fromSnippet parser toBadEnd snippet of
175+ Right a -> ok a
176+ Left x -> err (Failure region x)
177+
178+ _ ->
124− err (E.Expecting E.TString)
179+ err (Expecting region TString)
125
180
126
181
127
182
128-- BOOL
183-- BOOL
129
184
130
185
131−bool :: Decoder e Bool
186+bool :: Decoder x Bool
132bool =
187bool =
133− Decoder $ \ast ok err ->
188+ Decoder $ \(A.At region ast) ok err ->
134 case ast of
189 case ast of
135 TRUE ->
190 TRUE ->
136 ok True
191 ok True
@@ -139,40 +194,40 @@ bool =
139 ok False
194 ok False
140
195
141 _ ->
196 _ ->
142− err (E.Expecting E.TBool)
197+ err (Expecting region TBool)
143
198
144
199
145
200
146-- INT
201-- INT
147
202
148
203
149−int :: Decoder e Int
204+int :: Decoder x Int
150int =
205int =
151− Decoder $ \ast ok err ->
206+ Decoder $ \(A.At region ast) ok err ->
152 case ast of
207 case ast of
153 Int n ->
208 Int n ->
154 ok n
209 ok n
155
210
156 _ ->
211 _ ->
157− err (E.Expecting E.TInt)
212+ err (Expecting region TInt)
158
213
159
214
160
215
161−-- ARRAYS
216+-- LISTS
162
217
163
218
164−list :: Decoder e a -> Decoder e [a]
219+list :: Decoder x a -> Decoder x [a]
165list decoder =
220list decoder =
166− Decoder $ \ast ok err ->
221+ Decoder $ \(A.At region ast) ok err ->
167 case ast of
222 case ast of
168 Array asts ->
223 Array asts ->
169 listHelp decoder ok err 0 asts []
224 listHelp decoder ok err 0 asts []
170
225
171 _ ->
226 _ ->
172− err (E.Expecting E.TArray)
227+ err (Expecting region TArray)
173
228
174
229
175−listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
230+listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
176listHelp decoder@(Decoder decodeA) ok err !i asts revs =
231listHelp decoder@(Decoder decodeA) ok err !i asts revs =
177 case asts of
232 case asts of
178 [] ->
233 [] ->
@@ -180,24 +235,40 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
180
235
181 ast:asts ->
236 ast:asts ->
182 let
237 let
183− ok' a = listHelp decoder ok err (i+1) asts (a:revs)
238+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)
184− err' e = err (E.Index i e)
239+ err' prob = err (Index i prob)
185 in
240 in
186 decodeA ast ok' err'
241 decodeA ast ok' err'
187
242
188
243
244+
245+-- NON-EMPTY LISTS
246+
247+
248+nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
249+nonEmptyList decoder x =
250+ do values <- list decoder
251+ case values of
252+ v:vs -> return (NE.List v vs)
253+ [] -> failure x
254+
255+
256+
257+-- PAIR
258+
259+
189−pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
260+pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
190pair (Decoder decodeA) (Decoder decodeB) =
261pair (Decoder decodeA) (Decoder decodeB) =
191− Decoder $ \ast ok err ->
262+ Decoder $ \(A.At region ast) ok err ->
192 case ast of
263 case ast of
193 Array vs ->
264 Array vs ->
194 case vs of
265 case vs of
195 [astA,astB] ->
266 [astA,astB] ->
196 let
267 let
197− err0 e = err (E.Index 0 e)
268+ err0 e = err (Index 0 e)
198 ok0 a =
269 ok0 a =
199 let
270 let
200− err1 e = err (E.Index 1 e)
271+ err1 e = err (Index 1 e)
201 ok1 b = ok (a,b)
272 ok1 b = ok (a,b)
202 in
273 in
203 decodeB astB ok1 err1
274 decodeB astB ok1 err1
@@ -205,70 +276,103 @@ pair (Decoder decodeA) (Decoder decodeB) =
205 decodeA astA ok0 err0
276 decodeA astA ok0 err0
206
277
207 _ ->
278 _ ->
208− err (E.Expecting (E.TArrayPair (length vs)))
279+ err (Expecting region (TArrayPair (length vs)))
209
280
210 _ ->
281 _ ->
211− err (E.Expecting E.TArray)
282+ err (Expecting region TArray)
212
283
213
284
214
285
215−-- OBJECT
286+-- OBJECTS
216
287
217
288
218−dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
289+data KeyDecoder x a =
219−dict decoder =
290+ KeyDecoder (P.Parser x a) (Row -> Col -> x)
220− Map.fromList <$> pairs decoder
221
291
222
292
293+dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
294+dict keyDecoder valueDecoder =
295+ Map.fromList <$> pairs keyDecoder valueDecoder
296+
297+
223−pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
298+pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
224−pairs decoder =
299+pairs keyDecoder valueDecoder =
225− Decoder $ \ast ok err ->
300+ Decoder $ \(A.At region ast) ok err ->
226 case ast of
301 case ast of
227 Object kvs ->
302 Object kvs ->
228− pairsHelp decoder ok err kvs []
303+ pairsHelp keyDecoder valueDecoder ok err kvs []
229
304
230 _ ->
305 _ ->
231− err (E.Expecting E.TObject)
306+ err (Expecting region TObject)
232
307
233
308
234−pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
309+pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
235−pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
310+pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
236 case kvs of
311 case kvs of
237 [] ->
312 [] ->
238 ok (reverse revs)
313 ok (reverse revs)
239
314
240− (key, ast) : kvs ->
315+ (snippet, ast) : kvs ->
241− let
316+ case P.fromSnippet keyParser toBadEnd snippet of
317+ Left x ->
318+ err (Failure (snippetToRegion snippet) x)
319+
320+ Right key ->
321+ let
242− ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
322+ ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
243− err' e = err (E.Field key e)
323+ err' prob =
324+ let (P.Snippet fptr off len _ _) = snippet in
325+ err (Field (B.PS fptr off len) prob)
244− in
326+ in
245− decodeA ast ok' err'
327+ decodeA ast ok' err'
328+
246
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))
247
333
334+
335+
336+-- FIELDS
337+
338+
248−field :: Utf8.String -> Decoder e a -> Decoder e a
339+field :: B.ByteString -> Decoder x a -> Decoder x a
249field key (Decoder decodeA) =
340field key (Decoder decodeA) =
250− Decoder $ \ast ok err ->
341+ Decoder $ \(A.At region ast) ok err ->
251 case ast of
342 case ast of
252 Object kvs ->
343 Object kvs ->
253− case List.lookup key kvs of
344+ case findField key kvs of
254− Just v ->
345+ Just value ->
255 let
346 let
347+ err' prob =
256− err' e = err (E.Field key e)
348+ err (Field key prob)
257 in
349 in
258− decodeA v ok err'
350+ decodeA value ok err'
259
351
260 Nothing ->
352 Nothing ->
261− err (E.Expecting (E.TObjectWith key))
353+ err (Expecting region (TObjectWith key))
262
354
263 _ ->
355 _ ->
264− err (E.Expecting E.TObject)
356+ err (Expecting region TObject)
357+
358+
359+findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
360+findField key pairs =
361+ case pairs of
362+ [] ->
363+ Nothing
364+
365+ (P.Snippet fptr off len _ _, value) : remainingPairs ->
366+ if key == B.PS fptr off len
367+ then Just value
368+ else findField key remainingPairs
265
369
266
370
267
371
268-- ONE OF
372-- ONE OF
269
373
270
374
271−oneOf :: [Decoder e a] -> Decoder e a
375+oneOf :: [Decoder x a] -> Decoder x a
272oneOf decoders =
376oneOf decoders =
273 Decoder $ \ast ok err ->
377 Decoder $ \ast ok err ->
274 case decoders of
378 case decoders of
@@ -283,71 +387,75 @@ oneOf decoders =
283 error "Ran into (Json.Decode.oneOf [])"
387 error "Ran into (Json.Decode.oneOf [])"
284
388
285
389
286−oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
390+oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
287−oneOfHelp ast ok err decoders e es =
391+oneOfHelp ast ok err decoders p ps =
288 case decoders of
392 case decoders of
289 Decoder decodeA : decoders ->
393 Decoder decodeA : decoders ->
290 let
394 let
291− err' e' =
395+ err' p' =
292− oneOfHelp ast ok err decoders e' (e:es)
396+ oneOfHelp ast ok err decoders p' (p:ps)
293 in
397 in
294 decodeA ast ok err'
398 decodeA ast ok err'
295
399
296 [] ->
400 [] ->
297− err (oneOfError [] e es)
401+ err (oneOfError [] p ps)
298
402
299
403
300−oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
404+oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
301−oneOfError errors err es =
405+oneOfError problems prob ps =
302− case es of
406+ case ps of
303 [] ->
407 [] ->
304− E.OneOf err errors
408+ OneOf prob problems
305
409
306− e:es ->
410+ p:ps ->
307− oneOfError (err:errors) e es
411+ oneOfError (prob:problems) p ps
308
412
309
413
310
414
311-- FAILURE
415-- FAILURE
312
416
313
417
314−failure :: e -> Decoder e a
418+failure :: x -> Decoder x a
315−failure e =
419+failure x =
316− Decoder $ \_ _ err ->
420+ Decoder $ \(A.At region _) _ err ->
317− err (E.Failure e)
421+ err (Failure region x)
318
422
319
423
320
424
321-- ERRORS
425-- ERRORS
322
426
323
427
324−mapError :: (e -> e') -> Decoder e a -> Decoder e' a
428+mapError :: (x -> y) -> Decoder x a -> Decoder y a
325mapError func (Decoder decodeA) =
429mapError func (Decoder decodeA) =
326 Decoder $ \ast ok err ->
430 Decoder $ \ast ok err ->
327 let
431 let
328− err' e = err (mapErrorHelp func e)
432+ err' prob = err (mapErrorHelp func prob)
329 in
433 in
330 decodeA ast ok err'
434 decodeA ast ok err'
331
435
332
436
333−mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
437+mapErrorHelp :: (x -> y) -> Problem x -> Problem y
334−mapErrorHelp func err =
438+mapErrorHelp func problem =
335− case err of
439+ case problem of
336− E.Field k e -> E.Field k (mapErrorHelp func e)
440+ Field k p -> Field k (mapErrorHelp func p)
337− E.Index i e -> E.Index i (mapErrorHelp func e)
441+ Index i p -> Index i (mapErrorHelp func p)
338− E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
442+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
339− E.Failure e -> E.Failure (func e)
443+ Failure r x -> Failure r (func x)
340− E.Expecting e -> E.Expecting e
444+ Expecting r e -> Expecting r e
341
445
342
446
343
447
344-- AST
448-- AST
345
449
346
450
347−data AST
451+type AST =
452+ A.Located AST_
453+
454+
455+data AST_
348 = Array [AST]
456 = Array [AST]
349− | Object [(Utf8.String, AST)]
457+ | Object [(P.Snippet, AST)]
350− | String Utf8.String
458+ | String P.Snippet
351 | Int Int
459 | Int Int
352 | TRUE
460 | TRUE
353 | FALSE
461 | FALSE
@@ -359,7 +467,33 @@ data AST
359
467
360
468
361type Parser a =
469type Parser a =
362− P.Parser E.ParseError a
470+ P.Parser ParseError a
471+
472+
473+data ParseError
474+ = Start Row Col
475+ | ObjectField Row Col
476+ | ObjectColon Row Col
477+ | ObjectEnd Row Col
478+ | ArrayEnd Row Col
479+ | StringProblem StringProblem Row Col
480+ | NoLeadingZeros Row Col
481+ | NoFloats Row Col
482+ | BadEnd Row Col
483+
484+-- PIndex Int ParseError Row Col
485+-- PField Json.String ParseError Row Col
486+
487+
488+data StringProblem
489+ = BadStringEnd
490+ | BadStringControlChar
491+ | BadStringEscapeChar
492+ | BadStringEscapeHex
493+
494+
495+
496+-- PARSE AST
363
497
364
498
365pFile :: Parser AST
499pFile :: Parser AST
@@ -367,69 +501,60 @@ pFile =
367 do spaces
501 do spaces
368 value <- pValue
502 value <- pValue
369 spaces
503 spaces
370− endOfFile
371 return value
504 return value
372
505
373
506
374pValue :: Parser AST
507pValue :: Parser AST
375pValue =
508pValue =
509+ P.addLocation $
376− P.oneOf E.Value
510+ P.oneOf Start
377− [ fmap String pString
511+ [ String <$> pString Start
378 , pObject
512 , pObject
379 , pArray
513 , pArray
380 , pInt
514 , pInt
381− , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
515+ , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
382− , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
516+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
383− , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
517+ , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
384 ]
518 ]
385
519
386
520
387−endOfFile :: Parser ()
388−endOfFile =
389− P.Parser $ \state@(P.State pos end _ row col) _ eok _ eerr ->
390− if pos < end then
391− eerr row col E.EndOfFile
392− else
393− eok () state
394−
395−
396
521
397-- OBJECT
522-- OBJECT
398
523
399
524
400−pObject :: Parser AST
525+pObject :: Parser AST_
401pObject =
526pObject =
402− do P.word1 0x7B {- { -} E.ObjectStart
527+ do P.word1 0x7B {- { -} Start
403 spaces
528 spaces
404− P.oneOf E.ObjectMore
529+ P.oneOf ObjectField
405 [ do entry <- pField
530 [ do entry <- pField
406 spaces
531 spaces
407 pObjectHelp [entry]
532 pObjectHelp [entry]
408− , do P.word1 0x7D {-}-} E.ObjectEnd
533+ , do P.word1 0x7D {-}-} ObjectEnd
409 return (Object [])
534 return (Object [])
410 ]
535 ]
411
536
412
537
413−pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
538+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
414pObjectHelp revEntries =
539pObjectHelp revEntries =
415− P.oneOf E.ObjectMore
540+ P.oneOf ObjectEnd
416 [
541 [
417− do P.word1 0x2C {-,-} E.ObjectMore
542+ do P.word1 0x2C {-,-} ObjectEnd
418 spaces
543 spaces
419 entry <- pField
544 entry <- pField
420 spaces
545 spaces
421 pObjectHelp (entry:revEntries)
546 pObjectHelp (entry:revEntries)
422 ,
547 ,
423− do P.word1 0x7D {-}-} E.ObjectEnd
548+ do P.word1 0x7D {-}-} ObjectEnd
424 return (Object (reverse revEntries))
549 return (Object (reverse revEntries))
425 ]
550 ]
426
551
427
552
428−pField :: Parser (Utf8.String, AST)
553+pField :: Parser (P.Snippet, AST)
429pField =
554pField =
430− do key <- pString
555+ do key <- pString ObjectField
431 spaces
556 spaces
432− P.word1 0x3A {-:-} E.Colon
557+ P.word1 0x3A {-:-} ObjectColon
433 spaces
558 spaces
434 value <- pValue
559 value <- pValue
435 return (key, value)
560 return (key, value)
@@ -439,30 +564,30 @@ pField =
439-- ARRAY
564-- ARRAY
440
565
441
566
442−pArray :: Parser AST
567+pArray :: Parser AST_
443pArray =
568pArray =
444− do P.word1 0x5B {-[-} E.ArrayStart
569+ do P.word1 0x5B {-[-} Start
445 spaces
570 spaces
446− P.oneOf E.ArrayMore
571+ P.oneOf Start
447 [ do entry <- pValue
572 [ do entry <- pValue
448 spaces
573 spaces
449 pArrayHelp 1 [entry]
574 pArrayHelp 1 [entry]
450− , do P.word1 0x5D {-]-} E.ArrayEnd
575+ , do P.word1 0x5D {-]-} ArrayEnd
451 return (Array [])
576 return (Array [])
452 ]
577 ]
453
578
454
579
455−pArrayHelp :: Int -> [AST] -> Parser AST
580+pArrayHelp :: Int -> [AST] -> Parser AST_
456pArrayHelp !len revEntries =
581pArrayHelp !len revEntries =
457− P.oneOf E.ArrayMore
582+ P.oneOf ArrayEnd
458 [
583 [
459− do P.word1 0x2C {-,-} E.ArrayMore
584+ do P.word1 0x2C {-,-} ArrayEnd
460 spaces
585 spaces
461 entry <- pValue
586 entry <- pValue
462 spaces
587 spaces
463 pArrayHelp (len + 1) (entry:revEntries)
588 pArrayHelp (len + 1) (entry:revEntries)
464 ,
589 ,
465− do P.word1 0x5D {-]-} E.ArrayEnd
590+ do P.word1 0x5D {-]-} ArrayEnd
466 return (Array (reverse revEntries))
591 return (Array (reverse revEntries))
467 ]
592 ]
468
593
@@ -471,41 +596,44 @@ pArrayHelp !len revEntries =
471-- STRING
596-- STRING
472
597
473
598
474−pString :: Parser Utf8.String
599+pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
475−pString =
600+pString start =
476− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
601+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
477 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
478
603
479 let
604 let
480 !pos1 = plusPtr pos 1
605 !pos1 = plusPtr pos 1
606+ !col1 = col + 1
481
607
482 (# status, newPos, newRow, newCol #) =
608 (# status, newPos, newRow, newCol #) =
483− pStringHelp pos1 end row (col + 1)
609+ pStringHelp pos1 end row col1
484 in
610 in
485 case status of
611 case status of
486 GoodString ->
612 GoodString ->
487 let
613 let
614+ !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
615+ !len = minusPtr newPos pos1 - 1
616+ !snp = P.Snippet src off len row col1
488− !newState = P.State newPos end indent newRow newCol
617+ !newState = P.State src newPos end indent newRow newCol
489− !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
490 in
618 in
491− cok content newState
619+ cok snp newState
492
620
493− BadStringEnd ->
621+ BadString problem ->
494− cerr newRow newCol E.StringEnd
622+ cerr newRow newCol (StringProblem problem)
495
623
496 else
624 else
497− eerr row col E.StringStart
625+ eerr row col start
498
626
499
627
500data StringStatus
628data StringStatus
501 = GoodString
629 = GoodString
502− | BadStringEnd
630+ | BadString StringProblem
503
631
504
632
505−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
633+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
506pStringHelp pos end row col =
634pStringHelp pos end row col =
507 if pos >= end then
635 if pos >= end then
508− (# BadStringEnd, pos, row, col #)
636+ (# BadString BadStringEnd, pos, row, col #)
509
637
510 else
638 else
511 case P.unsafeIndex pos of
639 case P.unsafeIndex pos of
@@ -513,26 +641,50 @@ pStringHelp pos end row col =
513 (# GoodString, plusPtr pos 1, row, col + 1 #)
641 (# GoodString, plusPtr pos 1, row, col + 1 #)
514
642
515 0x0A {-\n-} ->
643 0x0A {-\n-} ->
516− (# BadStringEnd, pos, row, col #)
644+ (# BadString BadStringEnd, pos, row, col #)
517
645
518 0x5C {-\-} ->
646 0x5C {-\-} ->
519− let
520− !pos1 = plusPtr pos 1
647+ let !pos1 = plusPtr pos 1 in
521− in
522− if pos1 < end then
648+ if pos1 >= end then
523−
649+ (# BadString BadStringEnd, pos1, row + 1, col #)
524− let
525− !word = P.unsafeIndex pos1
526− !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
527− in
528− pStringHelp newPos end row (col + 2)
529−
530 else
650 else
531− (# BadStringEnd, pos1, row + 1, col #)
651+ case P.unsafeIndex pos1 of
652+ 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
653+ 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
654+ 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
655+ 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
656+ 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
657+ 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
658+ 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
659+ 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
660+ 0x75 {-u-} ->
661+ let !pos6 = plusPtr pos 6 in
662+ if pos6 <= end
663+ && isHex (P.unsafeIndex (plusPtr pos 2))
664+ && isHex (P.unsafeIndex (plusPtr pos 3))
665+ && isHex (P.unsafeIndex (plusPtr pos 4))
666+ && isHex (P.unsafeIndex (plusPtr pos 5))
667+ then
668+ pStringHelp pos6 end row (col + 6)
669+ else
670+ (# BadString BadStringEscapeHex, pos, row, col #)
671+
672+ _ ->
673+ (# BadString BadStringEscapeChar, pos, row, col #)
532
674
533 word ->
675 word ->
676+ if word < 0x20 then
677+ (# BadString BadStringControlChar, pos, row, col #)
678+ else
534− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
679+ let !newPos = plusPtr pos (P.getCharWidth word) in
535− pStringHelp newPos end row (col + 1)
680+ pStringHelp newPos end row (col + 1)
681+
682+
683+isHex :: Word8 -> Bool
684+isHex word =
685+ 0x30 {-0-} <= word && word <= 0x39 {-9-}
686+ || 0x61 {-a-} <= word && word <= 0x66 {-f-}
687+ || 0x41 {-A-} <= word && word <= 0x46 {-F-}
536
688
537
689
538
690
@@ -541,7 +693,7 @@ pStringHelp pos end row col =
541
693
542spaces :: Parser ()
694spaces :: Parser ()
543spaces =
695spaces =
544− P.Parser $ \state@(P.State pos end indent row col) cok eok _ _ ->
696+ P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
545 let
697 let
546 (# newPos, newRow, newCol #) =
698 (# newPos, newRow, newCol #) =
547 eatSpaces pos end row col
699 eatSpaces pos end row col
@@ -551,12 +703,12 @@ spaces =
551 else
703 else
552 let
704 let
553 !newState =
705 !newState =
554− P.State newPos end indent newRow newCol
706+ P.State src newPos end indent newRow newCol
555 in
707 in
556 cok () newState
708 cok () newState
557
709
558
710
559−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
711+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
560eatSpaces pos end row col =
712eatSpaces pos end row col =
561 if pos >= end then
713 if pos >= end then
562 (# pos, row, col #)
714 (# pos, row, col #)
@@ -575,29 +727,29 @@ eatSpaces pos end row col =
575-- INTS
727-- INTS
576
728
577
729
578−pInt :: Parser AST
730+pInt :: Parser AST_
579pInt =
731pInt =
580− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
732+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
581 if pos >= end then
733 if pos >= end then
582− eerr row col E.IntStart
734+ eerr row col Start
583
735
584 else
736 else
585 let !word = P.unsafeIndex pos in
737 let !word = P.unsafeIndex pos in
586 if not (isDecimalDigit word) then
738 if not (isDecimalDigit word) then
587− eerr row col E.IntStart
739+ eerr row col Start
588
740
589 else if word == 0x30 {-0-} then
741 else if word == 0x30 {-0-} then
590
742
591 let
743 let
592 !pos1 = plusPtr pos 1
744 !pos1 = plusPtr pos 1
593− !newState = P.State pos1 end indent row (col + 1)
745+ !newState = P.State src pos1 end indent row (col + 1)
594 in
746 in
595 if pos1 < end then
747 if pos1 < end then
596 let !word1 = P.unsafeIndex pos1 in
748 let !word1 = P.unsafeIndex pos1 in
597 if isDecimalDigit word1 then
749 if isDecimalDigit word1 then
598− cerr row (col + 1) E.NoLeadingZeros
750+ cerr row (col + 1) NoLeadingZeros
599 else if word1 == 0x2E {-.-} then
751 else if word1 == 0x2E {-.-} then
600− cerr row (col + 1) E.NoFloats
752+ cerr row (col + 1) NoFloats
601 else
753 else
602 cok (Int 0) newState
754 cok (Int 0) newState
603 else
755 else
@@ -614,12 +766,12 @@ pInt =
614 GoodInt ->
766 GoodInt ->
615 let
767 let
616 !newState =
768 !newState =
617− P.State newPos end indent row (col + len)
769+ P.State src newPos end indent row (col + len)
618 in
770 in
619 cok (Int n) newState
771 cok (Int n) newState
620
772
621 BadIntEnd ->
773 BadIntEnd ->
622− cerr row (col + len) E.NoFloats
774+ cerr row (col + len) NoFloats
623
775
624
776
625data IntStatus = GoodInt | BadIntEnd
777data IntStatus = GoodInt | BadIntEnd
compiler/src/Json/Encode.hs+37−21
@@ -10,6 +10,7 @@ module Json.Encode
10 , object
10 , object
11 , string
11 , string
12 , name
12 , name
13+ , chars
13 , bool
14 , bool
14 , int
15 , int
15 , number
16 , number
@@ -32,6 +33,7 @@ import qualified Data.Name as Name
32import qualified Data.Utf8 as Utf8
33import qualified Data.Utf8 as Utf8
33
34
34import qualified File
35import qualified File
36+import qualified Json.String as Json
35
37
36
38
37
39
@@ -40,7 +42,7 @@ import qualified File
40
42
41data Value
43data Value
42 = Array [Value]
44 = Array [Value]
43− | Object [(Utf8.String, Value)]
45+ | Object [(Json.String, Value)]
44 | String B.Builder
46 | String B.Builder
45 | Boolean Bool
47 | Boolean Bool
46 | Integer Int
48 | Integer Int
@@ -53,14 +55,14 @@ array =
53 Array
55 Array
54
56
55
57
56−object :: [(Utf8.String,Value)] -> Value
58+object :: [(Json.String, Value)] -> Value
57object =
59object =
58 Object
60 Object
59
61
60
62
61−string :: Utf8.String -> Value
63+string :: Json.String -> Value
62string str =
64string str =
63− String (encodeUtf8 str)
65+ String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')
64
66
65
67
66name :: Name.Name -> Value
68name :: Name.Name -> Value
@@ -88,7 +90,7 @@ null =
88 Null
90 Null
89
91
90
92
91−dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value
93+dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value
92dict encodeKey encodeValue pairs =
94dict encodeKey encodeValue pairs =
93 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
95 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
94
96
@@ -99,12 +101,35 @@ list encodeEntry entries =
99
101
100
102
101
103
104+-- CHARS
105+
106+
107+chars :: [Char] -> Value -- PERF can this be done better? Look for examples.
108+chars chrs =
109+ String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')
110+
111+
112+escape :: [Char] -> [Char]
113+escape chrs =
114+ case chrs of
115+ [] ->
116+ []
117+
118+ c:cs
119+ | c == '\r' -> '\\' : 'r' : escape cs
120+ | c == '\n' -> '\\' : 'n' : escape cs
121+ | c == '\"' -> '\\' : '"' : escape cs
122+ | c == '\\' -> '\\' : '\\' : escape cs
123+ | otherwise -> c : escape cs
124+
125+
126+
102-- HELPERS
127-- HELPERS
103
128
104
129
105−(==>) :: a -> b -> (a, b)
130+(==>) :: [Char] -> value -> (Json.String, value)
106−(==>) a b =
131+(==>) key value =
107− (a, b)
132+ (Json.fromChars key, value)
108
133
109
134
110
135
@@ -144,7 +169,7 @@ encodeUgly value =
144 Object (first : rest) ->
169 Object (first : rest) ->
145 let
170 let
146 encodeEntry char (key, entry) =
171 encodeEntry char (key, entry) =
147− B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry
172+ B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry
148 in
173 in
149 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
150
175
@@ -205,15 +230,6 @@ encodeHelp indent value =
205
230
206
231
207
232
208−-- ENCODE UTF-8
209−
210−
211−encodeUtf8 :: Utf8.String -> B.Builder
212−encodeUtf8 str =
213− B.char7 '"' <> Utf8.toBuilder str <> B.char7 '"'
214−
215−
216−
217-- ENCODE ARRAY
233-- ENCODE ARRAY
218
234
219
235
@@ -236,7 +252,7 @@ arrayClose =
236-- ENCODE OBJECT
252-- ENCODE OBJECT
237
253
238
254
239−encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder
255+encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder
240encodeObject =
256encodeObject =
241 encodeSequence objectOpen objectClose encodeField
257 encodeSequence objectOpen objectClose encodeField
242
258
@@ -251,9 +267,9 @@ objectClose =
251 B.char7 '}'
267 B.char7 '}'
252
268
253
269
254−encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder
270+encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder
255encodeField indent (key, value) =
271encodeField indent (key, value) =
256− encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value
272+ B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value
257
273
258
274
259
275
compiler/src/Json/String.hsnew file+192
@@ -0,0 +1,192 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
3+module Json.String
4+ ( String
5+ , isEmpty
6+ --
7+ , fromPtr
8+ , fromName
9+ , fromChars
10+ , fromSnippet
11+ , fromComment
12+ --
13+ , toChars
14+ , toBuilder
15+ )
16+ where
17+
18+
19+import Prelude hiding (String)
20+import qualified Data.ByteString.Builder as B
21+import qualified Data.Coerce as Coerce
22+import qualified Data.Name as Name
23+import qualified Data.Utf8 as Utf8
24+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
25+import Data.Word (Word8)
26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
27+import Foreign.ForeignPtr (withForeignPtr)
28+import GHC.Exts (RealWorld)
29+import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)
30+import GHC.ST (ST)
31+
32+import qualified Parse.Primitives as P
33+
34+
35+
36+-- JSON STRINGS
37+
38+
39+-- INVARIANT: any Json.String is appropriately escaped already
40+-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
41+--
42+type String =
43+ Utf8.Utf8 JSON_STRING
44+
45+
46+data JSON_STRING
47+
48+
49+isEmpty :: String -> Bool
50+isEmpty =
51+ Utf8.isEmpty
52+
53+
54+
55+-- FROM
56+
57+
58+fromPtr :: Ptr Word8 -> Ptr Word8 -> String
59+fromPtr =
60+ Utf8.fromPtr
61+
62+
63+fromChars :: [Char] -> String
64+fromChars =
65+ Utf8.fromChars
66+
67+
68+fromSnippet :: P.Snippet -> String
69+fromSnippet =
70+ Utf8.fromSnippet
71+
72+
73+fromName :: Name.Name -> String
74+fromName =
75+ Coerce.coerce
76+
77+
78+
79+-- TO
80+
81+
82+toChars :: String -> [Char]
83+toChars =
84+ Utf8.toChars
85+
86+
87+{-# INLINE toBuilder #-}
88+toBuilder :: String -> B.Builder
89+toBuilder =
90+ Utf8.toBuilder
91+
92+
93+
94+-- FROM COMMENT
95+
96+
97+fromComment :: P.Snippet -> String
98+fromComment (P.Snippet fptr off len _ _) =
99+ unsafePerformIO $ withForeignPtr fptr $ \ptr ->
100+ let
101+ !pos = plusPtr ptr off
102+ !end = plusPtr pos len
103+ !str = fromChunks (chompChunks pos end pos [])
104+ in
105+ return str
106+
107+
108+chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
109+chompChunks pos end start revChunks =
110+ if pos >= end then
111+ reverse (addSlice start end revChunks)
112+ else
113+ let
114+ !word = P.unsafeIndex pos
115+ in
116+ case word of
117+ 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
118+ 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
119+ 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
120+ 0x0D {-\r-} ->
121+ let
122+ !newPos = plusPtr pos 1
123+ in
124+ chompChunks newPos end newPos (addSlice start pos revChunks)
125+
126+ _ ->
127+ let
128+ !width = P.getCharWidth word
129+ !newPos = plusPtr pos width
130+ in
131+ chompChunks newPos end start revChunks
132+
133+
134+chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
135+chompEscape escape pos end start revChunks =
136+ let
137+ !pos1 = plusPtr pos 1
138+ in
139+ chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)
140+
141+
142+addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
143+addSlice start end revChunks =
144+ if start == end
145+ then revChunks
146+ else Slice start (minusPtr end start) : revChunks
147+
148+
149+
150+-- FROM CHUNKS
151+
152+
153+data Chunk
154+ = Slice (Ptr Word8) Int
155+ | Escape Word8
156+
157+
158+fromChunks :: [Chunk] -> String
159+fromChunks chunks =
160+ unsafeDupablePerformIO (stToIO (
161+ do let !len = sum (map chunkToWidth chunks)
162+ mba <- newByteArray len
163+ writeChunks mba 0 chunks
164+ freeze mba
165+ ))
166+
167+
168+chunkToWidth :: Chunk -> Int
169+chunkToWidth chunk =
170+ case chunk of
171+ Slice _ len -> len
172+ Escape _ -> 2
173+
174+
175+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
176+writeChunks mba offset chunks =
177+ case chunks of
178+ [] ->
179+ return ()
180+
181+ chunk : chunks ->
182+ case chunk of
183+ Slice ptr len ->
184+ do copyFromPtr ptr mba offset len
185+ let !newOffset = offset + len
186+ writeChunks mba newOffset chunks
187+
188+ Escape word ->
189+ do writeWord8 mba offset 0x5C {- \ -}
190+ writeWord8 mba (offset + 1) word
191+ let !newOffset = offset + 2
192+ writeChunks mba newOffset chunks
compiler/src/Nitpick/PatternMatches.hs+4−4
@@ -22,11 +22,11 @@ import qualified Data.Map as Map
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
@@ -204,7 +204,7 @@ data Context
204
204
205
205
206check :: Can.Module -> Either (NE.List Error) ()
206check :: Can.Module -> Either (NE.List Error) ()
207−check (Can.Module _ _ decls _ _ _ _) =
207+check (Can.Module _ _ _ decls _ _ _ _) =
208 case checkDecls decls [] of
208 case checkDecls decls [] of
209 [] ->
209 [] ->
210 Right ()
210 Right ()
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+4−4
@@ -41,7 +41,7 @@ type Annotations =
41
41
42
42
43optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
43optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
44−optimize annotations (Can.Module home _ decls unions aliases _ effects) =
44+optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =
45 addDecls home annotations decls $
45 addDecls home annotations decls $
46 addEffects home effects $
46 addEffects home effects $
47 addUnions home unions $
47 addUnions home unions $
@@ -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/Declaration.hs+18−19
@@ -20,7 +20,6 @@ import qualified Parse.Space as Space
20import qualified Parse.Symbol as Symbol
20import qualified Parse.Symbol as Symbol
21import qualified Parse.Type as Type
21import qualified Parse.Type as Type
22import qualified Parse.Variable as Var
22import qualified Parse.Variable as Var
23−import Parse.Space (DocComment)
24import Parse.Primitives hiding (State)
23import Parse.Primitives hiding (State)
25import qualified Parse.Primitives as P
24import qualified Parse.Primitives as P
26import qualified Reporting.Annotation as A
25import qualified Reporting.Annotation as A
@@ -32,10 +31,10 @@ import qualified Reporting.Error.Syntax as E
32
31
33
32
34data Decl
33data Decl
35− = Value (Maybe DocComment) (A.Located Src.Value)
34+ = Value (Maybe Src.Comment) (A.Located Src.Value)
36− | Union (Maybe DocComment) (A.Located Src.Union)
35+ | Union (Maybe Src.Comment) (A.Located Src.Union)
37− | Alias (Maybe DocComment) (A.Located Src.Alias)
36+ | Alias (Maybe Src.Comment) (A.Located Src.Alias)
38− | Port (Maybe DocComment) Src.Port
37+ | Port (Maybe Src.Comment) Src.Port
39
38
40
39
41declaration :: Space.Parser E.Decl Decl
40declaration :: Space.Parser E.Decl Decl
@@ -53,7 +52,7 @@ declaration =
53-- DOC COMMENT
52-- DOC COMMENT
54
53
55
54
56−chompDocComment :: Parser E.Decl (Maybe DocComment)
55+chompDocComment :: Parser E.Decl (Maybe Src.Comment)
57chompDocComment =
56chompDocComment =
58 oneOfWithFallback
57 oneOfWithFallback
59 [
58 [
@@ -70,7 +69,7 @@ chompDocComment =
70
69
71
70
72{-# INLINE valueDecl #-}
71{-# INLINE valueDecl #-}
73−valueDecl :: Maybe DocComment -> A.Position -> Space.Parser E.Decl Decl
72+valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
74valueDecl maybeDocs start =
73valueDecl maybeDocs start =
75 do name <- Var.lower E.DeclStart
74 do name <- Var.lower E.DeclStart
76 end <- getPosition
75 end <- getPosition
@@ -81,7 +80,7 @@ valueDecl maybeDocs start =
81 do word1 0x3A {-:-} E.DeclDefEquals
80 do word1 0x3A {-:-} E.DeclDefEquals
82 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
81 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
83 (tipe, _) <- specialize E.DeclDefType Type.expression
82 (tipe, _) <- specialize E.DeclDefType Type.expression
84− Space.checkFreshLine E.DeclDefFreshLineAfterType
83+ Space.checkFreshLine E.DeclDefNameRepeat
85 defName <- chompMatchingName name
84 defName <- chompMatchingName name
86 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
85 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
87 chompDefArgsAndBody maybeDocs start defName (Just tipe) []
86 chompDefArgsAndBody maybeDocs start defName (Just tipe) []
@@ -90,7 +89,7 @@ valueDecl maybeDocs start =
90 ]
89 ]
91
90
92
91
93−chompDefArgsAndBody :: Maybe DocComment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
92+chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
94chompDefArgsAndBody maybeDocs start name tipe revArgs =
93chompDefArgsAndBody maybeDocs start name tipe revArgs =
95 oneOf E.DeclDefEquals
94 oneOf E.DeclDefEquals
96 [ do arg <- specialize E.DeclDefArg Pattern.term
95 [ do arg <- specialize E.DeclDefArg Pattern.term
@@ -108,19 +107,19 @@ chompDefArgsAndBody maybeDocs start name tipe revArgs =
108chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
107chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
109chompMatchingName expectedName =
108chompMatchingName expectedName =
110 let
109 let
111− (P.Parser parserL) = Var.lower (E.DeclDefNameRepeat expectedName)
110+ (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
112 in
111 in
113− P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
112+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
114 let
113 let
115− cokL name newState@(P.State _ _ _ er ec) =
114+ cokL name newState@(P.State _ _ _ _ er ec) =
116 if expectedName == name
115 if expectedName == name
117 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
118− else cerr sr sc (E.DeclDefNameMatch expectedName name)
117+ else cerr sr sc (E.DeclDefNameMatch name)
119
118
120− eokL name newState@(P.State _ _ _ er ec) =
119+ eokL name newState@(P.State _ _ _ _ er ec) =
121 if expectedName == name
120 if expectedName == name
122 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
123− else eerr sr sc (E.DeclDefNameMatch expectedName name)
122+ else eerr sr sc (E.DeclDefNameMatch name)
124 in
123 in
125 parserL state cokL eokL cerr eerr
124 parserL state cokL eokL cerr eerr
126
125
@@ -130,7 +129,7 @@ chompMatchingName expectedName =
130
129
131
130
132{-# INLINE typeDecl #-}
131{-# INLINE typeDecl #-}
133−typeDecl :: Maybe DocComment -> A.Position -> Space.Parser E.Decl Decl
132+typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
134typeDecl maybeDocs start =
133typeDecl maybeDocs start =
135 inContext E.DeclType (Keyword.type_ E.DeclStart) $
134 inContext E.DeclType (Keyword.type_ E.DeclStart) $
136 do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
135 do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
@@ -215,7 +214,7 @@ chompVariants variants end =
215
214
216
215
217{-# INLINE portDecl #-}
216{-# INLINE portDecl #-}
218−portDecl :: Maybe DocComment -> Space.Parser E.Decl Decl
217+portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl
219portDecl maybeDocs =
218portDecl maybeDocs =
220 inContext E.Port (Keyword.port_ E.DeclStart) $
219 inContext E.Port (Keyword.port_ E.DeclStart) $
221 do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
220 do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
@@ -236,7 +235,7 @@ portDecl maybeDocs =
236
235
237-- INVARIANT: always chomps to a freshline
236-- INVARIANT: always chomps to a freshline
238--
237--
239−infix_ :: Parser E.Module (A.Located Src.Binop)
238+infix_ :: Parser E.Module (A.Located Src.Infix)
240infix_ =
239infix_ =
241 let
240 let
242 err = E.Infix
241 err = E.Infix
@@ -264,4 +263,4 @@ infix_ =
264 end <- getPosition
263 end <- getPosition
265 Space.chomp _err
264 Space.chomp _err
266 Space.checkFreshLine err
265 Space.checkFreshLine err
267− return (A.at start end (Src.Binop op associativity precedence name))
266+ return (A.at start end (Src.Infix op associativity precedence name))
compiler/src/Parse/Docs.hsdeleted−275
@@ -1,275 +0,0 @@
1−module Parse.Docs
2− ( Docs(..)
3− , parser
4− )
5− where
6−
7−
8−
9−-- DOCS
10−
11−
12−data Docs =
13− Docs
14− { _exposed :: [A.Located Name.Name]
15− , _overview :: Utf8.String
16− , _listed :: [A.Located Name.Name]
17− , _comments :: Map.Map Name.Name Utf8.String
18− }
19−
20−
21−
22−-- PARSER
23−
24−
25−parser :: Parser Docs
26−parser =
27− error "TODO implement docs parser"
28−
29−
30−chompUntilDocs :: Parser Bool
31−chompUntilDocs =
32− P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33− let
34− (# isStart, newOffset, newRow, newCol #) =
35− eatDocs fp offset terminal row col
36−
37− !newState =
38− P.State fp newOffset terminal indent newRow newCol ctx
39− in
40− cok isStart newState
41−
42−
43−eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44−eatDocs fp offset terminal row col =
45− if offset >= terminal then
46− (# False, offset, row, col #)
47−
48− else if isDocsStart fp offset terminal then
49− (# True, offset + 5, row, col + 5 #)
50−
51− else
52− let !word = P.unsafeIndex fp offset in
53− if word == 0x0A {- \n -} then
54− eatDocs fp (offset + 1) terminal (row + 1) 1
55−
56− else
57− let !newOffset = offset + P.getCharWidth fp offset terminal word in
58− eatDocs fp newOffset terminal row (col + 1)
59−
60−
61−isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62−isDocsStart =
63− let (B.PS dfp doff dlen) = docsStart in
64− P.isSubstring dfp doff dlen
65−
66−
67−{-# NOINLINE docsStart #-}
68−docsStart :: B.ByteString
69−docsStart =
70− "@docs"
71−
72−
73−chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74−chompOverview names =
75− do isDocs <- chompUntilDocs
76− if isDocs
77− then chompOverviewHelp names
78− else return names
79−
80−
81−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82−chompOverviewHelp names =
83− do pos <- getPosition
84− (SPos spos) <- whitespace
85− if pos == spos
86− then chompOverview names
87− else chompOverview =<< chompDocs names
88−
89−
90−chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91−chompDocs names =
92− do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93− spos <- whitespace
94− oneOf SE.XXX
95− [ do checkSpace spos
96− word1 0x2C {-,-} SE.XXX
97− spaces
98− chompDocs (name:names)
99− , return (name:names)
100− ]
101−
102−
103−chompBinop :: Parser Name.Name
104−chompBinop =
105− do word1 0x28 {-(-} SE.XXX
106− name <- Symbol.binop
107− word1 0x29 {-)-} SE.XXX
108− return name
109−
110−
111−
112−
113−-- CHECK NAMES
114−
115−
116−type Result i w a =
117− Result.Result i w E.Error a
118−
119−
120−type Dups =
121− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122−
123−
124−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125−checkNames exports names =
126− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127− let overlap = Map.size (Map.intersection docs exports)
128− if Map.size exports == overlap && overlap == Map.size docs
129− then Result.ok ()
130− else
131− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133− Result.ok ()
134−
135−
136−addName :: Dups -> A.Located Name.Name -> Dups
137−addName dict (A.At region name) =
138− Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139−
140−
141−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142−isUnique name regions =
143− case regions of
144− OneOrMore.One region ->
145− Result.ok region
146−
147− OneOrMore.More _ _ ->
148− let (r1:r2:_) = OneOrMore.toList regions in
149− Result.throw (E.Duplicate name r1 r2)
150−
151−
152−onlyInDocs :: Name.Name -> A.Region -> Result i w a
153−onlyInDocs name region =
154− Result.throw $ E.OnlyInDocs name region
155−
156−
157−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158−onlyInExports name (A.At region _) =
159− Result.throw $ E.OnlyInExports name region
160−
161−
162−
163−-- CHECK EXPORTS
164−
165−
166−data Info =
167− Info
168− { _iComments :: Map.Map Name.Name Comment
169− , _iValues :: Types
170− , _iUnions :: Map.Map Name.Name Can.Union
171− , _iAliases :: Map.Map Name.Name Can.Alias
172− , _iBinops :: Map.Map Name.Name Can.Binop
173− , _iEffects :: Can.Effects
174− }
175−
176−
177−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178−checkExport info name (A.At region export) =
179− case export of
180− Can.ExportValue ->
181− do tipe <- getType name info
182− comment <- getComment region name info
183− Result.ok $ \m ->
184− m { _values = Map.insert name (Value comment tipe) (_values m) }
185−
186− Can.ExportBinop ->
187− do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188− tipe <- getType realName info
189− comment <- getComment region realName info
190− Result.ok $ \m ->
191− m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192−
193− Can.ExportAlias ->
194− do let (Can.Alias tvars tipe) = _iAliases info ! name
195− comment <- getComment region name info
196− Result.ok $ \m ->
197− m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198−
199− Can.ExportUnionOpen ->
200− do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201− comment <- getComment region name info
202− Result.ok $ \m ->
203− m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204−
205− Can.ExportUnionClosed ->
206− do let (Can.Union tvars _ _ _) = _iUnions info ! name
207− comment <- getComment region name info
208− Result.ok $ \m ->
209− m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210−
211− Can.ExportPort ->
212− do tipe <- getType name info
213− comment <- getComment region name info
214− Result.ok $ \m ->
215− m { _values = Map.insert name (Value comment tipe) (_values m) }
216−
217−
218−getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219−getComment region name info =
220− case Map.lookup name (_iComments info) of
221− Nothing ->
222− Result.throw (E.NoComment name region)
223−
224− Just comment ->
225− Result.ok comment
226−
227−
228−getType :: Name.Name -> Info -> Result i w Type.Type
229−getType name info =
230− case _iValues info ! name of
231− A.At defRegion Nothing ->
232− Result.throw (E.NoAnnotation name defRegion)
233−
234− A.At _ (Just tipe) ->
235− Result.ok (Extract.fromType tipe)
236−
237−
238−dector :: Can.Ctor -> (Name.Name, [Type.Type])
239−dector (Can.Ctor name _ _ args) =
240− ( name, map Extract.fromType args )
241−
242−
243−
244−-- GATHER TYPES
245−
246−
247−type Types =
248− Map.Map Name.Name (A.Located (Maybe Can.Type))
249−
250−
251−gatherTypes :: Can.Decls -> Types -> Types
252−gatherTypes decls types =
253− case decls of
254− Can.Declare def subDecls ->
255− gatherTypes subDecls (addDef types def)
256−
257− Can.DeclareRec defs subDecls ->
258− gatherTypes subDecls (List.foldl' addDef types defs)
259−
260− Can.SaveTheEnvironment ->
261− types
262−
263−
264−addDef :: Types -> Can.Def -> Types
265−addDef types def =
266− case def of
267− Can.Def (A.At region name) _ _ ->
268− Map.insert name (A.At region Nothing) types
269−
270− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271− let
272− tipe =
273− foldr Can.TLambda resultType (map snd typedArgs)
274− in
275− Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+57−45
@@ -16,7 +16,7 @@ import qualified Parse.Shader as Shader
16import qualified Parse.Space as Space
16import qualified Parse.Space as Space
17import qualified Parse.Symbol as Symbol
17import qualified Parse.Symbol as Symbol
18import qualified Parse.Type as Type
18import qualified Parse.Type as Type
19−import qualified Parse.Utf8 as Utf8
19+import qualified Parse.String as String
20import qualified Parse.Variable as Var
20import qualified Parse.Variable as Var
21import Parse.Primitives hiding (State)
21import Parse.Primitives hiding (State)
22import qualified Parse.Primitives as P
22import qualified Parse.Primitives as P
@@ -46,13 +46,13 @@ term =
46
46
47string :: A.Position -> Parser E.Expr Src.Expr
47string :: A.Position -> Parser E.Expr Src.Expr
48string start =
48string start =
49− do str <- Utf8.string E.Start E.String
49+ do str <- String.string E.Start E.String
50 addEnd start (Src.Str str)
50 addEnd start (Src.Str str)
51
51
52
52
53character :: A.Position -> Parser E.Expr Src.Expr
53character :: A.Position -> Parser E.Expr Src.Expr
54character start =
54character start =
55− do chr <- Utf8.character E.Start E.Char
55+ do chr <- String.character E.Start E.Char
56 addEnd start (Src.Chr chr)
56 addEnd start (Src.Chr chr)
57
57
58
58
@@ -128,42 +128,53 @@ 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− oneOf E.TupleOpen
131+ do before <- getPosition
132+ Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
133+ after <- getPosition
134+ if before /= after
135+ then
136+ do (entry, end) <- specialize E.TupleExpr expression
137+ Space.checkIndent end E.TupleIndentEnd
138+ chompTupleEnd start entry []
139+ else
140+ oneOf E.TupleIndentExpr1
132− [
141+ [
133− do op <- Symbol.operator E.TupleOpen 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+ ,
150+ do (entry, end) <-
141− specialize E.TupleExpr $
151+ specialize E.TupleExpr $
142− do negatedExpr@(A.At (A.Region _ end) _) <- term
152+ do negatedExpr@(A.At (A.Region _ end) _) <- term
143− Space.chomp E.Space
153+ Space.chomp E.Space
144− let exprStart = A.Position row (col + 2)
154+ let exprStart = A.Position row (col + 2)
145− let expr = A.at exprStart end (Src.Negate negatedExpr)
155+ let expr = A.at exprStart end (Src.Negate negatedExpr)
146− fst <$> chompExprEnd exprStart (State [] expr [] end)
156+ chompExprEnd exprStart (State [] expr [] end)
147− ]
157+ Space.checkIndent end E.TupleIndentEnd
158+ chompTupleEnd start entry []
159+ ]
148− else
160+ else
149− do word1 0x29 {-)-} E.TupleOperatorClose
161+ do word1 0x29 {-)-} E.TupleOperatorClose
150− addEnd start (Src.Op op)
162+ addEnd start (Src.Op op)
151− ,
163+ ,
152− do word1 0x29 {-)-} E.TupleOpen
164+ do word1 0x29 {-)-} E.TupleIndentExpr1
153− addEnd start Src.Unit
165+ addEnd start Src.Unit
154− ,
166+ ,
155− do Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr
156− (entry, end) <- specialize E.TupleExpr expression
167+ do (entry, end) <- specialize E.TupleExpr expression
157− Space.checkIndent end E.TupleIndentEnd
168+ Space.checkIndent end E.TupleIndentEnd
158− chompTupleEnd start entry []
169+ chompTupleEnd start entry []
159− ]
170+ ]
160
171
161
172
162chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
173chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
163chompTupleEnd start firstExpr revExprs =
174chompTupleEnd start firstExpr revExprs =
164 oneOf E.TupleEnd
175 oneOf E.TupleEnd
165 [ do word1 0x2C {-,-} E.TupleEnd
176 [ do word1 0x2C {-,-} E.TupleEnd
166− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr
177+ Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN
167 (entry, end) <- specialize E.TupleExpr expression
178 (entry, end) <- specialize E.TupleExpr expression
168 Space.checkIndent end E.TupleIndentEnd
179 Space.checkIndent end E.TupleIndentEnd
169 chompTupleEnd start firstExpr (entry : revExprs)
180 chompTupleEnd start firstExpr (entry : revExprs)
@@ -213,7 +224,7 @@ chompFields :: [Field] -> Parser E.Record [Field]
213chompFields fields =
224chompFields fields =
214 oneOf E.RecordEnd
225 oneOf E.RecordEnd
215 [ do word1 0x2C {-,-} E.RecordEnd
226 [ do word1 0x2C {-,-} E.RecordEnd
216− Space.chompAndCheckIndent E.RecordSpace E.RecordField
227+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
217 f <- chompField
228 f <- chompField
218 chompFields (f : fields)
229 chompFields (f : fields)
219 , do word1 0x7D {-}-} E.RecordEnd
230 , do word1 0x7D {-}-} E.RecordEnd
@@ -264,16 +275,16 @@ chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr
264chompExprEnd start (State ops expr args end) =
275chompExprEnd start (State ops expr args end) =
265 oneOfWithFallback
276 oneOfWithFallback
266 [ -- argument
277 [ -- argument
267− do Space.checkIndent end E.IndentMoreExpr
278+ do Space.checkIndent end E.Start
268 arg <- term
279 arg <- term
269 newEnd <- getPosition
280 newEnd <- getPosition
270 Space.chomp E.Space
281 Space.chomp E.Space
271 chompExprEnd start (State ops expr (arg:args) newEnd)
282 chompExprEnd start (State ops expr (arg:args) newEnd)
272
283
273 , -- operator
284 , -- operator
274− do Space.checkIndent end E.IndentMoreExpr
285+ do Space.checkIndent end E.Start
275 op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
286 op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
276− Space.chompAndCheckIndent E.Space E.IndentOperatorRight
287+ Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
277 newStart <- getPosition
288 newStart <- getPosition
278 if "-" == opName && end /= opStart && opEnd == newStart
289 if "-" == opName && end /= opStart && opEnd == newStart
279 then
290 then
@@ -284,7 +295,8 @@ chompExprEnd start (State ops expr args end) =
284 let arg = A.at opStart newEnd (Src.Negate negatedExpr)
295 let arg = A.at opStart newEnd (Src.Negate negatedExpr)
285 chompExprEnd start (State ops expr (arg:args) newEnd)
296 chompExprEnd start (State ops expr (arg:args) newEnd)
286 else
297 else
287− oneOf E.OperatorRight
298+ let err = E.OperatorRight opName in
299+ oneOf err
288 [ -- term
300 [ -- term
289 do newExpr <- possiblyNegativeTerm newStart
301 do newExpr <- possiblyNegativeTerm newStart
290 newEnd <- getPosition
302 newEnd <- getPosition
@@ -294,7 +306,7 @@ chompExprEnd start (State ops expr args end) =
294
306
295 , -- final term
307 , -- final term
296 do (newLast, newEnd) <-
308 do (newLast, newEnd) <-
297− oneOf E.OperatorRight
309+ oneOf err
298 [ let_ newStart
310 [ let_ newStart
299 , case_ newStart
311 , case_ newStart
300 , if_ newStart
312 , if_ newStart
@@ -531,19 +543,19 @@ chompDefArgsAndBody start name tipe revArgs =
531chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
543chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
532chompMatchingName expectedName =
544chompMatchingName expectedName =
533 let
545 let
534− (P.Parser parserL) = Var.lower (E.DefNameRepeat expectedName)
546+ (P.Parser parserL) = Var.lower E.DefNameRepeat
535 in
547 in
536− P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
548+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
537 let
549 let
538− cokL name newState@(P.State _ _ _ er ec) =
550+ cokL name newState@(P.State _ _ _ _ er ec) =
539 if expectedName == name
551 if expectedName == name
540 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
552 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
541− else cerr sr sc (E.DefNameMatch expectedName name)
553+ else cerr sr sc (E.DefNameMatch name)
542
554
543− eokL name newState@(P.State _ _ _ er ec) =
555+ eokL name newState@(P.State _ _ _ _ er ec) =
544 if expectedName == name
556 if expectedName == name
545 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
557 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
546− else eerr sr sc (E.DefNameMatch expectedName name)
558+ else eerr sr sc (E.DefNameMatch name)
547 in
559 in
548 parserL state cokL eokL cerr eerr
560 parserL state cokL eokL cerr eerr
549
561
compiler/src/Parse/Keyword.hs+16−16
@@ -120,7 +120,7 @@ command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx
120
120
121subscription_ :: (Row -> Col -> x) -> Parser x ()
121subscription_ :: (Row -> Col -> x) -> Parser x ()
122subscription_ toError =
122subscription_ toError =
123− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
123+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
124 let !pos12 = plusPtr pos 12 in
124 let !pos12 = plusPtr pos 12 in
125 if pos12 <= end
125 if pos12 <= end
126 && P.unsafeIndex ( pos ) == 0x73
126 && P.unsafeIndex ( pos ) == 0x73
@@ -137,7 +137,7 @@ subscription_ toError =
137 && P.unsafeIndex (plusPtr pos 11) == 0x6E
137 && P.unsafeIndex (plusPtr pos 11) == 0x6E
138 && Var.getInnerWidth pos12 end == 0
138 && Var.getInnerWidth pos12 end == 0
139 then
139 then
140− let !s = P.State pos12 end indent row (col + 12) in cok () s
140+ let !s = P.State src pos12 end indent row (col + 12) in cok () s
141 else
141 else
142 eerr row col toError
142 eerr row col toError
143
143
@@ -148,21 +148,21 @@ subscription_ toError =
148
148
149k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
149k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
150k2 w1 w2 toError =
150k2 w1 w2 toError =
151− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
151+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
152 let !pos2 = plusPtr pos 2 in
152 let !pos2 = plusPtr pos 2 in
153 if pos2 <= end
153 if pos2 <= end
154 && P.unsafeIndex ( pos ) == w1
154 && P.unsafeIndex ( pos ) == w1
155 && P.unsafeIndex (plusPtr pos 1) == w2
155 && P.unsafeIndex (plusPtr pos 1) == w2
156 && Var.getInnerWidth pos2 end == 0
156 && Var.getInnerWidth pos2 end == 0
157 then
157 then
158− let !s = P.State pos2 end indent row (col + 2) in cok () s
158+ let !s = P.State src pos2 end indent row (col + 2) in cok () s
159 else
159 else
160 eerr row col toError
160 eerr row col toError
161
161
162
162
163k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
163k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
164k3 w1 w2 w3 toError =
164k3 w1 w2 w3 toError =
165− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
165+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
166 let !pos3 = plusPtr pos 3 in
166 let !pos3 = plusPtr pos 3 in
167 if pos3 <= end
167 if pos3 <= end
168 && P.unsafeIndex ( pos ) == w1
168 && P.unsafeIndex ( pos ) == w1
@@ -170,14 +170,14 @@ k3 w1 w2 w3 toError =
170 && P.unsafeIndex (plusPtr pos 2) == w3
170 && P.unsafeIndex (plusPtr pos 2) == w3
171 && Var.getInnerWidth pos3 end == 0
171 && Var.getInnerWidth pos3 end == 0
172 then
172 then
173− let !s = P.State pos3 end indent row (col + 3) in cok () s
173+ let !s = P.State src pos3 end indent row (col + 3) in cok () s
174 else
174 else
175 eerr row col toError
175 eerr row col toError
176
176
177
177
178k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
178k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
179k4 w1 w2 w3 w4 toError =
179k4 w1 w2 w3 w4 toError =
180− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
180+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
181 let !pos4 = plusPtr pos 4 in
181 let !pos4 = plusPtr pos 4 in
182 if pos4 <= end
182 if pos4 <= end
183 && P.unsafeIndex ( pos ) == w1
183 && P.unsafeIndex ( pos ) == w1
@@ -186,14 +186,14 @@ k4 w1 w2 w3 w4 toError =
186 && P.unsafeIndex (plusPtr pos 3) == w4
186 && P.unsafeIndex (plusPtr pos 3) == w4
187 && Var.getInnerWidth pos4 end == 0
187 && Var.getInnerWidth pos4 end == 0
188 then
188 then
189− let !s = P.State pos4 end indent row (col + 4) in cok () s
189+ let !s = P.State src pos4 end indent row (col + 4) in cok () s
190 else
190 else
191 eerr row col toError
191 eerr row col toError
192
192
193
193
194k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
194k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
195k5 w1 w2 w3 w4 w5 toError =
195k5 w1 w2 w3 w4 w5 toError =
196− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
196+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
197 let !pos5 = plusPtr pos 5 in
197 let !pos5 = plusPtr pos 5 in
198 if pos5 <= end
198 if pos5 <= end
199 && P.unsafeIndex ( pos ) == w1
199 && P.unsafeIndex ( pos ) == w1
@@ -203,14 +203,14 @@ k5 w1 w2 w3 w4 w5 toError =
203 && P.unsafeIndex (plusPtr pos 4) == w5
203 && P.unsafeIndex (plusPtr pos 4) == w5
204 && Var.getInnerWidth pos5 end == 0
204 && Var.getInnerWidth pos5 end == 0
205 then
205 then
206− let !s = P.State pos5 end indent row (col + 5) in cok () s
206+ let !s = P.State src pos5 end indent row (col + 5) in cok () s
207 else
207 else
208 eerr row col toError
208 eerr row col toError
209
209
210
210
211k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
211k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
212k6 w1 w2 w3 w4 w5 w6 toError =
212k6 w1 w2 w3 w4 w5 w6 toError =
213− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
213+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
214 let !pos6 = plusPtr pos 6 in
214 let !pos6 = plusPtr pos 6 in
215 if pos6 <= end
215 if pos6 <= end
216 && P.unsafeIndex ( pos ) == w1
216 && P.unsafeIndex ( pos ) == w1
@@ -221,14 +221,14 @@ k6 w1 w2 w3 w4 w5 w6 toError =
221 && P.unsafeIndex (plusPtr pos 5) == w6
221 && P.unsafeIndex (plusPtr pos 5) == w6
222 && Var.getInnerWidth pos6 end == 0
222 && Var.getInnerWidth pos6 end == 0
223 then
223 then
224− let !s = P.State pos6 end indent row (col + 6) in cok () s
224+ let !s = P.State src pos6 end indent row (col + 6) in cok () s
225 else
225 else
226 eerr row col toError
226 eerr row col toError
227
227
228
228
229k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
229k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
230k7 w1 w2 w3 w4 w5 w6 w7 toError =
230k7 w1 w2 w3 w4 w5 w6 w7 toError =
231− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
231+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
232 let !pos7 = plusPtr pos 7 in
232 let !pos7 = plusPtr pos 7 in
233 if pos7 <= end
233 if pos7 <= end
234 && P.unsafeIndex ( pos ) == w1
234 && P.unsafeIndex ( pos ) == w1
@@ -240,14 +240,14 @@ k7 w1 w2 w3 w4 w5 w6 w7 toError =
240 && P.unsafeIndex (plusPtr pos 6) == w7
240 && P.unsafeIndex (plusPtr pos 6) == w7
241 && Var.getInnerWidth pos7 end == 0
241 && Var.getInnerWidth pos7 end == 0
242 then
242 then
243− let !s = P.State pos7 end indent row (col + 7) in cok () s
243+ let !s = P.State src pos7 end indent row (col + 7) in cok () s
244 else
244 else
245 eerr row col toError
245 eerr row col toError
246
246
247
247
248k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
248k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
249k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
249k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
250− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
250+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
251 let !pos8 = plusPtr pos 8 in
251 let !pos8 = plusPtr pos 8 in
252 if pos8 <= end
252 if pos8 <= end
253 && P.unsafeIndex ( pos ) == w1
253 && P.unsafeIndex ( pos ) == w1
@@ -260,6 +260,6 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
260 && P.unsafeIndex (plusPtr pos 7) == w8
260 && P.unsafeIndex (plusPtr pos 7) == w8
261 && Var.getInnerWidth pos8 end == 0
261 && Var.getInnerWidth pos8 end == 0
262 then
262 then
263− let !s = P.State pos8 end indent row (col + 8) in cok () s
263+ let !s = P.State src pos8 end indent row (col + 8) in cok () s
264 else
264 else
265 eerr row col toError
265 eerr row col toError
compiler/src/Parse/Module.hs+240−189
@@ -2,9 +2,10 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Module
3module Parse.Module
4 ( fromByteString
4 ( fromByteString
5− , Header(..)
5+ , ProjectType(..)
6− , Effects(..)
6+ , isKernel
7 , chompImports
7 , chompImports
8+ , chompImport
8 )
9 )
9 where
10 where
10
11
@@ -30,102 +31,111 @@ import qualified Reporting.Error.Syntax as E
30-- FROM BYTE STRING
31-- FROM BYTE STRING
31
32
32
33
33−fromByteString :: Pkg.Name -> BS.ByteString -> Either E.Error Src.Module
34+fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module
34−fromByteString pkg source =
35+fromByteString projectType source =
35− let
36− parser
37− | pkg == Pkg.core = core
38− | Pkg.isKernel pkg = platform
39− | otherwise = normal
40− in
41− case P.fromByteString parser source of
36+ case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of
42− P.Ok outcome _ ->
43− case outcome of
44− Right modul -> Right modul
37+ Right modul -> checkModule projectType modul
45− Left err -> Left err
38+ Left err -> Left (E.ParseError err)
46
39
47− P.Err err ->
48− Left (E.ParseError err)
49
40
50
41
42+-- PROJECT TYPE
51
43
52−-- MODULE
53
44
45+data ProjectType
46+ = Package Pkg.Name
47+ | Application
54
48
55−normal :: Parser E.Module (Either E.Error Src.Module)
56−normal =
57− do freshLine E.FreshLineModuleStart
58− header <- chompHeader
59− comment <- chompModuleDocComment
60− imports <- chompImports []
61− decls <- specialize E.Declarations $ chompDecls []
62− endOfFile
63− return (checkModule header comment (Imports.addDefaults imports) [] decls)
64
49
50+isCore :: ProjectType -> Bool
51+isCore projectType =
52+ case projectType of
53+ Package pkg -> pkg == Pkg.core
54+ Application -> False
65
55
66−core :: Parser E.Module (Either E.Error Src.Module)
56+
67−core =
57+isKernel :: ProjectType -> Bool
68− do freshLine E.FreshLineModuleStart
58+isKernel projectType =
69− header <- chompHeader
59+ case projectType of
70− comment <- chompModuleDocComment
60+ Package pkg -> Pkg.isKernel pkg
71− imports <- chompImports []
61+ Application -> False
72− binops <- chompBinops []
73− decls <- specialize E.Declarations $ chompDecls []
74− endOfFile
75− return (checkModule header comment imports binops decls)
76
62
77
63
64+
65+-- MODULE
66+
67+
68+data Module =
69+ Module
70+ { _header :: Maybe Header
71+ , _imports :: [Src.Import]
72+ , _infixes :: [A.Located Src.Infix]
73+ , _decls :: [Decl.Decl]
74+ }
75+
76+
78−platform :: Parser E.Module (Either E.Error Src.Module)
77+chompModule :: ProjectType -> Parser E.Module Module
79−platform =
78+chompModule projectType =
80− do freshLine E.FreshLineModuleStart
81− header <- chompHeader
79+ do header <- chompHeader
82− comment <- chompModuleDocComment
83− imports <- chompImports []
80+ imports <- chompImports (if isCore projectType then [] else Imports.defaults)
84− binops <- chompBinops []
81+ infixes <- if isKernel projectType then chompInfixes [] else return []
85 decls <- specialize E.Declarations $ chompDecls []
82 decls <- specialize E.Declarations $ chompDecls []
86− endOfFile
87− return (checkModule header comment (Imports.addDefaults imports) binops decls)
83+ return (Module header imports infixes decls)
88
84
89
85
90
86
91-- CHECK MODULE
87-- CHECK MODULE
92
88
93
89
94−checkModule :: Maybe Header -> Maybe Space.DocComment -> [Src.Import] -> [A.Located Src.Binop] -> [Decl.Decl] -> Either E.Error Src.Module
90+checkModule :: ProjectType -> Module -> Either E.Error Src.Module
95−checkModule maybeHeader _maybeDocs imports binops decls =
91+checkModule projectType (Module maybeHeader imports infixes decls) =
96 let
92 let
97 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
93 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
98 in
94 in
99 case maybeHeader of
95 case maybeHeader of
100− Just (Header name effects exports) ->
96+ Just (Header name effects exports docs) ->
101− Src.Module (Just name) exports imports values unions aliases binops
97+ Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
102− <$> checkEffects ports effects
98+ <$> checkEffects projectType ports effects
103
99
104 Nothing ->
100 Nothing ->
105 Right $
101 Right $
106− Src.Module Nothing (A.At A.one Src.Open) imports values unions aliases binops $
102+ Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $
107 case ports of
103 case ports of
108 [] -> Src.NoEffects
104 [] -> Src.NoEffects
109 _:_ -> Src.Ports ports
105 _:_ -> Src.Ports ports
110
106
111
107
112−checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects
108+checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
113−checkEffects ports effects =
109+checkEffects projectType ports effects =
114 case effects of
110 case effects of
115 NoEffects region ->
111 NoEffects region ->
116 case ports of
112 case ports of
113+ [] ->
117− [] -> Right Src.NoEffects
114+ Right Src.NoEffects
115+
116+ Src.Port name _ : _ ->
117+ case projectType of
118+ Package _ -> Left (E.NoPortsInPackage name)
118− _:_ -> Left (E.UnexpectedPort region)
119+ Application -> Left (E.UnexpectedPort region)
119
120
120 Ports region ->
121 Ports region ->
121− case ports of
122+ case projectType of
123+ Package _ ->
124+ Left (E.NoPortModulesInPackage region)
125+
126+ Application ->
127+ case ports of
122− [] -> Left (E.NoPorts region)
128+ [] -> Left (E.NoPorts region)
123− _:_ -> Right (Src.Ports ports)
129+ _:_ -> Right (Src.Ports ports)
124
130
125 Manager region manager ->
131 Manager region manager ->
132+ if isKernel projectType then
126− case ports of
133+ case ports of
127− [] -> Right (Src.Manager region manager)
134+ [] -> Right (Src.Manager region manager)
128− _:_ -> Left (E.UnexpectedPort region)
135+ _:_ -> Left (E.UnexpectedPort region)
136+ else
137+ Left (E.NoEffectsOutsideKernel region)
138+
129
139
130
140
131categorizeDecls :: [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] )
@@ -143,6 +153,41 @@ categorizeDecls values unions aliases ports decls =
143
153
144
154
145
155
156+-- TO DOCS
157+
158+
159+toDocs :: Either A.Region Src.Comment -> [Decl.Decl] -> Src.Docs
160+toDocs comment decls =
161+ case comment of
162+ Right overview ->
163+ Src.YesDocs overview (getComments decls [])
164+
165+ Left region ->
166+ Src.NoDocs region
167+
168+
169+getComments :: [Decl.Decl] -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]
170+getComments decls comments =
171+ case decls of
172+ [] ->
173+ comments
174+
175+ decl:otherDecls ->
176+ case decl of
177+ Decl.Value c (A.At _ (Src.Value n _ _ _)) -> getComments otherDecls (addComment c n comments)
178+ Decl.Union c (A.At _ (Src.Union n _ _ )) -> getComments otherDecls (addComment c n comments)
179+ Decl.Alias c (A.At _ (Src.Alias n _ _ )) -> getComments otherDecls (addComment c n comments)
180+ Decl.Port c (Src.Port n _ ) -> getComments otherDecls (addComment c n comments)
181+
182+
183+addComment :: Maybe Src.Comment -> A.Located Name.Name -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]
184+addComment maybeComment (A.At _ name) comments =
185+ case maybeComment of
186+ Just comment -> (name, comment) : comments
187+ Nothing -> comments
188+
189+
190+
146-- FRESH LINES
191-- FRESH LINES
147
192
148
193
@@ -152,15 +197,6 @@ freshLine toFreshLineError =
152 Space.checkFreshLine toFreshLineError
197 Space.checkFreshLine toFreshLineError
153
198
154
199
155−endOfFile :: Parser E.Module ()
156−endOfFile =
157− P.Parser $ \state@(P.State pos end _ row col) _ eok _ eerr ->
158− if pos < end then
159− eerr row col E.ModuleEndOfFile
160− else
161− eok () state
162−
163−
164
200
165-- CHOMP DECLARATIONS
201-- CHOMP DECLARATIONS
166
202
@@ -169,35 +205,36 @@ chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]
169chompDecls decls =
205chompDecls decls =
170 do (decl, _) <- Decl.declaration
206 do (decl, _) <- Decl.declaration
171 oneOfWithFallback
207 oneOfWithFallback
172− [ do Space.checkFreshLine E.DeclFreshLineStart
208+ [ do Space.checkFreshLine E.DeclStart
173 chompDecls (decl:decls)
209 chompDecls (decl:decls)
174 ]
210 ]
175 (reverse (decl:decls))
211 (reverse (decl:decls))
176
212
177
213
178−chompBinops :: [A.Located Src.Binop] -> Parser E.Module [A.Located Src.Binop]
214+chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]
179−chompBinops binops =
215+chompInfixes infixes =
180 oneOfWithFallback
216 oneOfWithFallback
181 [ do binop <- Decl.infix_
217 [ do binop <- Decl.infix_
182− chompBinops (binop:binops)
218+ chompInfixes (binop:infixes)
183 ]
219 ]
184− binops
220+ infixes
185
221
186
222
187
223
188-- MODULE DOC COMMENT
224-- MODULE DOC COMMENT
189
225
190
226
191−chompModuleDocComment :: Parser E.Module (Maybe Space.DocComment)
227+chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.Comment)
192−chompModuleDocComment =
228+chompModuleDocCommentSpace =
229+ do (A.At region ()) <- addLocation (freshLine E.FreshLine)
193− oneOfWithFallback
230+ oneOfWithFallback
194− [
231+ [
195− do docComment <- Space.docComment E.ImportStart E.ModuleSpace
232+ do docComment <- Space.docComment E.ImportStart E.ModuleSpace
196− Space.chomp E.ModuleSpace
233+ Space.chomp E.ModuleSpace
197− Space.checkFreshLine E.FreshLineAfterDocComment
234+ Space.checkFreshLine E.FreshLine
198− return (Just docComment)
235+ return (Right docComment)
199− ]
236+ ]
200− Nothing
237+ (Left region)
201
238
202
239
203
240
@@ -205,7 +242,7 @@ chompModuleDocComment =
205
242
206
243
207data Header =
244data Header =
208− Header Name.Name Effects (A.Located Src.Exposing)
245+ Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.Comment)
209
246
210
247
211data Effects
248data Effects
@@ -216,52 +253,56 @@ data Effects
216
253
217chompHeader :: Parser E.Module (Maybe Header)
254chompHeader :: Parser E.Module (Maybe Header)
218chompHeader =
255chompHeader =
256+ do freshLine E.FreshLine
219− do start <- getPosition
257+ start <- getPosition
220 oneOfWithFallback
258 oneOfWithFallback
221 [
259 [
222 -- module MyThing exposing (..)
260 -- module MyThing exposing (..)
223− do Keyword.module_ E.Module
261+ do Keyword.module_ E.ModuleProblem
224− end <- getPosition
262+ effectEnd <- getPosition
225− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentName
263+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
226− name <- Var.moduleName E.ModuleName
264+ name <- addLocation (Var.moduleName E.ModuleName)
227− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
265+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
228− Keyword.exposing_ E.ModuleExposing
266+ Keyword.exposing_ E.ModuleProblem
229− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
267+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
230− exports <- addLocation (specialize E.ModuleExposingList exposing)
268+ exports <- addLocation (specialize E.ModuleExposing exposing)
231− freshLine E.FreshLineAfterModuleLine
269+ comment <- chompModuleDocCommentSpace
270+ return $ Just $
232− return (Just (Header name (NoEffects (A.Region start end)) exports))
271+ Header name (NoEffects (A.Region start effectEnd)) exports comment
233 ,
272 ,
234 -- port module MyThing exposing (..)
273 -- port module MyThing exposing (..)
235− do Keyword.port_ E.Module
274+ do Keyword.port_ E.PortModuleProblem
236− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentPortModule
275+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
237− Keyword.module_ E.ModulePortModule
276+ Keyword.module_ E.PortModuleProblem
238− end <- getPosition
277+ effectEnd <- getPosition
239− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentName
278+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
240− name <- Var.moduleName E.ModuleName
279+ name <- addLocation (Var.moduleName E.PortModuleName)
241− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
280+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
242− Keyword.exposing_ E.ModuleExposing
281+ Keyword.exposing_ E.PortModuleProblem
243− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
282+ Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
244− exports <- addLocation (specialize E.ModuleExposingList exposing)
283+ exports <- addLocation (specialize E.PortModuleExposing exposing)
245− freshLine E.FreshLineAfterModuleLine
284+ comment <- chompModuleDocCommentSpace
285+ return $ Just $
246− return (Just (Header name (Ports (A.Region start end)) exports))
286+ Header name (Ports (A.Region start effectEnd)) exports comment
247 ,
287 ,
248 -- effect module MyThing where { command = MyCmd } exposing (..)
288 -- effect module MyThing where { command = MyCmd } exposing (..)
249− do Keyword.effect_ E.Module
289+ do Keyword.effect_ E.Effect
250− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
290+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
251− Keyword.module_ E.ModuleEffect
291+ Keyword.module_ E.Effect
252− end <- getPosition
292+ effectEnd <- getPosition
253− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
293+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
254− name <- Var.moduleName E.ModuleName
294+ name <- addLocation (Var.moduleName E.ModuleName)
255− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
295+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
256− Keyword.where_ E.ModuleEffect
296+ Keyword.where_ E.Effect
257− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
297+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
258 manager <- chompManager
298 manager <- chompManager
259− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
299+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
260− Keyword.exposing_ E.ModuleExposing
300+ Keyword.exposing_ E.Effect
261− Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
301+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
262− exports <- addLocation (specialize E.ModuleExposingList exposing)
302+ exports <- addLocation (specialize (const E.Effect) exposing)
263− freshLine E.FreshLineAfterModuleLine
303+ comment <- chompModuleDocCommentSpace
304+ return $ Just $
264− return (Just (Header name (Manager (A.Region start end) manager) exports))
305+ Header name (Manager (A.Region start effectEnd) manager) exports comment
265 ]
306 ]
266 -- default header
307 -- default header
267 Nothing
308 Nothing
@@ -269,34 +310,34 @@ chompHeader =
269
310
270chompManager :: Parser E.Module Src.Manager
311chompManager :: Parser E.Module Src.Manager
271chompManager =
312chompManager =
272− do word1 0x7B {- { -} E.ModuleEffect
313+ do word1 0x7B {- { -} E.Effect
273 spaces_em
314 spaces_em
274− oneOf E.ModuleEffect
315+ oneOf E.Effect
275 [ do cmd <- chompCommand
316 [ do cmd <- chompCommand
276 spaces_em
317 spaces_em
277− oneOf E.ModuleEffect
318+ oneOf E.Effect
278− [ do word1 0x7D {-}-} E.ModuleEffect
319+ [ do word1 0x7D {-}-} E.Effect
279 spaces_em
320 spaces_em
280 return (Src.Cmd cmd)
321 return (Src.Cmd cmd)
281− , do word1 0x2C {-,-} E.ModuleEffect
322+ , do word1 0x2C {-,-} E.Effect
282 spaces_em
323 spaces_em
283 sub <- chompSubscription
324 sub <- chompSubscription
284 spaces_em
325 spaces_em
285− word1 0x7D {-}-} E.ModuleEffect
326+ word1 0x7D {-}-} E.Effect
286 spaces_em
327 spaces_em
287 return (Src.Fx cmd sub)
328 return (Src.Fx cmd sub)
288 ]
329 ]
289 , do sub <- chompSubscription
330 , do sub <- chompSubscription
290 spaces_em
331 spaces_em
291− oneOf E.ModuleEffect
332+ oneOf E.Effect
292− [ do word1 0x7D {-}-} E.ModuleEffect
333+ [ do word1 0x7D {-}-} E.Effect
293 spaces_em
334 spaces_em
294 return (Src.Sub sub)
335 return (Src.Sub sub)
295− , do word1 0x2C {-,-} E.ModuleEffect
336+ , do word1 0x2C {-,-} E.Effect
296 spaces_em
337 spaces_em
297 cmd <- chompCommand
338 cmd <- chompCommand
298 spaces_em
339 spaces_em
299− word1 0x7D {-}-} E.ModuleEffect
340+ word1 0x7D {-}-} E.Effect
300 spaces_em
341 spaces_em
301 return (Src.Fx cmd sub)
342 return (Src.Fx cmd sub)
302 ]
343 ]
@@ -305,25 +346,25 @@ chompManager =
305
346
306chompCommand :: Parser E.Module (A.Located Name.Name)
347chompCommand :: Parser E.Module (A.Located Name.Name)
307chompCommand =
348chompCommand =
308− do Keyword.command_ E.ModuleEffect
349+ do Keyword.command_ E.Effect
309 spaces_em
350 spaces_em
310− word1 0x3D {-=-} E.ModuleEffect
351+ word1 0x3D {-=-} E.Effect
311 spaces_em
352 spaces_em
312− addLocation (Var.upper E.ModuleEffect)
353+ addLocation (Var.upper E.Effect)
313
354
314
355
315chompSubscription :: Parser E.Module (A.Located Name.Name)
356chompSubscription :: Parser E.Module (A.Located Name.Name)
316chompSubscription =
357chompSubscription =
317− do Keyword.subscription_ E.ModuleEffect
358+ do Keyword.subscription_ E.Effect
318 spaces_em
359 spaces_em
319− word1 0x3D {-=-} E.ModuleEffect
360+ word1 0x3D {-=-} E.Effect
320 spaces_em
361 spaces_em
321− addLocation (Var.upper E.ModuleEffect)
362+ addLocation (Var.upper E.Effect)
322
363
323
364
324spaces_em :: Parser E.Module ()
365spaces_em :: Parser E.Module ()
325spaces_em =
366spaces_em =
326− Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
367+ Space.chompAndCheckIndent E.ModuleSpace E.Effect
327
368
328
369
329
370
@@ -331,28 +372,33 @@ spaces_em =
331
372
332
373
333chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
374chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
334−chompImports imports =
375+chompImports is =
335 oneOfWithFallback
376 oneOfWithFallback
336− [ do Keyword.import_ E.ImportStart
377+ [ do i <- chompImport
337− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
338− name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
339− Space.chomp E.ModuleSpace
340− oneOf E.ImportEnd
341− [ do Space.checkFreshLine E.ImportEnd
342− chompImports $
378+ chompImports (i:is)
343− Src.Import name Nothing (Src.Explicit []) : imports
344− , do Space.checkIndent end E.ImportIndentAs
345− oneOf E.ImportAs
346− [ chompAs name imports
347− , chompExposing name Nothing imports
348− ]
349− ]
350 ]
379 ]
351− (reverse imports)
380+ (reverse is)
352
381
353
382
383+chompImport :: Parser E.Module Src.Import
384+chompImport =
385+ do Keyword.import_ E.ImportStart
386+ Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
387+ name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
388+ Space.chomp E.ModuleSpace
389+ oneOf E.ImportEnd
390+ [ do Space.checkFreshLine E.ImportEnd
391+ return $ Src.Import name Nothing (Src.Explicit [])
392+ , do Space.checkIndent end E.ImportEnd
393+ oneOf E.ImportAs
394+ [ chompAs name
395+ , chompExposing name Nothing
396+ ]
397+ ]
398+
399+
354−chompAs :: A.Located Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
400+chompAs :: A.Located Name.Name -> Parser E.Module Src.Import
355−chompAs name imports =
401+chompAs name =
356 do Keyword.as_ E.ImportAs
402 do Keyword.as_ E.ImportAs
357 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
403 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
358 alias <- Var.upper E.ImportAlias
404 alias <- Var.upper E.ImportAlias
@@ -360,21 +406,19 @@ chompAs name imports =
360 Space.chomp E.ModuleSpace
406 Space.chomp E.ModuleSpace
361 oneOf E.ImportEnd
407 oneOf E.ImportEnd
362 [ do Space.checkFreshLine E.ImportEnd
408 [ do Space.checkFreshLine E.ImportEnd
363− chompImports $
364− Src.Import name (Just alias) (Src.Explicit []) : imports
409+ return $ Src.Import name (Just alias) (Src.Explicit [])
365− , do Space.checkIndent end E.ImportIndentExposing
410+ , do Space.checkIndent end E.ImportEnd
366− chompExposing name (Just alias) imports
411+ chompExposing name (Just alias)
367 ]
412 ]
368
413
369
414
370−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
371−chompExposing name maybeAlias imports =
416+chompExposing name maybeAlias =
372 do Keyword.exposing_ E.ImportExposing
417 do Keyword.exposing_ E.ImportExposing
373 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
418 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
374 exposed <- specialize E.ImportExposingList exposing
419 exposed <- specialize E.ImportExposingList exposing
375 freshLine E.ImportEnd
420 freshLine E.ImportEnd
376− chompImports $
377− Src.Import name maybeAlias exposed : imports
421+ return $ Src.Import name maybeAlias exposed
378
422
379
423
380
424
@@ -385,24 +429,24 @@ exposing :: Parser E.Exposing Src.Exposing
385exposing =
429exposing =
386 do word1 0x28 {-(-} E.ExposingStart
430 do word1 0x28 {-(-} E.ExposingStart
387 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
431 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
388− oneOf E.ExposingIndentValue
432+ oneOf E.ExposingValue
389− [ do word2 0x2E 0x2E {-..-} E.ExposingIndentValue
433+ [ do word2 0x2E 0x2E {-..-} E.ExposingValue
390 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
434 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
391 word1 0x29 {-)-} E.ExposingEnd
435 word1 0x29 {-)-} E.ExposingEnd
392 return Src.Open
436 return Src.Open
393− , do exposed <- addLocation chompExposed
437+ , do exposed <- chompExposed
394 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
438 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
395 exposingHelp [exposed]
439 exposingHelp [exposed]
396 ]
440 ]
397
441
398
442
399−exposingHelp :: [A.Located Src.Exposed] -> Parser E.Exposing Src.Exposing
443+exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing
400exposingHelp revExposed =
444exposingHelp revExposed =
401 oneOf E.ExposingEnd
445 oneOf E.ExposingEnd
402 [ do word1 0x2C {-,-} E.ExposingEnd
446 [ do word1 0x2C {-,-} E.ExposingEnd
403 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
447 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
404− exposed <- addLocation chompExposed
448+ exposed <- chompExposed
405− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValueEnd
449+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
406 exposingHelp (exposed:revExposed)
450 exposingHelp (exposed:revExposed)
407 , do word1 0x29 {-)-} E.ExposingEnd
451 , do word1 0x29 {-)-} E.ExposingEnd
408 return (Src.Explicit (reverse revExposed))
452 return (Src.Explicit (reverse revExposed))
@@ -411,26 +455,33 @@ exposingHelp revExposed =
411
455
412chompExposed :: Parser E.Exposing Src.Exposed
456chompExposed :: Parser E.Exposing Src.Exposed
413chompExposed =
457chompExposed =
458+ do start <- getPosition
414− oneOf E.ExposingValue
459+ oneOf E.ExposingValue
415− [ 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
416− , do word1 0x28 {-(-} E.ExposingValue
463+ , do word1 0x28 {-(-} E.ExposingValue
417− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
464+ op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
418− word1 0x29 {-)-} E.ExposingOperatorRightParen
465+ word1 0x29 {-)-} E.ExposingOperatorRightParen
466+ end <- getPosition
419− return (Src.Operator op)
467+ return $ Src.Operator (A.Region start end) op
420− , do name <- Var.upper E.ExposingValue
468+ , do name <- Var.upper E.ExposingValue
469+ end <- getPosition
421− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacy
470+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
422− Src.Upper name <$> privacy
471+ Src.Upper (A.at start end name) <$> privacy
423− ]
472+ ]
424
473
425
474
426privacy :: Parser E.Exposing Src.Privacy
475privacy :: Parser E.Exposing Src.Privacy
427privacy =
476privacy =
428 oneOfWithFallback
477 oneOfWithFallback
429 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
478 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
430− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyDots
479+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
480+ start <- getPosition
431− word2 0x2E 0x2E {-..-} E.ExposingTypePrivacyDots
481+ word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
482+ end <- getPosition
432− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyEnd
483+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
433− word1 0x29 {-)-} E.ExposingTypePrivacyEnd
484+ word1 0x29 {-)-} E.ExposingTypePrivacy
434− return Src.Public
485+ return $ Src.Public (A.Region start end)
435 ]
486 ]
436 Src.Private
487 Src.Private
compiler/src/Parse/Number.hs+16−13
@@ -11,11 +11,11 @@ module Parse.Number
11 where
11 where
12
12
13
13
14−import qualified Data.Utf8 as Utf8
15import Data.Word (Word8)
14import Data.Word (Word8)
16import Foreign.Ptr (Ptr, plusPtr, minusPtr)
15import Foreign.Ptr (Ptr, plusPtr, minusPtr)
17
16
18import qualified AST.Utils.Binop as Binop
17import qualified AST.Utils.Binop as Binop
18+import qualified Elm.Float as EF
19import Parse.Primitives (Parser, Row, Col)
19import Parse.Primitives (Parser, Row, Col)
20import qualified Parse.Variable as Var
20import qualified Parse.Variable as Var
21import qualified Parse.Primitives as P
21import qualified Parse.Primitives as P
@@ -43,12 +43,12 @@ isDecimalDigit word =
43
43
44data Number
44data Number
45 = Int Int
45 = Int Int
46− | Float (Utf8.Under256 Float)
46+ | Float EF.Float
47
47
48
48
49number :: (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> Parser x Number
49number :: (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> Parser x Number
50number toExpectation toError =
50number toExpectation toError =
51− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
51+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
52 if pos >= end then
52 if pos >= end then
53 eerr row col toExpectation
53 eerr row col toExpectation
54
54
@@ -76,16 +76,16 @@ number toExpectation toError =
76 let
76 let
77 !newCol = col + fromIntegral (minusPtr newPos pos)
77 !newCol = col + fromIntegral (minusPtr newPos pos)
78 !integer = Int n
78 !integer = Int n
79− !newState = P.State newPos end indent row newCol
79+ !newState = P.State src newPos end indent row newCol
80 in
80 in
81 cok integer newState
81 cok integer newState
82
82
83 OkFloat newPos ->
83 OkFloat newPos ->
84 let
84 let
85 !newCol = col + fromIntegral (minusPtr newPos pos)
85 !newCol = col + fromIntegral (minusPtr newPos pos)
86− !copy = Utf8.fromPtr pos newPos
86+ !copy = EF.fromPtr pos newPos
87 !float = Float copy
87 !float = Float copy
88− !newState = P.State newPos end indent row newCol
88+ !newState = P.State src newPos end indent row newCol
89 in
89 in
90 cok float newState
90 cok float newState
91
91
@@ -121,7 +121,7 @@ chompInt !pos end !n =
121 chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-}))
121 chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-}))
122
122
123 else if word == 0x2E {-.-} then
123 else if word == 0x2E {-.-} then
124− chompFraction (plusPtr pos 1) end n
124+ chompFraction pos end n
125
125
126 else if word == 0x65 {-e-} || word == 0x45 {-E-} then
126 else if word == 0x65 {-e-} || word == 0x45 {-E-} then
127 chompExponent (plusPtr pos 1) end
127 chompExponent (plusPtr pos 1) end
@@ -139,11 +139,14 @@ chompInt !pos end !n =
139
139
140chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome
140chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome
141chompFraction pos end n =
141chompFraction pos end n =
142+ let
143+ !pos1 = plusPtr pos 1
144+ in
142− if pos >= end then
145+ if pos1 >= end then
143 Err pos (E.NumberDot n)
146 Err pos (E.NumberDot n)
144
147
145− else if isDecimalDigit (P.unsafeIndex pos) then
148+ else if isDecimalDigit (P.unsafeIndex pos1) then
146− chompFractionHelp (plusPtr pos 1) end
149+ chompFractionHelp (plusPtr pos1 1) end
147
150
148 else
151 else
149 Err pos (E.NumberDot n)
152 Err pos (E.NumberDot n)
@@ -222,7 +225,7 @@ chompZero pos end =
222 chompHexInt (plusPtr pos 1) end
225 chompHexInt (plusPtr pos 1) end
223
226
224 else if word == 0x2E {-.-} then
227 else if word == 0x2E {-.-} then
225− chompFraction (plusPtr pos 1) end 0
228+ chompFraction pos end 0
226
229
227 else if isDecimalDigit word then
230 else if isDecimalDigit word then
228 Err pos E.NumberNoLeadingZero
231 Err pos E.NumberNoLeadingZero
@@ -287,7 +290,7 @@ stepHex pos end word acc
287
290
288precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence
291precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence
289precedence toExpectation =
292precedence toExpectation =
290− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
293+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
291 if pos >= end then
294 if pos >= end then
292 eerr row col toExpectation
295 eerr row col toExpectation
293
296
@@ -296,7 +299,7 @@ precedence toExpectation =
296 if isDecimalDigit word then
299 if isDecimalDigit word then
297 cok
300 cok
298 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
301 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
299− (P.State (plusPtr pos 1) end indent row (col + 1))
302+ (P.State src (plusPtr pos 1) end indent row (col + 1))
300
303
301 else
304 else
302 eerr row col toExpectation
305 eerr row col toExpectation
compiler/src/Parse/Pattern.hs+46−21
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3module Parse.Pattern
3module Parse.Pattern
4 ( term
4 ( term
5 , expression
5 , expression
@@ -10,13 +10,13 @@ module Parse.Pattern
10import qualified Data.List as List
10import qualified Data.List as List
11import qualified Data.Name as Name
11import qualified Data.Name as Name
12import qualified Data.Utf8 as Utf8
12import qualified Data.Utf8 as Utf8
13+import Foreign.Ptr (plusPtr)
13
14
14import qualified AST.Source as Src
15import qualified AST.Source as Src
15import qualified Parse.Keyword as Keyword
16import qualified Parse.Keyword as Keyword
16import qualified Parse.Number as Number
17import qualified Parse.Number as Number
17import qualified Parse.Space as Space
18import qualified Parse.Space as Space
18−import qualified Parse.Symbol as Symbol
19+import qualified Parse.String as String
19−import qualified Parse.Utf8 as Utf8
20import qualified Parse.Variable as Var
20import qualified Parse.Variable as Var
21import qualified Parse.Primitives as P
21import qualified Parse.Primitives as P
22import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2)
22import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2)
@@ -43,7 +43,7 @@ termHelp :: A.Position -> Parser E.Pattern Src.Pattern
43termHelp start =
43termHelp start =
44 oneOf E.PStart
44 oneOf E.PStart
45 [
45 [
46− do Symbol.wildcard
46+ do wildcard
47 addEnd start Src.PAnything
47 addEnd start Src.PAnything
48 ,
48 ,
49 do name <- Var.lower E.PStart
49 do name <- Var.lower E.PStart
@@ -67,18 +67,43 @@ termHelp start =
67 return (A.at start end (Src.PInt int))
67 return (A.at start end (Src.PInt int))
68
68
69 Number.Float float ->
69 Number.Float float ->
70− P.Parser $ \(P.State _ _ _ row col) _ _ cerr _ ->
70+ P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ ->
71+ let
71− cerr row col (E.PFloat (Utf8.size float))
72+ width = fromIntegral (Utf8.size float)
73+ in
74+ cerr row (col - width) (E.PFloat width)
72 ,
75 ,
73− do str <- Utf8.string E.PStart E.PString
76+ do str <- String.string E.PStart E.PString
74 addEnd start (Src.PStr str)
77 addEnd start (Src.PStr str)
75 ,
78 ,
76− do chr <- Utf8.character E.PStart E.PChar
79+ do chr <- String.character E.PStart E.PChar
77 addEnd start (Src.PChr chr)
80 addEnd start (Src.PChr chr)
78 ]
81 ]
79
82
80
83
81
84
85+-- WILDCARD
86+
87+
88+wildcard :: Parser E.Pattern ()
89+wildcard =
90+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
91+ if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
92+ eerr row col E.PStart
93+ else
94+ let
95+ !newPos = plusPtr pos 1
96+ !newCol = col + 1
97+ in
98+ if Var.getInnerWidth newPos end > 0 then
99+ let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in
100+ cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col)))
101+ else
102+ let !newState = P.State src newPos end indent row newCol in
103+ cok () newState
104+
105+
106+
82-- RECORDS
107-- RECORDS
83
108
84
109
@@ -104,7 +129,7 @@ recordHelp start vars =
104 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
129 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
105 recordHelp start (var:vars)
130 recordHelp start (var:vars)
106 , do word1 0x7D {-}-} E.PRecordEnd
131 , do word1 0x7D {-}-} E.PRecordEnd
107− addEnd start (Src.PRecord vars)
132+ addEnd start (Src.PRecord (reverse vars))
108 ]
133 ]
109
134
110
135
@@ -115,7 +140,7 @@ recordHelp start vars =
115tuple :: A.Position -> Parser E.Pattern Src.Pattern
140tuple :: A.Position -> Parser E.Pattern Src.Pattern
116tuple start =
141tuple start =
117 inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
142 inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
118− do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentOpen
143+ do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1
119 oneOf E.PTupleOpen
144 oneOf E.PTupleOpen
120 [ do (pattern, end) <- P.specialize E.PTupleExpr expression
145 [ do (pattern, end) <- P.specialize E.PTupleExpr expression
121 Space.checkIndent end E.PTupleIndentEnd
146 Space.checkIndent end E.PTupleIndentEnd
@@ -129,7 +154,7 @@ tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.P
129tupleHelp start firstPattern revPatterns =
154tupleHelp start firstPattern revPatterns =
130 oneOf E.PTupleEnd
155 oneOf E.PTupleEnd
131 [ do word1 0x2C {-,-} E.PTupleEnd
156 [ do word1 0x2C {-,-} E.PTupleEnd
132− Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr
157+ Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN
133 (pattern, end) <- P.specialize E.PTupleExpr expression
158 (pattern, end) <- P.specialize E.PTupleExpr expression
134 Space.checkIndent end E.PTupleIndentEnd
159 Space.checkIndent end E.PTupleIndentEnd
135 tupleHelp start firstPattern (pattern : revPatterns)
160 tupleHelp start firstPattern (pattern : revPatterns)
@@ -180,18 +205,18 @@ listHelp start patterns =
180expression :: Space.Parser E.Pattern Src.Pattern
205expression :: Space.Parser E.Pattern Src.Pattern
181expression =
206expression =
182 do start <- getPosition
207 do start <- getPosition
183− cTerm <- exprTerm
208+ ePart <- exprPart
184− exprHelp start [] cTerm
209+ exprHelp start [] ePart
185
210
186
211
187exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
212exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
188−exprHelp start patterns (pattern, end) =
213+exprHelp start revPatterns (pattern, end) =
189 oneOfWithFallback
214 oneOfWithFallback
190 [ do Space.checkIndent end E.PIndentStart
215 [ do Space.checkIndent end E.PIndentStart
191 word2 0x3A 0x3A {-::-} E.PStart
216 word2 0x3A 0x3A {-::-} E.PStart
192 Space.chompAndCheckIndent E.PSpace E.PIndentStart
217 Space.chompAndCheckIndent E.PSpace E.PIndentStart
193− cTerm <- exprTerm
218+ ePart <- exprPart
194− exprHelp start (pattern:patterns) cTerm
219+ exprHelp start (pattern:revPatterns) ePart
195 , do Space.checkIndent end E.PIndentStart
220 , do Space.checkIndent end E.PIndentStart
196 Keyword.as_ E.PStart
221 Keyword.as_ E.PStart
197 Space.chompAndCheckIndent E.PSpace E.PIndentAlias
222 Space.chompAndCheckIndent E.PSpace E.PIndentAlias
@@ -201,11 +226,11 @@ exprHelp start patterns (pattern, end) =
201 Space.chomp E.PSpace
226 Space.chomp E.PSpace
202 let alias = A.at nameStart newEnd name
227 let alias = A.at nameStart newEnd name
203 return
228 return
204− ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern patterns) alias)
229+ ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias)
205 , newEnd
230 , newEnd
206 )
231 )
207 ]
232 ]
208− ( List.foldl' cons pattern patterns
233+ ( List.foldl' cons pattern revPatterns
209 , end
234 , end
210 )
235 )
211
236
@@ -216,11 +241,11 @@ cons tl hd =
216
241
217
242
218
243
219−-- EXPRESSION TERM
244+-- EXPRESSION PART
220
245
221
246
222−exprTerm :: Space.Parser E.Pattern Src.Pattern
247+exprPart :: Space.Parser E.Pattern Src.Pattern
223−exprTerm =
248+exprPart =
224 oneOf E.PStart
249 oneOf E.PStart
225 [
250 [
226 do start <- getPosition
251 do start <- getPosition
compiler/src/Parse/Primitives.hs+95−47
@@ -1,8 +1,7 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
3module Parse.Primitives
3module Parse.Primitives
4− ( Result(..)
5− , fromByteString
4+ ( fromByteString
6 , Parser(..)
5 , Parser(..)
7 , State(..)
6 , State(..)
8 , Row
7 , Row
@@ -13,18 +12,20 @@ module Parse.Primitives
13 , getIndent, setIndent, withIndent, withBacksetIndent
12 , getIndent, setIndent, withIndent, withBacksetIndent
14 , word1, word2
13 , word1, word2
15 , unsafeIndex, isWord, getCharWidth
14 , unsafeIndex, isWord, getCharWidth
15+ , Snippet(..)
16+ , fromSnippet
16 )
17 )
17 where
18 where
18
19
19
20
20import Prelude hiding (length)
21import Prelude hiding (length)
21import qualified Control.Applicative as Applicative (Applicative(..))
22import qualified Control.Applicative as Applicative (Applicative(..))
22−import Control.Monad
23import qualified Data.ByteString.Internal as B
23import qualified Data.ByteString.Internal as B
24import Data.Word (Word8, Word16)
24import Data.Word (Word8, Word16)
25import Foreign.Ptr (Ptr, plusPtr)
25import Foreign.Ptr (Ptr, plusPtr)
26import Foreign.Storable (peek)
26import Foreign.Storable (peek)
27−import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)
27+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
28+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
28
29
29import qualified Reporting.Annotation as A
30import qualified Reporting.Annotation as A
30
31
@@ -45,9 +46,10 @@ newtype Parser x a =
45 )
46 )
46
47
47
48
48−data State = -- TODO try adding UNPACK to everything
49+data State = -- PERF try taking some out to avoid allocation
49 State
50 State
51+ { _src :: ForeignPtr Word8
50− { _pos :: !(Ptr Word8)
52+ , _pos :: !(Ptr Word8)
51 , _end :: !(Ptr Word8)
53 , _end :: !(Ptr Word8)
52 , _indent :: !Word16
54 , _indent :: !Word16
53 , _row :: !Row
55 , _row :: !Row
@@ -83,7 +85,23 @@ instance Applicative.Applicative (Parser x) where
83 pure = return
85 pure = return
84
86
85 {-# INLINE (<*>) #-}
87 {-# INLINE (<*>) #-}
86− (<*>) = ap
88+ (<*>) (Parser parserFunc) (Parser parserArg) =
89+ Parser $ \state cok eok cerr eerr ->
90+ let
91+ cokF func s1 =
92+ let
93+ cokA arg s2 = cok (func arg) s2
94+ in
95+ parserArg s1 cokA cokA cerr cerr
96+
97+ eokF func s1 =
98+ let
99+ cokA arg s2 = cok (func arg) s2
100+ eokA arg s2 = eok (func arg) s2
101+ in
102+ parserArg s1 cokA eokA cerr eerr
103+ in
104+ parserFunc state cokF eokF cerr eerr
87
105
88
106
89
107
@@ -117,7 +135,7 @@ oneOfHelp state cok eok cerr eerr toError parsers =
117
135
118 [] ->
136 [] ->
119 let
137 let
120− (State _ _ _ row col) = state
138+ (State _ _ _ _ row col) = state
121 in
139 in
122 eerr row col toError
140 eerr row col toError
123
141
@@ -127,7 +145,7 @@ oneOfHelp state cok eok cerr eerr toError parsers =
127
145
128
146
129{-# INLINE oneOfWithFallback #-}
147{-# INLINE oneOfWithFallback #-}
130−oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- TODO is this function okay? Worried about allocation/laziness with fallback values.
148+oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values.
131oneOfWithFallback parsers fallback =
149oneOfWithFallback parsers fallback =
132 Parser $ \state cok eok cerr _ ->
150 Parser $ \state cok eok cerr _ ->
133 oowfHelp state cok eok cerr parsers fallback
151 oowfHelp state cok eok cerr parsers fallback
@@ -183,26 +201,56 @@ instance Monad (Parser x) where
183-- FROM BYTESTRING
201-- FROM BYTESTRING
184
202
185
203
186−data Result x a
187− = Ok !a State
188− | Err x
189−
190−
191−fromByteString :: Parser x a -> B.ByteString -> Result x a
204+fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a
192−fromByteString (Parser parser) (B.PS fp offset length) =
205+fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) =
193 B.accursedUnutterablePerformIO $
206 B.accursedUnutterablePerformIO $
194 let
207 let
208+ toOk' = toOk toBadEnd
195− !pos = plusPtr (unsafeForeignPtrToPtr fp) offset
209+ !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset
196 !end = plusPtr pos length
210 !end = plusPtr pos length
197− !result = parser (State pos end 0 1 1) Ok Ok toErr toErr
211+ !result = parser (State fptr pos end 0 1 1) toOk' toOk' toErr toErr
198 in
212 in
199− do touchForeignPtr fp
213+ do touchForeignPtr fptr
200 return result
214 return result
201
215
202
216
217+toOk :: (Row -> Col -> x) -> a -> State -> Either x a
218+toOk toBadEnd !a (State _ pos end _ row col) =
219+ if pos == end
220+ then Right a
221+ else Left (toBadEnd row col)
222+
223+
203−toErr :: Row -> Col -> (Row -> Col -> x) -> Result x a
224+toErr :: Row -> Col -> (Row -> Col -> x) -> Either x a
204toErr row col toError =
225toErr row col toError =
205− Err (toError row col)
226+ Left (toError row col)
227+
228+
229+
230+-- FROM SNIPPET
231+
232+
233+data Snippet =
234+ Snippet
235+ { _fptr :: ForeignPtr Word8
236+ , _offset :: Int
237+ , _length :: Int
238+ , _offRow :: Row
239+ , _offCol :: Col
240+ }
241+
242+
243+fromSnippet :: Parser x a -> (Row -> Col -> x) -> Snippet -> Either x a
244+fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =
245+ B.accursedUnutterablePerformIO $
246+ let
247+ toOk' = toOk toBadEnd
248+ !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset
249+ !end = plusPtr pos length
250+ !result = parser (State fptr pos end 0 row col) toOk' toOk' toErr toErr
251+ in
252+ do touchForeignPtr fptr
253+ return result
206
254
207
255
208
256
@@ -211,30 +259,30 @@ toErr row col toError =
211
259
212getCol :: Parser x Word16
260getCol :: Parser x Word16
213getCol =
261getCol =
214− Parser $ \state@(State _ _ _ _ col) _ eok _ _ ->
262+ Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ ->
215 eok col state
263 eok col state
216
264
217
265
218{-# INLINE getPosition #-}
266{-# INLINE getPosition #-}
219getPosition :: Parser x A.Position
267getPosition :: Parser x A.Position
220getPosition =
268getPosition =
221− Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
269+ Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
222 eok (A.Position row col) state
270 eok (A.Position row col) state
223
271
224
272
225addLocation :: Parser x a -> Parser x (A.Located a)
273addLocation :: Parser x a -> Parser x (A.Located a)
226addLocation (Parser parser) =
274addLocation (Parser parser) =
227− Parser $ \state@(State _ _ _ sr sc) cok eok cerr eerr ->
275+ Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr ->
228 let
276 let
229− cok' a s@(State _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
277+ cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
230− eok' a s@(State _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
278+ eok' a s@(State _ _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
231 in
279 in
232 parser state cok' eok' cerr eerr
280 parser state cok' eok' cerr eerr
233
281
234
282
235addEnd :: A.Position -> a -> Parser x (A.Located a)
283addEnd :: A.Position -> a -> Parser x (A.Located a)
236addEnd start value =
284addEnd start value =
237− Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
285+ Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
238 eok (A.at start (A.Position row col) value) state
286 eok (A.at start (A.Position row col) value) state
239
287
240
288
@@ -244,37 +292,37 @@ addEnd start value =
244
292
245getIndent :: Parser x Word16
293getIndent :: Parser x Word16
246getIndent =
294getIndent =
247− Parser $ \state@(State _ _ indent _ _) _ eok _ _ ->
295+ Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ ->
248 eok indent state
296 eok indent state
249
297
250
298
251setIndent :: Word16 -> Parser x ()
299setIndent :: Word16 -> Parser x ()
252setIndent indent =
300setIndent indent =
253− Parser $ \(State pos end _ row col) _ eok _ _ ->
301+ Parser $ \(State src pos end _ row col) _ eok _ _ ->
254 let
302 let
255− !newState = State pos end indent row col
303+ !newState = State src pos end indent row col
256 in
304 in
257 eok () newState
305 eok () newState
258
306
259
307
260withIndent :: Parser x a -> Parser x a
308withIndent :: Parser x a -> Parser x a
261withIndent (Parser parser) =
309withIndent (Parser parser) =
262− Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
310+ Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
263 let
311 let
264− cok' a (State p e _ r c) = cok a (State p e oldIndent r c)
312+ cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
265− eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
313+ eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)
266 in
314 in
267− parser (State pos end col row col) cok' eok' cerr eerr
315+ parser (State src pos end col row col) cok' eok' cerr eerr
268
316
269
317
270withBacksetIndent :: Word16 -> Parser x a -> Parser x a
318withBacksetIndent :: Word16 -> Parser x a -> Parser x a
271withBacksetIndent backset (Parser parser) =
319withBacksetIndent backset (Parser parser) =
272− Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
320+ Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
273 let
321 let
274− cok' a (State p e _ r c) = cok a (State p e oldIndent r c)
322+ cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
275− eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
323+ eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)
276 in
324 in
277− parser (State pos end (col - backset) row col) cok' eok' cerr eerr
325+ parser (State src pos end (col - backset) row col) cok' eok' cerr eerr
278
326
279
327
280
328
@@ -283,7 +331,7 @@ withBacksetIndent backset (Parser parser) =
283
331
284inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a
332inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a
285inContext addContext (Parser parserStart) (Parser parserA) =
333inContext addContext (Parser parserStart) (Parser parserA) =
286− Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
334+ Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
287 let
335 let
288 cerrA r c tx = cerr row col (addContext (tx r c))
336 cerrA r c tx = cerr row col (addContext (tx r c))
289 eerrA r c tx = eerr row col (addContext (tx r c))
337 eerrA r c tx = eerr row col (addContext (tx r c))
@@ -296,7 +344,7 @@ inContext addContext (Parser parserStart) (Parser parserA) =
296
344
297specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a
345specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a
298specialize addContext (Parser parser) =
346specialize addContext (Parser parser) =
299− Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
347+ Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
300 let
348 let
301 cerr' r c tx = cerr row col (addContext (tx r c))
349 cerr' r c tx = cerr row col (addContext (tx r c))
302 eerr' r c tx = eerr row col (addContext (tx r c))
350 eerr' r c tx = eerr row col (addContext (tx r c))
@@ -310,9 +358,9 @@ specialize addContext (Parser parser) =
310
358
311word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()
359word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()
312word1 word toError =
360word1 word toError =
313− Parser $ \(State pos end indent row col) cok _ _ eerr ->
361+ Parser $ \(State src pos end indent row col) cok _ _ eerr ->
314 if pos < end && unsafeIndex pos == word then
362 if pos < end && unsafeIndex pos == word then
315− let !newState = State (plusPtr pos 1) end indent row (col + 1) in
363+ let !newState = State src (plusPtr pos 1) end indent row (col + 1) in
316 cok () newState
364 cok () newState
317 else
365 else
318 eerr row col toError
366 eerr row col toError
@@ -320,12 +368,12 @@ word1 word toError =
320
368
321word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
369word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
322word2 w1 w2 toError =
370word2 w1 w2 toError =
323− Parser $ \(State pos end indent row col) cok _ _ eerr ->
371+ Parser $ \(State src pos end indent row col) cok _ _ eerr ->
324 let
372 let
325 !pos1 = plusPtr pos 1
373 !pos1 = plusPtr pos 1
326 in
374 in
327 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
375 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
328− let !newState = State (plusPtr pos 2) end indent row (col + 2) in
376+ let !newState = State src (plusPtr pos 2) end indent row (col + 2) in
329 cok () newState
377 cok () newState
330 else
378 else
331 eerr row col toError
379 eerr row col toError
@@ -346,8 +394,8 @@ isWord pos end word =
346 pos < end && unsafeIndex pos == word
394 pos < end && unsafeIndex pos == word
347
395
348
396
349−getCharWidth :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
397+getCharWidth :: Word8 -> Int
350−getCharWidth _pos _end word
398+getCharWidth word
351 | word < 0x80 = 1
399 | word < 0x80 = 1
352 | 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."
353 | 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+20−19
@@ -6,12 +6,13 @@ module Parse.Shader
6 where
6 where
7
7
8
8
9−import qualified Data.List as List
9+import qualified Data.ByteString.Internal as B
10+import qualified Data.ByteString.UTF8 as BS_UTF8
10import qualified Data.Map as Map
11import qualified Data.Map as Map
11import qualified Data.Name as Name
12import qualified Data.Name as Name
12−import qualified Data.Utf8 as Utf8
13import Data.Word (Word8)
13import Data.Word (Word8)
14−import Foreign.Ptr (Ptr, plusPtr)
14+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
15+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
15import qualified Language.GLSL.Parser as GLP
16import qualified Language.GLSL.Parser as GLP
16import qualified Language.GLSL.Syntax as GLS
17import qualified Language.GLSL.Syntax as GLS
17import qualified Text.Parsec as Parsec
18import qualified Text.Parsec as Parsec
@@ -34,17 +35,16 @@ shader start@(A.Position row col) =
34 do block <- parseBlock
35 do block <- parseBlock
35 shdr <- parseGlsl row col block
36 shdr <- parseGlsl row col block
36 end <- P.getPosition
37 end <- P.getPosition
37− let src = List.intercalate "\\n" (lines block)
38− return (A.at start end (Src.Shader (Utf8.fromChars src) shdr))
38+ return (A.at start end (Src.Shader (Shader.fromChars block) shdr))
39
39
40
40
41
41
42-- BLOCK
42-- BLOCK
43
43
44
44
45−parseBlock :: Parser E.Expr String
45+parseBlock :: Parser E.Expr [Char]
46parseBlock =
46parseBlock =
47− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
47+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
48 let
48 let
49 !pos6 = plusPtr pos 6
49 !pos6 = plusPtr pos 6
50 in
50 in
@@ -58,16 +58,17 @@ parseBlock =
58 then
58 then
59 let
59 let
60 (# status, newPos, newRow, newCol #) =
60 (# status, newPos, newRow, newCol #) =
61− eatShader pos6 end row col
61+ eatShader pos6 end row (col + 6)
62 in
62 in
63 case status of
63 case status of
64 Good ->
64 Good ->
65 let
65 let
66− !block = Utf8.fromPtr pos newPos
66+ !off = minusPtr pos6 (unsafeForeignPtrToPtr src)
67− !source = Utf8.toChars block
67+ !len = minusPtr newPos pos6
68+ !block = BS_UTF8.toString (B.PS src off len)
68− !newState = P.State (plusPtr newPos 2) end indent newRow newCol
69+ !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)
69 in
70 in
70− cok source newState
71+ cok block newState
71
72
72 Unending ->
73 Unending ->
73 cerr row col E.EndlessShader
74 cerr row col E.EndlessShader
@@ -89,13 +90,13 @@ eatShader pos end row col =
89 else
90 else
90 let !word = P.unsafeIndex pos in
91 let !word = P.unsafeIndex pos in
91 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
92 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
92− (# Good, pos, row, col + 2 #)
93+ (# Good, pos, row, col #)
93
94
94 else if word == 0x0A {- \n -} then
95 else if word == 0x0A {- \n -} then
95 eatShader (plusPtr pos 1) end (row + 1) 1
96 eatShader (plusPtr pos 1) end (row + 1) 1
96
97
97 else
98 else
98− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
99+ let !newPos = plusPtr pos (P.getCharWidth word) in
99 eatShader newPos end row (col + 1)
100 eatShader newPos end row (col + 1)
100
101
101
102
@@ -103,7 +104,7 @@ eatShader pos end row col =
103-- GLSL
104-- GLSL
104
105
105
106
106−parseGlsl :: Row -> Col -> String -> Parser E.Expr Shader.Types
107+parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types
107parseGlsl startRow startCol src =
108parseGlsl startRow startCol src =
108 case GLP.parse src of
109 case GLP.parse src of
109 Right (GLS.TranslationUnit decls) ->
110 Right (GLS.TranslationUnit decls) ->
@@ -128,9 +129,9 @@ parseGlsl startRow startCol src =
128 else failure (startRow + row - 1) col msg
129 else failure (startRow + row - 1) col msg
129
130
130
131
131−failure :: Row -> Col -> String -> Parser E.Expr a
132+failure :: Row -> Col -> [Char] -> Parser E.Expr a
132failure row col msg =
133failure row col msg =
133− P.Parser $ \(P.State _ _ _ _ _) _ _ cerr _ ->
134+ P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->
134 cerr row col (E.ShaderProblem msg)
135 cerr row col (E.ShaderProblem msg)
135
136
136
137
@@ -143,7 +144,7 @@ emptyTypes =
143 Shader.Types Map.empty Map.empty Map.empty
144 Shader.Types Map.empty Map.empty Map.empty
144
145
145
146
146−addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types
147+addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types
147addInput (qual, tipe, name) glDecls =
148addInput (qual, tipe, name) glDecls =
148 case qual of
149 case qual of
149 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
150 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
@@ -152,7 +153,7 @@ addInput (qual, tipe, name) glDecls =
152 _ -> error "Should never happen due to `extractInputs` function"
153 _ -> error "Should never happen due to `extractInputs` function"
153
154
154
155
155−extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)]
156+extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]
156extractInputs decl =
157extractInputs decl =
157 case decl of
158 case decl of
158 GLS.Declaration
159 GLS.Declaration
compiler/src/Parse/Space.hs+25−29
@@ -10,15 +10,16 @@ module Parse.Space
10 , checkAligned
10 , checkAligned
11 , checkFreshLine
11 , checkFreshLine
12 --
12 --
13− , DocComment(..)
14 , docComment
13 , docComment
15 )
14 )
16 where
15 where
17
16
18
17
19import Data.Word (Word8, Word16)
18import Data.Word (Word8, Word16)
20−import Foreign.Ptr (Ptr, plusPtr)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
21
21
22+import qualified AST.Source as Src
22import Parse.Primitives (Row, Col)
23import Parse.Primitives (Row, Col)
23import qualified Parse.Primitives as P
24import qualified Parse.Primitives as P
24import qualified Reporting.Annotation as A
25import qualified Reporting.Annotation as A
@@ -39,20 +40,19 @@ type Parser x a =
39
40
40chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()
41chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()
41chomp toError =
42chomp toError =
42− P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
43+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
43 let
44 let
44 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
45 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
45 in
46 in
46 case status of
47 case status of
47 Good ->
48 Good ->
48 let
49 let
49− !newState = P.State newPos end indent newRow newCol
50+ !newState = P.State src newPos end indent newRow newCol
50 in
51 in
51 cok () newState
52 cok () newState
52
53
53 HasTab -> cerr newRow newCol (toError E.HasTab)
54 HasTab -> cerr newRow newCol (toError E.HasTab)
54 EndlessMultiComment -> cerr newRow newCol (toError E.EndlessMultiComment)
55 EndlessMultiComment -> cerr newRow newCol (toError E.EndlessMultiComment)
55− UnexpectedDocComment -> cerr newRow newCol (toError E.UnexpectedDocComment)
56
56
57
57
58
58
@@ -61,7 +61,7 @@ chomp toError =
61
61
62checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x ()
62checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x ()
63checkIndent (A.Position endRow endCol) toError =
63checkIndent (A.Position endRow endCol) toError =
64− P.Parser $ \state@(P.State _ _ indent _ col) _ eok _ eerr ->
64+ P.Parser $ \state@(P.State _ _ _ indent _ col) _ eok _ eerr ->
65 if col > indent && col > 1
65 if col > indent && col > 1
66 then eok () state
66 then eok () state
67 else eerr endRow endCol toError
67 else eerr endRow endCol toError
@@ -69,7 +69,7 @@ checkIndent (A.Position endRow endCol) toError =
69
69
70checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x ()
70checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x ()
71checkAligned toError =
71checkAligned toError =
72− P.Parser $ \state@(P.State _ _ indent row col) _ eok _ eerr ->
72+ P.Parser $ \state@(P.State _ _ _ indent row col) _ eok _ eerr ->
73 if col == indent
73 if col == indent
74 then eok () state
74 then eok () state
75 else eerr row col (toError indent)
75 else eerr row col (toError indent)
@@ -77,7 +77,7 @@ checkAligned toError =
77
77
78checkFreshLine :: (Row -> Col -> x) -> P.Parser x ()
78checkFreshLine :: (Row -> Col -> x) -> P.Parser x ()
79checkFreshLine toError =
79checkFreshLine toError =
80− P.Parser $ \state@(P.State _ _ _ row col) _ eok _ eerr ->
80+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
81 if col == 1
81 if col == 1
82 then eok () state
82 then eok () state
83 else eerr row col toError
83 else eerr row col toError
@@ -89,7 +89,7 @@ checkFreshLine toError =
89
89
90chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x ()
90chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x ()
91chompAndCheckIndent toSpaceError toIndentError =
91chompAndCheckIndent toSpaceError toIndentError =
92− P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
92+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
93 let
93 let
94 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
94 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
95 in
95 in
@@ -99,7 +99,7 @@ chompAndCheckIndent toSpaceError toIndentError =
99 then
99 then
100
100
101 let
101 let
102− !newState = P.State newPos end indent newRow newCol
102+ !newState = P.State src newPos end indent newRow newCol
103 in
103 in
104 cok () newState
104 cok () newState
105
105
@@ -108,7 +108,6 @@ chompAndCheckIndent toSpaceError toIndentError =
108
108
109 HasTab -> cerr newRow newCol (toSpaceError E.HasTab)
109 HasTab -> cerr newRow newCol (toSpaceError E.HasTab)
110 EndlessMultiComment -> cerr newRow newCol (toSpaceError E.EndlessMultiComment)
110 EndlessMultiComment -> cerr newRow newCol (toSpaceError E.EndlessMultiComment)
111− UnexpectedDocComment -> cerr newRow newCol (toSpaceError E.UnexpectedDocComment)
112
111
113
112
114
113
@@ -119,7 +118,6 @@ data Status
119 = Good
118 = Good
120 | HasTab
119 | HasTab
121 | EndlessMultiComment
120 | EndlessMultiComment
122− | UnexpectedDocComment
123
121
124
122
125eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
123eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
@@ -159,7 +157,7 @@ eatSpaces pos end row col =
159-- LINE COMMENTS
157-- LINE COMMENTS
160
158
161
159
162−eatLineComment :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
160+eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
163eatLineComment pos end row col =
161eatLineComment pos end row col =
164 if pos >= end then
162 if pos >= end then
165 (# Good, pos, row, col #)
163 (# Good, pos, row, col #)
@@ -169,7 +167,7 @@ eatLineComment pos end row col =
169 if word == 0x0A {- \n -} then
167 if word == 0x0A {- \n -} then
170 eatSpaces (plusPtr pos 1) end (row + 1) 1
168 eatSpaces (plusPtr pos 1) end (row + 1) 1
171 else
169 else
172− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
170+ let !newPos = plusPtr pos (P.getCharWidth word) in
173 eatLineComment newPos end row (col + 1)
171 eatLineComment newPos end row (col + 1)
174
172
175
173
@@ -189,7 +187,7 @@ eatMultiComment pos end row col =
189 else if P.unsafeIndex pos1 == 0x2D {- - -} then
187 else if P.unsafeIndex pos1 == 0x2D {- - -} then
190
188
191 if P.unsafeIndex pos2 == 0x7C {- | -} then
189 if P.unsafeIndex pos2 == 0x7C {- | -} then
192− (# UnexpectedDocComment, pos, row, col #)
190+ (# Good, pos, row, col #)
193 else
191 else
194 let
192 let
195 (# status, newPos, newRow, newCol #) =
193 (# status, newPos, newRow, newCol #) =
@@ -210,7 +208,7 @@ data MultiStatus
210 | MultiEndless
208 | MultiEndless
211
209
212
210
213−eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Word16, Word16 #)
211+eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)
214eatMultiCommentHelp pos end row col openComments =
212eatMultiCommentHelp pos end row col openComments =
215 if pos >= end then
213 if pos >= end then
216 (# MultiEndless, pos, row, col #)
214 (# MultiEndless, pos, row, col #)
@@ -233,7 +231,7 @@ eatMultiCommentHelp pos end row col openComments =
233 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
231 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
234
232
235 else
233 else
236− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
234+ let !newPos = plusPtr pos (P.getCharWidth word) in
237 eatMultiCommentHelp newPos end row (col + 1) openComments
235 eatMultiCommentHelp newPos end row (col + 1) openComments
238
236
239
237
@@ -241,16 +239,9 @@ eatMultiCommentHelp pos end row col openComments =
241-- DOCUMENTATION COMMENT
239-- DOCUMENTATION COMMENT
242
240
243
241
244−data DocComment =
245− DocComment
246− { _start :: Ptr Word8
247− , _end :: Ptr Word8
248− }
249−
250−
251−docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x DocComment
242+docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment
252docComment toExpectation toSpaceError =
243docComment toExpectation toSpaceError =
253− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
244+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
254 let
245 let
255 !pos3 = plusPtr pos 3
246 !pos3 = plusPtr pos 3
256 in
247 in
@@ -260,14 +251,19 @@ docComment toExpectation toSpaceError =
260 && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
251 && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
261 then
252 then
262 let
253 let
254+ !col3 = col + 3
255+
263 (# status, newPos, newRow, newCol #) =
256 (# status, newPos, newRow, newCol #) =
264− eatMultiCommentHelp pos3 end row (col + 3) 1
257+ eatMultiCommentHelp pos3 end row col3 1
265 in
258 in
266 case status of
259 case status of
267 MultiGood ->
260 MultiGood ->
268 let
261 let
269− !comment = DocComment pos3 (plusPtr newPos (-2))
262+ !off = minusPtr pos3 (unsafeForeignPtrToPtr src)
263+ !len = minusPtr newPos pos3 - 2
264+ !snippet = P.Snippet src off len row col3
265+ !comment = Src.Comment snippet
270− !newState = P.State newPos end indent newRow newCol
266+ !newState = P.State src newPos end indent newRow newCol
271 in
267 in
272 cok comment newState
268 cok comment newState
273
269
compiler/src/Parse/Utf8.hs → compiler/src/Parse/String.hsrenamed+64−66
@@ -1,6 +1,6 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
2{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3−module Parse.Utf8
3+module Parse.String
4 ( string
4 ( string
5 , character
5 , character
6 )
6 )
@@ -11,6 +11,7 @@ import qualified Data.Utf8 as Utf8
11import Data.Word (Word8, Word16)
11import Data.Word (Word8, Word16)
12import Foreign.Ptr (Ptr, plusPtr, minusPtr)
12import Foreign.Ptr (Ptr, plusPtr, minusPtr)
13
13
14+import qualified Elm.String as ES
14import Parse.Primitives (Parser, Row, Col)
15import Parse.Primitives (Parser, Row, Col)
15import qualified Parse.Number as Number
16import qualified Parse.Number as Number
16import qualified Parse.Primitives as P
17import qualified Parse.Primitives as P
@@ -21,39 +22,39 @@ import qualified Reporting.Error.Syntax as E
21-- CHARACTER
22-- CHARACTER
22
23
23
24
24−character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x Utf8.String
25+character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x ES.String
25character toExpectation toError =
26character toExpectation toError =
26− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
27+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
27 if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then
28 if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then
28 eerr row col toExpectation
29 eerr row col toExpectation
29
30
30 else
31 else
31− case chompChar (plusPtr pos 1) end (col + 1) 0 placeholder of
32+ case chompChar (plusPtr pos 1) end row (col + 1) 0 placeholder of
32 Good newPos newCol numChars mostRecent ->
33 Good newPos newCol numChars mostRecent ->
33 if numChars /= 1 then
34 if numChars /= 1 then
34 cerr row col (toError (E.CharNotString (fromIntegral (newCol - col))))
35 cerr row col (toError (E.CharNotString (fromIntegral (newCol - col))))
35 else
36 else
36 let
37 let
37− !newState = P.State newPos end indent row newCol
38+ !newState = P.State src newPos end indent row newCol
38− !char = Utf8.fromChunks [mostRecent]
39+ !char = ES.fromChunks [mostRecent]
39 in
40 in
40 cok char newState
41 cok char newState
41
42
42 CharEndless newCol ->
43 CharEndless newCol ->
43 cerr row newCol (toError E.CharEndless)
44 cerr row newCol (toError E.CharEndless)
44
45
45− CharEscape newCol escape ->
46+ CharEscape r c escape ->
46− cerr row newCol (toError (E.CharEscape escape))
47+ cerr r c (toError (E.CharEscape escape))
47
48
48
49
49data CharResult
50data CharResult
50− = Good (Ptr Word8) Col Word16 Utf8.Chunk
51+ = Good (Ptr Word8) Col Word16 ES.Chunk
51 | CharEndless Col
52 | CharEndless Col
52− | CharEscape Col E.Escape
53+ | CharEscape Row Col E.Escape
53
54
54
55
55−chompChar :: Ptr Word8 -> Ptr Word8 -> Col -> Word16 -> Utf8.Chunk -> CharResult
56+chompChar :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> ES.Chunk -> CharResult
56−chompChar pos end col numChars mostRecent =
57+chompChar pos end row col numChars mostRecent =
57 if pos >= end then
58 if pos >= end then
58 CharEndless col
59 CharEndless col
59
60
@@ -68,37 +69,37 @@ chompChar pos end col numChars mostRecent =
68 CharEndless col
69 CharEndless col
69
70
70 else if word == 0x22 {- " -} then
71 else if word == 0x22 {- " -} then
71− chompChar (plusPtr pos 1) end (col + 1) (numChars + 1) doubleQuote
72+ chompChar (plusPtr pos 1) end row (col + 1) (numChars + 1) doubleQuote
72
73
73 else if word == 0x5C {- \ -} then
74 else if word == 0x5C {- \ -} then
74− case eatEscape (plusPtr pos 1) end col of
75+ case eatEscape (plusPtr pos 1) end row col of
75 EscapeNormal ->
76 EscapeNormal ->
76− chompChar (plusPtr pos 2) end (col + 2) (numChars + 1) (Utf8.Slice pos 2)
77+ chompChar (plusPtr pos 2) end row (col + 2) (numChars + 1) (ES.Slice pos 2)
77
78
78 EscapeUnicode delta code ->
79 EscapeUnicode delta code ->
79− chompChar (plusPtr pos delta) end (col + fromIntegral delta) (numChars + 1) (Utf8.CodePoint code)
80+ chompChar (plusPtr pos delta) end row (col + fromIntegral delta) (numChars + 1) (ES.CodePoint code)
80
81
81− EscapeProblem badEscape ->
82+ EscapeProblem r c badEscape ->
82− CharEscape col badEscape
83+ CharEscape r c badEscape
83
84
84 EscapeEndOfFile ->
85 EscapeEndOfFile ->
85 CharEndless col
86 CharEndless col
86
87
87 else
88 else
88 let
89 let
89− !width = P.getCharWidth pos end word
90+ !width = P.getCharWidth word
90 !newPos = plusPtr pos width
91 !newPos = plusPtr pos width
91 in
92 in
92− chompChar newPos end (col + 1) (numChars + 1) (Utf8.Slice pos width)
93+ chompChar newPos end row (col + 1) (numChars + 1) (ES.Slice pos width)
93
94
94
95
95
96
96-- STRINGS
97-- STRINGS
97
98
98
99
99−string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x Utf8.String
100+string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x ES.String
100string toExpectation toError =
101string toExpectation toError =
101− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
102+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
102 if isDoubleQuote pos end then
103 if isDoubleQuote pos end then
103
104
104 let
105 let
@@ -121,7 +122,7 @@ string toExpectation toError =
121 Ok newPos newRow newCol utf8 ->
122 Ok newPos newRow newCol utf8 ->
122 let
123 let
123 !newState =
124 !newState =
124− P.State newPos end indent newRow newCol
125+ P.State src newPos end indent newRow newCol
125 in
126 in
126 cok utf8 newState
127 cok utf8 newState
127
128
@@ -139,32 +140,32 @@ isDoubleQuote pos end =
139
140
140
141
141data StringResult
142data StringResult
142− = Ok (Ptr Word8) Row Col !Utf8.String
143+ = Ok (Ptr Word8) Row Col !ES.String
143 | Err Row Col E.String
144 | Err Row Col E.String
144
145
145
146
146−finalize :: Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> Utf8.String
147+finalize :: Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> ES.String
147finalize start end revChunks =
148finalize start end revChunks =
148− Utf8.fromChunks $ reverse $
149+ ES.fromChunks $ reverse $
149 if start == end then
150 if start == end then
150 revChunks
151 revChunks
151 else
152 else
152− Utf8.Slice start (minusPtr end start) : revChunks
153+ ES.Slice start (minusPtr end start) : revChunks
153
154
154
155
155−addEscape :: Utf8.Chunk -> Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> [Utf8.Chunk]
156+addEscape :: ES.Chunk -> Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> [ES.Chunk]
156addEscape chunk start end revChunks =
157addEscape chunk start end revChunks =
157 if start == end then
158 if start == end then
158 chunk : revChunks
159 chunk : revChunks
159 else
160 else
160− chunk : Utf8.Slice start (minusPtr end start) : revChunks
161+ chunk : ES.Slice start (minusPtr end start) : revChunks
161
162
162
163
163
164
164-- SINGLE STRINGS
165-- SINGLE STRINGS
165
166
166
167
167−singleString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Utf8.Chunk] -> StringResult
168+singleString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [ES.Chunk] -> StringResult
168singleString pos end row col initialPos revChunks =
169singleString pos end row col initialPos revChunks =
169 if pos >= end then
170 if pos >= end then
170 Err row col E.StringEndless_Single
171 Err row col E.StringEndless_Single
@@ -186,23 +187,23 @@ singleString pos end row col initialPos revChunks =
186 addEscape singleQuote initialPos pos revChunks
187 addEscape singleQuote initialPos pos revChunks
187
188
188 else if word == 0x5C {- \ -} then
189 else if word == 0x5C {- \ -} then
189− case eatEscape (plusPtr pos 1) end col of
190+ case eatEscape (plusPtr pos 1) end row col of
190 EscapeNormal ->
191 EscapeNormal ->
191 singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks
192 singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks
192
193
193 EscapeUnicode delta code ->
194 EscapeUnicode delta code ->
194 let !newPos = plusPtr pos delta in
195 let !newPos = plusPtr pos delta in
195 singleString newPos end row (col + fromIntegral delta) newPos $
196 singleString newPos end row (col + fromIntegral delta) newPos $
196− addEscape (Utf8.CodePoint code) initialPos pos revChunks
197+ addEscape (ES.CodePoint code) initialPos pos revChunks
197
198
198− EscapeProblem x ->
199+ EscapeProblem r c x ->
199− Err row col (E.StringEscape x)
200+ Err r c (E.StringEscape x)
200
201
201 EscapeEndOfFile ->
202 EscapeEndOfFile ->
202 Err row (col + 1) E.StringEndless_Single
203 Err row (col + 1) E.StringEndless_Single
203
204
204 else
205 else
205− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
206+ let !newPos = plusPtr pos (P.getCharWidth word) in
206 singleString newPos end row (col + 1) initialPos revChunks
207 singleString newPos end row (col + 1) initialPos revChunks
207
208
208
209
@@ -210,7 +211,7 @@ singleString pos end row col initialPos revChunks =
210-- MULTI STRINGS
211-- MULTI STRINGS
211
212
212
213
213−multiString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> Word16 -> Word16 -> [Utf8.Chunk] -> StringResult
214+multiString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> Row -> Col -> [ES.Chunk] -> StringResult
214multiString pos end row col initialPos sr sc revChunks =
215multiString pos end row col initialPos sr sc revChunks =
215 if pos >= end then
216 if pos >= end then
216 Err sr sc E.StringEndless_Multi
217 Err sr sc E.StringEndless_Multi
@@ -237,23 +238,23 @@ multiString pos end row col initialPos sr sc revChunks =
237 addEscape carriageReturn initialPos pos revChunks
238 addEscape carriageReturn initialPos pos revChunks
238
239
239 else if word == 0x5C {- \ -} then
240 else if word == 0x5C {- \ -} then
240− case eatEscape (plusPtr pos 1) end col of
241+ case eatEscape (plusPtr pos 1) end row col of
241 EscapeNormal ->
242 EscapeNormal ->
242 multiString (plusPtr pos 2) end row (col + 2) initialPos sr sc revChunks
243 multiString (plusPtr pos 2) end row (col + 2) initialPos sr sc revChunks
243
244
244 EscapeUnicode delta code ->
245 EscapeUnicode delta code ->
245 let !newPos = plusPtr pos delta in
246 let !newPos = plusPtr pos delta in
246 multiString newPos end row (col + fromIntegral delta) newPos sr sc $
247 multiString newPos end row (col + fromIntegral delta) newPos sr sc $
247− addEscape (Utf8.CodePoint code) initialPos pos revChunks
248+ addEscape (ES.CodePoint code) initialPos pos revChunks
248
249
249− EscapeProblem x ->
250+ EscapeProblem r c x ->
250− Err row col (E.StringEscape x)
251+ Err r c (E.StringEscape x)
251
252
252 EscapeEndOfFile ->
253 EscapeEndOfFile ->
253 Err sr sc E.StringEndless_Multi
254 Err sr sc E.StringEndless_Multi
254
255
255 else
256 else
256− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
257+ let !newPos = plusPtr pos (P.getCharWidth word) in
257 multiString newPos end row (col + 1) initialPos sr sc revChunks
258 multiString newPos end row (col + 1) initialPos sr sc revChunks
258
259
259
260
@@ -265,11 +266,11 @@ data Escape
265 = EscapeNormal
266 = EscapeNormal
266 | EscapeUnicode !Int !Int
267 | EscapeUnicode !Int !Int
267 | EscapeEndOfFile
268 | EscapeEndOfFile
268− | EscapeProblem E.Escape
269+ | EscapeProblem Row Col E.Escape
269
270
270
271
271−eatEscape :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
272+eatEscape :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
272−eatEscape pos end startCol =
273+eatEscape pos end row col =
273 if pos >= end then
274 if pos >= end then
274 EscapeEndOfFile
275 EscapeEndOfFile
275
276
@@ -281,14 +282,14 @@ eatEscape pos end startCol =
281 0x22 {- " -} -> EscapeNormal
282 0x22 {- " -} -> EscapeNormal
282 0x27 {- ' -} -> EscapeNormal
283 0x27 {- ' -} -> EscapeNormal
283 0x5C {- \ -} -> EscapeNormal
284 0x5C {- \ -} -> EscapeNormal
284− 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end startCol
285+ 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end row col
285− _ -> EscapeProblem (E.EscapeUnknown startCol (startCol + 1))
286+ _ -> EscapeProblem row col E.EscapeUnknown
286
287
287
288
288−eatUnicode :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
289+eatUnicode :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
289−eatUnicode pos end startCol =
290+eatUnicode pos end row col =
290 if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then
291 if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then
291− EscapeProblem $ E.BadUnicodeFormat startCol (startCol + 1)
292+ EscapeProblem row col (E.BadUnicodeFormat 2)
292 else
293 else
293 let
294 let
294 !digitPos = plusPtr pos 1
295 !digitPos = plusPtr pos 1
@@ -296,18 +297,15 @@ eatUnicode pos end startCol =
296 !numDigits = minusPtr newPos digitPos
297 !numDigits = minusPtr newPos digitPos
297 in
298 in
298 if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then
299 if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then
299− EscapeProblem $ E.BadUnicodeFormat startCol $
300+ EscapeProblem row col $ E.BadUnicodeFormat (2 + fromIntegral (minusPtr newPos pos))
300− startCol + fromIntegral (minusPtr newPos pos)
301
301
302 else if code < 0 || 0x10FFFF < code then
302 else if code < 0 || 0x10FFFF < code then
303− EscapeProblem $ E.BadUnicodeCode startCol $
303+ EscapeProblem row col $ E.BadUnicodeCode (3 + fromIntegral (minusPtr newPos pos))
304− startCol + fromIntegral (minusPtr newPos pos) + 1
305
304
306 else if numDigits < 4 || 6 < numDigits then
305 else if numDigits < 4 || 6 < numDigits then
307− EscapeProblem $
306+ EscapeProblem row col $
308 E.BadUnicodeLength
307 E.BadUnicodeLength
309− startCol
310− (startCol + fromIntegral (minusPtr newPos pos) + 1)
308+ (3 + fromIntegral (minusPtr newPos pos))
311 numDigits
309 numDigits
312 code
310 code
313
311
@@ -316,30 +314,30 @@ eatUnicode pos end startCol =
316
314
317
315
318{-# NOINLINE singleQuote #-}
316{-# NOINLINE singleQuote #-}
319−singleQuote :: Utf8.Chunk
317+singleQuote :: ES.Chunk
320singleQuote =
318singleQuote =
321− Utf8.Escape 0x27 {- ' -}
319+ ES.Escape 0x27 {-'-}
322
320
323
321
324{-# NOINLINE doubleQuote #-}
322{-# NOINLINE doubleQuote #-}
325−doubleQuote :: Utf8.Chunk
323+doubleQuote :: ES.Chunk
326doubleQuote =
324doubleQuote =
327− Utf8.Escape 0x22 {- " -}
325+ ES.Escape 0x22 {-"-}
328
326
329
327
330{-# NOINLINE newline #-}
328{-# NOINLINE newline #-}
331−newline :: Utf8.Chunk
329+newline :: ES.Chunk
332newline =
330newline =
333− Utf8.Escape 0x6E {- n -}
331+ ES.Escape 0x6E {-n-}
334
332
335
333
336{-# NOINLINE carriageReturn #-}
334{-# NOINLINE carriageReturn #-}
337−carriageReturn :: Utf8.Chunk
335+carriageReturn :: ES.Chunk
338carriageReturn =
336carriageReturn =
339− Utf8.Escape 0x72 {- \r -}
337+ ES.Escape 0x72 {-r-}
340
338
341
339
342{-# NOINLINE placeholder #-}
340{-# NOINLINE placeholder #-}
343−placeholder :: Utf8.Chunk
341+placeholder :: ES.Chunk
344placeholder =
342placeholder =
345− Utf8.CodePoint 0xFFFD {- replacement character -}
343+ ES.CodePoint 0xFFFD {-replacement character-}
compiler/src/Parse/Symbol.hs+19−34
@@ -1,8 +1,9 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3module Parse.Symbol
3module Parse.Symbol
4− ( wildcard
5− , operator
4+ ( operator
5+ , BadOperator(..)
6+ , binopCharSet
6 )
7 )
7 where
8 where
8
9
@@ -15,55 +16,39 @@ import Foreign.Ptr (Ptr, plusPtr, minusPtr)
15import GHC.Word (Word8)
16import GHC.Word (Word8)
16
17
17import Parse.Primitives (Parser, Row, Col)
18import Parse.Primitives (Parser, Row, Col)
18−import qualified Parse.Variable as Var
19import qualified Parse.Primitives as P
19import qualified Parse.Primitives as P
20−import qualified Reporting.Error.Syntax as E
21
20
22
21
23
22
24−-- UNDERSCORE
23+-- OPERATOR
25−
26−
27−wildcard :: Parser E.Pattern ()
28−wildcard =
29− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
30− if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
31− eerr row col E.PStart
32− else
33− let
34− !newPos = plusPtr pos 1
35− !newCol = col + 1
36− in
37− if Var.getInnerWidth newPos end > 0 then
38− let (# _, badCol #) = Var.chompInnerChars newPos end newCol in
39− cerr row col (E.PWildcardNotVar (fromIntegral (badCol - col)))
40− else
41− let !newState = P.State newPos end indent row newCol in
42− cok () newState
43−
44
24
45
25
46−-- OPERATOR
26+data BadOperator
27+ = BadDot
28+ | BadPipe
29+ | BadArrow
30+ | BadEquals
31+ | BadHasType
47
32
48
33
49−operator :: (Row -> Col -> x) -> (E.Operator -> Row -> Col -> x) -> Parser x Name.Name
34+operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name
50operator toExpectation toError =
35operator toExpectation toError =
51− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
36+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
52 let !newPos = chompOps pos end in
37 let !newPos = chompOps pos end in
53 if pos == newPos then
38 if pos == newPos then
54 eerr row col toExpectation
39 eerr row col toExpectation
55
40
56 else
41 else
57 case Name.fromPtr pos newPos of
42 case Name.fromPtr pos newPos of
58− "." -> cerr row col (toError E.OpDot)
43+ "." -> eerr row col (toError BadDot)
59− "|" -> cerr row col (toError E.OpPipe)
44+ "|" -> cerr row col (toError BadPipe)
60− "->" -> cerr row col (toError E.OpArrow)
45+ "->" -> cerr row col (toError BadArrow)
61− "=" -> cerr row col (toError E.OpEquals)
46+ "=" -> cerr row col (toError BadEquals)
62− ":" -> cerr row col (toError E.OpHasType)
47+ ":" -> cerr row col (toError BadHasType)
63 op ->
48 op ->
64 let
49 let
65 !newCol = col + fromIntegral (minusPtr newPos pos)
50 !newCol = col + fromIntegral (minusPtr newPos pos)
66− !newState = P.State newPos end indent row newCol
51+ !newState = P.State src newPos end indent row newCol
67 in
52 in
68 cok op newState
53 cok op newState
69
54
compiler/src/Parse/Type.hs+3−3
@@ -47,7 +47,7 @@ term =
47 oneOf E.TTupleOpen
47 oneOf E.TTupleOpen
48 [ do word1 0x29 {-)-} E.TTupleOpen
48 [ do word1 0x29 {-)-} E.TTupleOpen
49 addEnd start Src.TUnit
49 addEnd start Src.TUnit
50− , do Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType
50+ , do Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType1
51 (tipe, end) <- specialize E.TTupleType expression
51 (tipe, end) <- specialize E.TTupleType expression
52 Space.checkIndent end E.TTupleIndentEnd
52 Space.checkIndent end E.TTupleIndentEnd
53 chompTupleEnd start tipe []
53 chompTupleEnd start tipe []
@@ -95,7 +95,7 @@ expression =
95 ]
95 ]
96 oneOfWithFallback
96 oneOfWithFallback
97 [ do Space.checkIndent end1 E.TIndentStart -- should never trigger
97 [ do Space.checkIndent end1 E.TIndentStart -- should never trigger
98− word2 0x2D 0x3E {-->-} E.TArrow
98+ word2 0x2D 0x3E {-->-} E.TStart -- could just be another type instead
99 Space.chompAndCheckIndent E.TSpace E.TIndentStart
99 Space.chompAndCheckIndent E.TSpace E.TIndentStart
100 (tipe2, end2) <- expression
100 (tipe2, end2) <- expression
101 let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
101 let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
@@ -147,7 +147,7 @@ chompTupleEnd :: A.Position -> Src.Type -> [Src.Type] -> Parser E.TTuple Src.Typ
147chompTupleEnd start firstType revTypes =
147chompTupleEnd start firstType revTypes =
148 oneOf E.TTupleEnd
148 oneOf E.TTupleEnd
149 [ do word1 0x2C {-,-} E.TTupleEnd
149 [ do word1 0x2C {-,-} E.TTupleEnd
150− Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType
150+ Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentTypeN
151 (tipe, end) <- specialize E.TTupleType expression
151 (tipe, end) <- specialize E.TTupleType expression
152 Space.checkIndent end E.TTupleIndentEnd
152 Space.checkIndent end E.TTupleIndentEnd
153 chompTupleEnd start firstType (tipe : revTypes)
153 chompTupleEnd start firstType (tipe : revTypes)
compiler/src/Parse/Variable.hs+30−23
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3module Parse.Variable
3module Parse.Variable
4 ( lower
4 ( lower
5 , upper
5 , upper
@@ -8,8 +8,10 @@ module Parse.Variable
8 , foreignUpper
8 , foreignUpper
9 , foreignAlpha
9 , foreignAlpha
10 , chompInnerChars
10 , chompInnerChars
11+ , getUpperWidth
11 , getInnerWidth
12 , getInnerWidth
12 , getInnerWidthHelp
13 , getInnerWidthHelp
14+ , reservedWords
13 )
15 )
14 where
16 where
15
17
@@ -33,13 +35,13 @@ import qualified Parse.Primitives as P
33
35
34upper :: (Row -> Col -> x) -> Parser x Name.Name
36upper :: (Row -> Col -> x) -> Parser x Name.Name
35upper toError =
37upper toError =
36− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
38+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
37 let (# newPos, newCol #) = chompUpper pos end col in
39 let (# newPos, newCol #) = chompUpper pos end col in
38 if pos == newPos then
40 if pos == newPos then
39 eerr row col toError
41 eerr row col toError
40 else
42 else
41 let !name = Name.fromPtr pos newPos in
43 let !name = Name.fromPtr pos newPos in
42− cok name (P.State newPos end indent row newCol)
44+ cok name (P.State src newPos end indent row newCol)
43
45
44
46
45
47
@@ -48,7 +50,7 @@ upper toError =
48
50
49lower :: (Row -> Col -> x) -> Parser x Name.Name
51lower :: (Row -> Col -> x) -> Parser x Name.Name
50lower toError =
52lower toError =
51− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
53+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
52 let (# newPos, newCol #) = chompLower pos end col in
54 let (# newPos, newCol #) = chompLower pos end col in
53 if pos == newPos then
55 if pos == newPos then
54 eerr row col toError
56 eerr row col toError
@@ -59,13 +61,13 @@ lower toError =
59 else
61 else
60 let
62 let
61 !newState =
63 !newState =
62− P.State newPos end indent row newCol
64+ P.State src newPos end indent row newCol
63 in
65 in
64 cok name newState
66 cok name newState
65
67
66
68
67{-# NOINLINE reservedWords #-}
69{-# NOINLINE reservedWords #-}
68−reservedWords :: Set.Set Name.Name -- TODO try using a trie instead
70+reservedWords :: Set.Set Name.Name -- PERF try using a trie instead
69reservedWords =
71reservedWords =
70 Set.fromList
72 Set.fromList
71 [ "if", "then", "else"
73 [ "if", "then", "else"
@@ -85,21 +87,26 @@ reservedWords =
85
87
86moduleName :: (Row -> Col -> x) -> Parser x Name.Name
88moduleName :: (Row -> Col -> x) -> Parser x Name.Name
87moduleName toError =
89moduleName toError =
88− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
90+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
89 let
91 let
90 (# pos1, col1 #) = chompUpper pos end col
92 (# pos1, col1 #) = chompUpper pos end col
91− (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
92 in
93 in
94+ if pos == pos1 then
95+ eerr row col toError
96+ else
97+ let
98+ (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
99+ in
93− case status of
100+ case status of
94− Good ->
101+ Good ->
95− let
102+ let
96− !name = Name.fromPtr pos newPos
103+ !name = Name.fromPtr pos newPos
97− !newState = P.State newPos end indent row newCol
104+ !newState = P.State src newPos end indent row newCol
98− in
105+ in
99− cok name newState
106+ cok name newState
100
107
101− Bad ->
108+ Bad ->
102− eerr row newCol toError
109+ cerr row newCol toError
103
110
104
111
105data ModuleNameStatus
112data ModuleNameStatus
@@ -134,22 +141,22 @@ data Upper
134
141
135foreignUpper :: (Row -> Col -> x) -> Parser x Upper
142foreignUpper :: (Row -> Col -> x) -> Parser x Upper
136foreignUpper toError =
143foreignUpper toError =
137− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
144+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
138 let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
145 let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
139 if upperStart == upperEnd then
146 if upperStart == upperEnd then
140 eerr row newCol toError
147 eerr row newCol toError
141 else
148 else
142 let
149 let
143− !newState = P.State upperEnd end indent row newCol
150+ !newState = P.State src upperEnd end indent row newCol
144 !name = Name.fromPtr upperStart upperEnd
151 !name = Name.fromPtr upperStart upperEnd
145− !foreign =
152+ !upperName =
146 if upperStart == pos then
153 if upperStart == pos then
147 Unqualified name
154 Unqualified name
148 else
155 else
149 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
156 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
150 Qualified home name
157 Qualified home name
151 in
158 in
152− cok foreign newState
159+ cok upperName newState
153
160
154
161
155foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
162foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
@@ -173,13 +180,13 @@ foreignUpperHelp pos end col =
173
180
174foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_
181foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_
175foreignAlpha toError =
182foreignAlpha toError =
176− P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
183+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
177 let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
184 let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
178 if alphaStart == alphaEnd then
185 if alphaStart == alphaEnd then
179 eerr row newCol toError
186 eerr row newCol toError
180 else
187 else
181 let
188 let
182− !newState = P.State alphaEnd end indent row newCol
189+ !newState = P.State src alphaEnd end indent row newCol
183 !name = Name.fromPtr alphaStart alphaEnd
190 !name = Name.fromPtr alphaStart alphaEnd
184 in
191 in
185 if alphaStart == pos then
192 if alphaStart == pos then
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+46−44
@@ -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,11 +39,10 @@ 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− , _localizer :: L.Localizer
47 }
46 }
48
47
49
48
@@ -55,60 +54,65 @@ data Error
55 = BadSyntax Syntax.Error
54 = BadSyntax Syntax.Error
56 | BadImports (NE.List Import.Error)
55 | BadImports (NE.List Import.Error)
57 | BadNames (OneOrMore.OneOrMore Canonicalize.Error)
56 | BadNames (OneOrMore.OneOrMore Canonicalize.Error)
58− | BadTypes (NE.List Type.Error)
57+ | BadTypes L.Localizer (NE.List Type.Error)
58+ | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error)
59 | BadPatterns (NE.List Pattern.Error)
59 | BadPatterns (NE.List Pattern.Error)
60− | BadMains (OneOrMore.OneOrMore Main.Error)
60+ | BadDocs Docs.Error
61
61
62
62
63
63
64-- TO REPORT
64-- TO REPORT
65
65
66
66
67−toReports :: L.Localizer -> Code.Source -> Error -> NE.List Report.Report
67+toReports :: Code.Source -> Error -> NE.List Report.Report
68−toReports localizer source err =
68+toReports source err =
69 case err of
69 case err of
70 BadSyntax syntaxError ->
70 BadSyntax syntaxError ->
71 NE.List (Syntax.toReport source syntaxError) []
71 NE.List (Syntax.toReport source syntaxError) []
72
72
73 BadImports errs ->
73 BadImports errs ->
74− fmap Import.toReport errs
74+ fmap (Import.toReport source) errs
75
75
76 BadNames errs ->
76 BadNames errs ->
77 fmap (Canonicalize.toReport source) (OneOrMore.destruct NE.List errs)
77 fmap (Canonicalize.toReport source) (OneOrMore.destruct NE.List errs)
78
78
79− BadTypes errs ->
79+ BadTypes localizer errs ->
80 fmap (Type.toReport source localizer) errs
80 fmap (Type.toReport source localizer) errs
81
81
82+ BadMains localizer errs ->
83+ fmap (Main.toReport localizer source) (OneOrMore.destruct NE.List errs)
84+
82 BadPatterns errs ->
85 BadPatterns errs ->
83 fmap (Pattern.toReport source) errs
86 fmap (Pattern.toReport source) errs
84
87
85− BadMains errs ->
88+ BadDocs docsErr ->
86− fmap (Main.toReport localizer source) (OneOrMore.destruct NE.List errs)
89+ Docs.toReports source docsErr
87
90
88
91
89
92
90-- TO DOC
93-- TO DOC
91
94
92
95
93−toDoc :: NE.List Module -> D.Doc
96+toDoc :: FilePath -> Module -> [Module] -> D.Doc
94−toDoc modules =
97+toDoc root err errs =
95 let
98 let
96− timeCompare m1 m2 = compare (_time m1) (_time m2)
97− (NE.List m ms) = NE.sortBy timeCompare modules
99+ (NE.List m ms) = NE.sortBy _modificationTime (NE.List err errs)
98 in
100 in
99− D.vcat (toDocHelp m ms)
101+ D.vcat (toDocHelp root m ms)
100
102
101
103
102−toDocHelp :: Module -> [Module] -> [D.Doc]
104+toDocHelp :: FilePath -> Module -> [Module] -> [D.Doc]
103−toDocHelp module1 modules =
105+toDocHelp root module1 modules =
104 case modules of
106 case modules of
105 [] ->
107 [] ->
106− [moduleToDoc module1]
108+ [moduleToDoc root module1
109+ ,""
110+ ]
107
111
108 module2 : otherModules ->
112 module2 : otherModules ->
109− moduleToDoc module1
113+ moduleToDoc root module1
110 : toSeparator module1 module2
114 : toSeparator module1 module2
111− : toDocHelp module2 otherModules
115+ : toDocHelp root module2 otherModules
112
116
113
117
114toSeparator :: Module -> Module -> D.Doc
118toSeparator :: Module -> Module -> D.Doc
@@ -130,19 +134,22 @@ toSeparator beforeModule afterModule =
130-- MODULE TO DOC
134-- MODULE TO DOC
131
135
132
136
133−moduleToDoc :: Module -> D.Doc
137+moduleToDoc :: FilePath -> Module -> D.Doc
134−moduleToDoc (Module _ path _ source err localizer) =
138+moduleToDoc root (Module _ absolutePath _ source err) =
135 let
139 let
136 reports =
140 reports =
137− toReports localizer (Code.toSource source) err
141+ toReports (Code.toSource source) err
142+
143+ relativePath =
144+ FP.makeRelative root absolutePath
138 in
145 in
139− D.vcat $ map (reportToDoc path) (NE.toList reports)
146+ D.vcat $ map (reportToDoc relativePath) (NE.toList reports)
140
147
141
148
142reportToDoc :: FilePath -> Report.Report -> D.Doc
149reportToDoc :: FilePath -> Report.Report -> D.Doc
143−reportToDoc path (Report.Report title _ _ message) =
150+reportToDoc relativePath (Report.Report title _ _ message) =
144 D.vcat
151 D.vcat
145− [ toMessageBar title path
152+ [ toMessageBar title relativePath
146 , ""
153 , ""
147 , message
154 , message
148 , ""
155 , ""
@@ -165,20 +172,15 @@ toMessageBar title filePath =
165-- TO JSON
172-- TO JSON
166
173
167
174
168−toJson :: NE.List Module -> E.Value
175+toJson :: Module -> E.Value
169−toJson modules =
170− E.array (map moduleToJson (NE.toList modules))
171−
172−
173−moduleToJson :: Module -> E.Value
174−moduleToJson (Module name path _ source err localizer) =
176+toJson (Module name path _ source err) =
175 let
177 let
176 reports =
178 reports =
177− toReports localizer (Code.toSource source) err
179+ toReports (Code.toSource source) err
178 in
180 in
179 E.object
181 E.object
180− [ "path" ==> E.string (Utf8.fromChars path)
182+ [ "path" ==> E.chars path
181− , "name" ==> E.string (Name.toUtf8 name)
183+ , "name" ==> E.name name
182 , "problems" ==> E.array (map reportToJson (NE.toList reports))
184 , "problems" ==> E.array (map reportToJson (NE.toList reports))
183 ]
185 ]
184
186
@@ -186,7 +188,7 @@ moduleToJson (Module name path _ source err localizer) =
186reportToJson :: Report.Report -> E.Value
188reportToJson :: Report.Report -> E.Value
187reportToJson (Report.Report title region _sgstns message) =
189reportToJson (Report.Report title region _sgstns message) =
188 E.object
190 E.object
189− [ "title" ==> E.string (Utf8.fromChars title)
191+ [ "title" ==> E.chars title
190 , "region" ==> encodeRegion region
192 , "region" ==> encodeRegion region
191 , "message" ==> D.encode message
193 , "message" ==> D.encode message
192 ]
194 ]
@@ -197,12 +199,12 @@ encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
197 E.object
199 E.object
198 [ "start" ==>
200 [ "start" ==>
199 E.object
201 E.object
200− [ ("line", E.int (fromIntegral sr))
202+ [ "line" ==> E.int (fromIntegral sr)
201− , ("column", E.int (fromIntegral sc))
203+ , "column" ==> E.int (fromIntegral sc)
202 ]
204 ]
203 , "end" ==>
205 , "end" ==>
204 E.object
206 E.object
205− [ ("line", E.int (fromIntegral er))
207+ [ "line" ==> E.int (fromIntegral er)
206− , ("column", E.int (fromIntegral ec))
208+ , "column" ==> E.int (fromIntegral ec)
207 ]
209 ]
208 ]
210 ]
compiler/src/Reporting/Error/Canonicalize.hs+74−73
@@ -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
@@ -151,7 +153,7 @@ toReport source err =
151 numDefArgs = numTypeArgs + leftovers
153 numDefArgs = numTypeArgs + leftovers
152 in
154 in
153 Report.Report "BAD TYPE ANNOTATION" region [] $
155 Report.Report "BAD TYPE ANNOTATION" region [] $
154− Report.toCodeSnippet source region Nothing
156+ Code.toSnippet source region Nothing
155 (
157 (
156 D.reflow $
158 D.reflow $
157 "The type annotation for `" <> Name.toChars name <> "` says it can accept "
159 "The type annotation for `" <> Name.toChars name <> "` says it can accept "
@@ -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
@@ -185,7 +187,7 @@ toReport source err =
185 in
187 in
186 if actual < expected then
188 if actual < expected then
187 Report.Report "TOO FEW ARGS" region [] $
189 Report.Report "TOO FEW ARGS" region [] $
188− Report.toCodeSnippet source region Nothing
190+ Code.toSnippet source region Nothing
189 (
191 (
190 D.reflow $
192 D.reflow $
191 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
193 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
@@ -197,7 +199,7 @@ toReport source err =
197
199
198 else
200 else
199 Report.Report "TOO MANY ARGS" region [] $
201 Report.Report "TOO MANY ARGS" region [] $
200− Report.toCodeSnippet source region Nothing
202+ Code.toSnippet source region Nothing
201 (
203 (
202 D.reflow $
204 D.reflow $
203 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
205 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
@@ -211,7 +213,7 @@ toReport source err =
211
213
212 Binop region op1 op2 ->
214 Binop region op1 op2 ->
213 Report.Report "INFIX PROBLEM" region [] $
215 Report.Report "INFIX PROBLEM" region [] $
214− Report.toCodeSnippet source region Nothing
216+ Code.toSnippet source region Nothing
215 (
217 (
216 D.reflow $
218 D.reflow $
217 "You cannot mix (" <> Name.toChars op1 <> ") and (" <> Name.toChars op2 <> ") without parentheses."
219 "You cannot mix (" <> Name.toChars op1 <> ") and (" <> Name.toChars op2 <> ") without parentheses."
@@ -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 $
@@ -268,18 +270,18 @@ toReport source err =
268
270
269 EffectNotFound region name ->
271 EffectNotFound region name ->
270 Report.Report "EFFECT PROBLEM" region [] $
272 Report.Report "EFFECT PROBLEM" region [] $
271− Report.toCodeSnippet source region Nothing
273+ Code.toSnippet source region Nothing
272 (
274 (
273 D.reflow $
275 D.reflow $
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 ->
281 Report.Report "EFFECT PROBLEM" region [] $
283 Report.Report "EFFECT PROBLEM" region [] $
282− Report.toCodeSnippet source region Nothing
284+ Code.toSnippet source region Nothing
283 (
285 (
284 D.reflow $
286 D.reflow $
285 "This kind of effect module must define a `" ++ Name.toChars name ++ "` function."
287 "This kind of effect module must define a `" ++ Name.toChars name ++ "` function."
@@ -295,7 +297,7 @@ toReport source err =
295 "You are trying to expose `" <> Name.toChars name <> "` multiple times!"
297 "You are trying to expose `" <> Name.toChars name <> "` multiple times!"
296 in
298 in
297 Report.Report "REDUNDANT EXPORT" r2 [] $
299 Report.Report "REDUNDANT EXPORT" r2 [] $
298− Report.toCodePair source r1 r2
300+ Code.toPair source r1 r2
299 (
301 (
300 D.reflow messageThatEndsWithPunctuation
302 D.reflow messageThatEndsWithPunctuation
301 ,
303 ,
@@ -339,10 +341,10 @@ toReport source err =
339
341
340 ExportOpenAlias region name ->
342 ExportOpenAlias region name ->
341 Report.Report "BAD EXPORT" region [] $
343 Report.Report "BAD EXPORT" region [] $
342− Report.toCodeSnippet 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 $
@@ -351,16 +353,16 @@ toReport source err =
351
353
352 ImportCtorByName region ctor tipe ->
354 ImportCtorByName region ctor tipe ->
353 Report.Report "BAD IMPORT" region [] $
355 Report.Report "BAD IMPORT" region [] $
354− Report.toCodeSnippet source region Nothing
356+ Code.toSnippet source region Nothing
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 )
@@ -371,7 +373,7 @@ toReport source err =
371 -- So this error should never actually get printed out.
373 -- So this error should never actually get printed out.
372 --
374 --
373 Report.Report "UNKNOWN IMPORT" region [] $
375 Report.Report "UNKNOWN IMPORT" region [] $
374− Report.toCodeSnippet source region Nothing
376+ Code.toSnippet source region Nothing
375 (
377 (
376 D.reflow $
378 D.reflow $
377 "I could not find a `" <> Name.toChars name <> "` module to import!"
379 "I could not find a `" <> Name.toChars name <> "` module to import!"
@@ -381,18 +383,13 @@ toReport source err =
381
383
382 ImportOpenAlias region name ->
384 ImportOpenAlias region name ->
383 Report.Report "BAD IMPORT" region [] $
385 Report.Report "BAD IMPORT" region [] $
384− Report.toCodeSnippet source region Nothing
386+ Code.toSnippet source region Nothing
385 (
387 (
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 ->
@@ -402,7 +399,7 @@ toReport source err =
402 Suggest.sort (Name.toChars home) Name.toChars possibleNames
399 Suggest.sort (Name.toChars home) Name.toChars possibleNames
403 in
400 in
404 Report.Report "BAD IMPORT" region suggestions $
401 Report.Report "BAD IMPORT" region suggestions $
405− Report.toCodeSnippet source region Nothing
402+ Code.toSnippet source region Nothing
406 (
403 (
407 D.reflow $
404 D.reflow $
408 "The `" <> Name.toChars home
405 "The `" <> Name.toChars home
@@ -435,7 +432,7 @@ toReport source err =
435 NotFoundBinop region op locals ->
432 NotFoundBinop region op locals ->
436 if op == "===" then
433 if op == "===" then
437 Report.Report "UNKNOWN OPERATOR" region ["=="] $
434 Report.Report "UNKNOWN OPERATOR" region ["=="] $
438− Report.toCodeSnippet source region Nothing
435+ Code.toSnippet source region Nothing
439 (
436 (
440 "Elm does not have a (===) operator like JavaScript."
437 "Elm does not have a (===) operator like JavaScript."
441 ,
438 ,
@@ -444,7 +441,7 @@ toReport source err =
444
441
445 else if op == "!=" || op == "!==" then
442 else if op == "!=" || op == "!==" then
446 Report.Report "UNKNOWN OPERATOR" region ["/="] $
443 Report.Report "UNKNOWN OPERATOR" region ["/="] $
447− Report.toCodeSnippet source region Nothing
444+ Code.toSnippet source region Nothing
448 (
445 (
449 D.reflow $
446 D.reflow $
450 "Elm uses a different name for the “not equal” operator:"
447 "Elm uses a different name for the “not equal” operator:"
@@ -459,7 +456,7 @@ toReport source err =
459
456
460 else if op == "**" then
457 else if op == "**" then
461 Report.Report "UNKNOWN OPERATOR" region ["^","*"] $
458 Report.Report "UNKNOWN OPERATOR" region ["^","*"] $
462− Report.toCodeSnippet source region Nothing
459+ Code.toSnippet source region Nothing
463 (
460 (
464 D.reflow $
461 D.reflow $
465 "I do not recognize the (**) operator:"
462 "I do not recognize the (**) operator:"
@@ -470,7 +467,7 @@ toReport source err =
470
467
471 else if op == "%" then
468 else if op == "%" then
472 Report.Report "UNKNOWN OPERATOR" region [] $
469 Report.Report "UNKNOWN OPERATOR" region [] $
473− Report.toCodeSnippet source region Nothing
470+ Code.toSnippet source region Nothing
474 (
471 (
475 D.reflow $
472 D.reflow $
476 "Elm does not use (%) as the remainder operator:"
473 "Elm does not use (%) as the remainder operator:"
@@ -497,7 +494,7 @@ toReport source err =
497 D.green $ "(" <> altOp <> ")"
494 D.green $ "(" <> altOp <> ")"
498 in
495 in
499 Report.Report "UNKNOWN OPERATOR" region suggestions $
496 Report.Report "UNKNOWN OPERATOR" region suggestions $
500− Report.toCodeSnippet source region Nothing
497+ Code.toSnippet source region Nothing
501 (
498 (
502 D.reflow $
499 D.reflow $
503 "I do not recognize the (" ++ Name.toChars op ++ ") operator."
500 "I do not recognize the (" ++ Name.toChars op ++ ") operator."
@@ -515,21 +512,21 @@ toReport source err =
515
512
516 PatternHasRecordCtor region name ->
513 PatternHasRecordCtor region name ->
517 Report.Report "BAD PATTERN" region [] $
514 Report.Report "BAD PATTERN" region [] $
518− Report.toCodeSnippet source region Nothing
515+ Code.toSnippet source region Nothing
519 (
516 (
520 D.reflow $
517 D.reflow $
521 "You can construct records by using `" <> Name.toChars name
518 "You can construct records by using `" <> Name.toChars name
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 ->
529 let
526 let
530 formatDetails (aBadKindOfThing, elaboration) =
527 formatDetails (aBadKindOfThing, elaboration) =
531 Report.Report "PORT ERROR" region [] $
528 Report.Report "PORT ERROR" region [] $
532− Report.toCodeSnippet source region Nothing
529+ Code.toSnippet source region Nothing
533 (
530 (
534 D.reflow $
531 D.reflow $
535 "The `" <> Name.toChars portName <> "` port is trying to transmit " <> aBadKindOfThing <> ":"
532 "The `" <> Name.toChars portName <> "` port is trying to transmit " <> aBadKindOfThing <> ":"
@@ -595,7 +592,7 @@ toReport source err =
595 let
592 let
596 formatDetails (before, after) =
593 formatDetails (before, after) =
597 Report.Report "BAD PORT" region [] $
594 Report.Report "BAD PORT" region [] $
598− Report.toCodeSnippet source region Nothing $
595+ Code.toSnippet source region Nothing $
599 (
596 (
600 D.reflow before
597 D.reflow before
601 ,
598 ,
@@ -674,7 +671,7 @@ toReport source err =
674 D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details)
671 D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details)
675 in
672 in
676 Report.Report "CYCLIC DEFINITION" region [] $
673 Report.Report "CYCLIC DEFINITION" region [] $
677− Report.toCodeSnippet source region Nothing $
674+ Code.toSnippet source region Nothing $
678 case names of
675 case names of
679 [] ->
676 [] ->
680 (
677 (
@@ -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!"
@@ -716,7 +713,7 @@ toReport source err =
716
713
717 RecursiveLet (A.At region name) names ->
714 RecursiveLet (A.At region name) names ->
718 Report.Report "CYCLIC VALUE" region [] $
715 Report.Report "CYCLIC VALUE" region [] $
719− Report.toCodeSnippet source region Nothing $
716+ Code.toSnippet source region Nothing $
720 case names of
717 case names of
721 [] ->
718 [] ->
722 let
719 let
@@ -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!"
@@ -762,7 +759,7 @@ toReport source err =
762
759
763 Shadowing name r1 r2 ->
760 Shadowing name r1 r2 ->
764 Report.Report "SHADOWING" r2 [] $
761 Report.Report "SHADOWING" r2 [] $
765− Report.toCodePair source r1 r2
762+ Code.toPair source r1 r2
766 ( "These variables cannot have the same name:"
763 ( "These variables cannot have the same name:"
767 , advice
764 , advice
768 )
765 )
@@ -783,7 +780,7 @@ toReport source err =
783
780
784 TupleLargerThanThree region ->
781 TupleLargerThanThree region ->
785 Report.Report "BAD TUPLE" region [] $
782 Report.Report "BAD TUPLE" region [] $
786− Report.toCodeSnippet source region Nothing
783+ Code.toSnippet source region Nothing
787 (
784 (
788 "I only accept tuples with two or three items. This has too many:"
785 "I only accept tuples with two or three items. This has too many:"
789 ,
786 ,
@@ -832,7 +829,7 @@ toReport source err =
832 )
829 )
833 in
830 in
834 Report.Report title aliasRegion [] $
831 Report.Report title aliasRegion [] $
835− Report.toCodeSnippet source aliasRegion subRegion
832+ Code.toSnippet source aliasRegion subRegion
836 (
833 (
837 D.fillSep overview
834 D.fillSep overview
838 ,
835 ,
@@ -885,7 +882,7 @@ toReport source err =
885
882
886 in
883 in
887 Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] $
884 Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] $
888− Report.toCodeSnippet source aliasRegion Nothing
885+ Code.toSnippet source aliasRegion Nothing
889 (
886 (
890 D.reflow $
887 D.reflow $
891 "Type alias `" <> Name.toChars typeName <> "` has some type variable problems."
888 "Type alias `" <> Name.toChars typeName <> "` has some type variable problems."
@@ -932,7 +929,7 @@ unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion)
932 )
929 )
933 in
930 in
934 Report.Report title declRegion [] $
931 Report.Report title declRegion [] $
935− Report.toCodeSnippet source declRegion subRegion
932+ Code.toSnippet source declRegion subRegion
936 (
933 (
937 D.fillSep overview
934 D.fillSep overview
938 ,
935 ,
@@ -960,7 +957,7 @@ unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion)
960nameClash :: Code.Source -> A.Region -> A.Region -> String -> Report.Report
957nameClash :: Code.Source -> A.Region -> A.Region -> String -> Report.Report
961nameClash source r1 r2 messageThatEndsWithPunctuation =
958nameClash source r1 r2 messageThatEndsWithPunctuation =
962 Report.Report "NAME CLASH" r2 [] $
959 Report.Report "NAME CLASH" r2 [] $
963− Report.toCodePair source r1 r2
960+ Code.toPair source r1 r2
964 (
961 (
965 D.reflow messageThatEndsWithPunctuation
962 D.reflow messageThatEndsWithPunctuation
966 ,
963 ,
@@ -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− Report.toCodeSnippet 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"
@@ -1065,7 +1066,7 @@ notFound source region maybePrefix name thing (PossibleNames locals quals) =
1065
1066
1066 in
1067 in
1067 Report.Report "NAMING ERROR" region nearbyNames $
1068 Report.Report "NAMING ERROR" region nearbyNames $
1068− Report.toCodeSnippet source region Nothing
1069+ Code.toSnippet source region Nothing
1069 (
1070 (
1070 D.reflow $
1071 D.reflow $
1071 "I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":"
1072 "I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":"
@@ -1195,7 +1196,7 @@ _argMismatchReport source region kind name expected actual =
1195 <> " arguments"
1196 <> " arguments"
1196 in
1197 in
1197 Report.Report (map Char.toUpper numArgs) region [] $
1198 Report.Report (map Char.toUpper numArgs) region [] $
1198− Report.toCodeSnippet source region Nothing
1199+ Code.toSnippet source region Nothing
1199 (
1200 (
1200 D.reflow $
1201 D.reflow $
1201 kind <> " " <> Name.toChars name <> " has " <> numArgs <> "."
1202 kind <> " " <> Name.toChars name <> " has " <> numArgs <> "."
@@ -1214,7 +1215,7 @@ aliasRecursionReport source region name args tipe others =
1214 case others of
1215 case others of
1215 [] ->
1216 [] ->
1216 Report.Report "ALIAS PROBLEM" region [] $
1217 Report.Report "ALIAS PROBLEM" region [] $
1217− Report.toCodeSnippet source region Nothing
1218+ Code.toSnippet source region Nothing
1218 (
1219 (
1219 "This type alias is recursive, forming an infinite type!"
1220 "This type alias is recursive, forming an infinite type!"
1220 ,
1221 ,
@@ -1233,7 +1234,7 @@ aliasRecursionReport source region name args tipe others =
1233
1234
1234 _ ->
1235 _ ->
1235 Report.Report "ALIAS PROBLEM" region [] $
1236 Report.Report "ALIAS PROBLEM" region [] $
1236− Report.toCodeSnippet source region Nothing
1237+ Code.toSnippet source region Nothing
1237 (
1238 (
1238 "This type alias is part of a mutually recursive set of type aliases."
1239 "This type alias is part of a mutually recursive set of type aliases."
1239 ,
1240 ,
compiler/src/Reporting/Error/Docs.hs+132−23
@@ -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,11 +86,85 @@ 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+
63
101
102+
103+-- SYNTAX PROBLEM
104+
105+
106+toSyntaxProblemReport :: Code.Source -> SyntaxProblem -> Report.Report
107+toSyntaxProblemReport source problem =
108+ let
109+ toSyntaxReport row col details =
110+ let
111+ region = toRegion row col
112+ in
113+ Report.Report "PROBLEM IN DOCS" region [] $
114+ Code.toSnippet source region Nothing
115+ ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:"
116+ , D.stack $
117+ [ D.reflow details
118+ , D.toSimpleHint $
119+ "Read through <https://package.elm-lang.org/help/documentation-format> for\
120+ \ tips on how to write module documentation!"
121+ ]
122+ )
123+ in
124+ case problem of
125+ Op row col ->
126+ toSyntaxReport row col $
127+ "I am trying to parse an operator like (+) or (*) but something is going wrong."
128+
129+ OpBad _ row col ->
130+ toSyntaxReport row col $
131+ "I am trying to parse an operator like (+) or (*) but it looks like you are using\
132+ \ a reserved symbol in this case."
133+
134+ Name row col ->
135+ toSyntaxReport row col $
136+ "I was expecting to see the name of another exposed value from this module."
137+
138+ Space space row col ->
139+ E.toSpaceReport source space row col
140+
141+ Comma row col ->
142+ toSyntaxReport row col $
143+ "I was expecting to see a comma next."
144+
145+ BadEnd row col ->
146+ toSyntaxReport row col $
147+ "I am not really sure what I am getting stuck on though."
148+
149+
150+toRegion :: Row -> Col -> A.Region
151+toRegion row col =
152+ let
153+ pos = A.Position row col
154+ in
155+ A.Region pos pos
156+
157+
158+
159+-- NAME PROBLEM
160+
161+
162+toNameProblemReport :: Code.Source -> NameProblem -> Report.Report
163+toNameProblemReport source problem =
164+ case problem of
64− Duplicate name r1 r2 ->
165+ NameDuplicate name r1 r2 ->
65 Report.Report "DUPLICATE DOCS" r2 [] $
166 Report.Report "DUPLICATE DOCS" r2 [] $
66− Report.toCodePair source r1 r2
167+ Code.toPair source r1 r2
67 (
168 (
68 D.reflow $
169 D.reflow $
69 "There can only be one `" <> Name.toChars name
170 "There can only be one `" <> Name.toChars name
@@ -81,9 +182,9 @@ 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− Report.toCodeSnippet source region Nothing
187+ Code.toSnippet source region Nothing
87 (
188 (
88 D.reflow $
189 D.reflow $
89 "I do not see `" <> Name.toChars name
190 "I do not see `" <> Name.toChars name
@@ -94,9 +195,9 @@ 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− Report.toCodeSnippet source region Nothing
200+ Code.toSnippet source region Nothing
100 (
201 (
101 D.reflow $
202 D.reflow $
102 "I do not see `" <> Name.toChars name
203 "I do not see `" <> Name.toChars name
@@ -110,9 +211,17 @@ 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− Report.toCodeSnippet source region Nothing
224+ Code.toSnippet source region Nothing
116 (
225 (
117 D.reflow $
226 D.reflow $
118 "The `" <> Name.toChars name <> "` definition does not have a documentation comment."
227 "The `" <> Name.toChars name <> "` definition does not have a documentation comment."
@@ -126,7 +235,7 @@ toReport source err =
126
235
127 NoAnnotation name region ->
236 NoAnnotation name region ->
128 Report.Report "NO TYPE ANNOTATION" region [] $
237 Report.Report "NO TYPE ANNOTATION" region [] $
129− Report.toCodeSnippet source region Nothing
238+ Code.toSnippet source region Nothing
130 (
239 (
131 D.reflow $
240 D.reflow $
132 "The `" <> Name.toChars name <> "` definition does not have a type annotation."
241 "The `" <> Name.toChars name <> "` definition does not have a type annotation."
compiler/src/Reporting/Error/Import.hs+139−31
@@ -1,54 +1,162 @@
1+{-# LANGUAGE OverloadedStrings #-}
1module Reporting.Error.Import
2module Reporting.Error.Import
2 ( Error(..)
3 ( Error(..)
4+ , Problem(..)
3 , toReport
5 , toReport
4 )
6 )
5 where
7 where
6
8
7
9
10+import qualified Data.Map as Map
11+import qualified Data.Set as Set
12+
8import qualified Elm.ModuleName as ModuleName
13import qualified Elm.ModuleName as ModuleName
9import qualified Elm.Package as Pkg
14import qualified Elm.Package as Pkg
15+import qualified Reporting.Doc as D
16+import qualified Reporting.Render.Code as Code
10import qualified Reporting.Report as Report
17import qualified Reporting.Report as Report
18+import qualified Reporting.Suggest as Suggest
19+import qualified Reporting.Annotation as A
11
20
12
21
13
22
14-- ERROR
23-- ERROR
15
24
16
25
17−data Error
26+data Error =
18− = NotFound ModuleName.Raw
27+ Error
19− | Ambiguous ModuleName.Raw FilePath [FilePath] Pkg.Name [Pkg.Name]
28+ { _region :: A.Region
20− | AmbiguousLocal ModuleName.Raw FilePath FilePath [FilePath]
29+ , _import :: ModuleName.Raw
21− | AmbiguousForeign ModuleName.Raw Pkg.Name Pkg.Name [Pkg.Name]
30+ , _unimported :: Set.Set ModuleName.Raw
22−
31+ , _problem :: Problem
23−
32+ }
24−
25−-- TO REPORT
26−
27
33
28−toReport :: Error -> Report.Report
29−toReport err =
30− case err of
31− NotFound name ->
32− error "TODO NotFound" name
33
34
34− Ambiguous name path paths pkg pkgs ->
35+data Problem
35− error "TODO Ambiguous" name path paths pkg pkgs
36+ = NotFound
37+ | Ambiguous FilePath [FilePath] Pkg.Name [Pkg.Name]
38+ | AmbiguousLocal FilePath FilePath [FilePath]
39+ | AmbiguousForeign Pkg.Name Pkg.Name [Pkg.Name]
36
40
37− AmbiguousLocal name path1 path2 paths ->
38− error "TODO AmbiguousLocal" name path1 path2 paths
39
41
40− AmbiguousForeign name pkg1 pkg2 pkgs ->
41− error "TODO AmbiguousForeign" name pkg1 pkg2 pkgs
42
42
43+-- TO REPORT
43
44
44−{-
45−
46−-- MODULE NOT FOUND ---------------------------------------------- src/Main.elm
47−
48−You are trying to import a `Whatever` module:
49−
50− import Whatever
51−
52−But I cannot find `Whatever` in your project or packages.
53
45
54−-}
46+toReport :: Code.Source -> Error -> Report.Report
47+toReport source (Error region name unimportedModules problem) =
48+ case problem of
49+ NotFound ->
50+ Report.Report "MODULE NOT FOUND" region [] $
51+ Code.toSnippet source region Nothing
52+ (
53+ D.reflow $
54+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
55+ ,
56+ D.stack
57+ [
58+ D.reflow $
59+ "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json,\
60+ \ but I cannot find it! Maybe it is a typo for one of these names?"
61+ ,
62+ D.dullyellow $ D.indent 4 $ D.vcat $
63+ map D.fromName (toSuggestions name unimportedModules)
64+ ,
65+ case Map.lookup name Pkg.suggestions of
66+ Nothing ->
67+ D.toSimpleHint $
68+ "If it is not a typo, check the \"dependencies\" and \"source-directories\"\
69+ \ of your elm.json to make sure all the packages you need are listed there!"
70+
71+ Just dependency ->
72+ D.toFancyHint
73+ ["Maybe","you","want","the"
74+ ,"`" <> D.fromName name <> "`"
75+ ,"module","defined","in","the"
76+ ,D.fromChars (Pkg.toChars dependency)
77+ ,"package?","Running"
78+ ,D.green (D.fromChars ("elm install " ++ Pkg.toChars dependency))
79+ ,"should","make","it","available!"
80+ ]
81+ ]
82+ )
83+
84+ Ambiguous path _ pkg _ ->
85+ Report.Report "AMBIGUOUS IMPORT" region [] $
86+ Code.toSnippet source region Nothing
87+ (
88+ D.reflow $
89+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
90+ ,
91+ D.stack
92+ [
93+ D.fillSep $
94+ ["But","I","found","multiple","modules","with","that","name.","One","in","the"
95+ ,D.dullyellow (D.fromChars (Pkg.toChars pkg))
96+ ,"package,","and","another","defined","locally","in","the"
97+ ,D.dullyellow (D.fromChars path)
98+ ,"file.","I","do","not","have","a","way","to","choose","between","them."
99+ ]
100+ ,
101+ D.reflow $
102+ "Try changing the name of the locally defined module to clear up the ambiguity?"
103+ ]
104+ )
105+
106+ AmbiguousLocal path1 path2 paths ->
107+ Report.Report "AMBIGUOUS IMPORT" region [] $
108+ Code.toSnippet source region Nothing
109+ (
110+ D.reflow $
111+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
112+ ,
113+ D.stack
114+ [
115+ D.reflow $
116+ "But I found multiple files in your \"source-directories\" with that name:"
117+ ,
118+ D.dullyellow $ D.indent 4 $ D.vcat $
119+ map D.fromChars (path1:path2:paths)
120+ ,
121+ D.reflow $
122+ "Change the module names to be distinct!"
123+ ]
124+ )
125+
126+ AmbiguousForeign pkg1 pkg2 pkgs ->
127+ Report.Report "AMBIGUOUS IMPORT" region [] $
128+ Code.toSnippet source region Nothing
129+ (
130+ D.reflow $
131+ "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
132+ ,
133+ D.stack
134+ [
135+ D.reflow $
136+ "But multiple packages in your \"dependencies\" that expose a module that name:"
137+ ,
138+ D.dullyellow $ D.indent 4 $ D.vcat $
139+ map (D.fromChars . Pkg.toChars) (pkg1:pkg2:pkgs)
140+ ,
141+ D.reflow $
142+ "There is no way to disambiguate in cases like this right now. Of the known name\
143+ \ clashes, they are usually for packages with similar purposes, so the current\
144+ \ recommendation is to pick just one of them."
145+ , D.toSimpleNote $
146+ "It seems possible to resolve this with new syntax in imports, but that is\
147+ \ more complicated than it sounds. Right now, our module names are tied to GitHub\
148+ \ repos, but we may want to get rid of that dependency for a variety of reasons.\
149+ \ That would in turn have implications for our package infrastructure, hosting\
150+ \ costs, and possibly on how package names are specified. The particular syntax\
151+ \ chosen seems like it would interact with all these factors in ways that are\
152+ \ difficult to predict, potentially leading to harder problems later on. So more\
153+ \ design work and planning is needed on these topics."
154+ ]
155+ )
156+
157+
158+
159+toSuggestions :: ModuleName.Raw -> Set.Set ModuleName.Raw -> [ModuleName.Raw]
160+toSuggestions name unimportedModules =
161+ take 4 $
162+ Suggest.sort (ModuleName.toChars name) ModuleName.toChars (Set.toList unimportedModules)
compiler/src/Reporting/Error/Json.hs+281−269
@@ -1,332 +1,344 @@
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/Main.hs+3−3
@@ -38,7 +38,7 @@ toReport localizer source err =
38 case err of
38 case err of
39 BadType region tipe ->
39 BadType region tipe ->
40 Report.Report "BAD MAIN TYPE" region [] $
40 Report.Report "BAD MAIN TYPE" region [] $
41− Report.toCodeSnippet source region Nothing
41+ Code.toSnippet source region Nothing
42 (
42 (
43 "I cannot handle this type of `main` value:"
43 "I cannot handle this type of `main` value:"
44 ,
44 ,
@@ -53,7 +53,7 @@ toReport localizer source err =
53
53
54 BadCycle region name names ->
54 BadCycle region name names ->
55 Report.Report "BAD MAIN" region [] $
55 Report.Report "BAD MAIN" region [] $
56− Report.toCodeSnippet source region Nothing
56+ Code.toSnippet source region Nothing
57 (
57 (
58 "A `main` definition cannot be defined in terms of itself."
58 "A `main` definition cannot be defined in terms of itself."
59 ,
59 ,
@@ -69,7 +69,7 @@ toReport localizer source err =
69 let
69 let
70 formatDetails (aBadKindOfThing, butThatIsNoGood) =
70 formatDetails (aBadKindOfThing, butThatIsNoGood) =
71 Report.Report "BAD FLAGS" region [] $
71 Report.Report "BAD FLAGS" region [] $
72− Report.toCodeSnippet source region Nothing
72+ Code.toSnippet source region Nothing
73 (
73 (
74 D.reflow $
74 D.reflow $
75 "Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript."
75 "Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript."
compiler/src/Reporting/Error/Pattern.hs+9−8
@@ -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
@@ -24,7 +25,7 @@ toReport source err =
24 case err of
25 case err of
25 P.Redundant caseRegion patternRegion index ->
26 P.Redundant caseRegion patternRegion index ->
26 Report.Report "REDUNDANT PATTERN" patternRegion [] $
27 Report.Report "REDUNDANT PATTERN" patternRegion [] $
27− Report.toCodeSnippet source caseRegion (Just patternRegion)
28+ Code.toSnippet source caseRegion (Just patternRegion)
28 (
29 (
29 D.reflow $
30 D.reflow $
30 "The " <> D.intToOrdinal index <> " pattern is redundant:"
31 "The " <> D.intToOrdinal index <> " pattern is redundant:"
@@ -38,9 +39,9 @@ toReport source err =
38 case context of
39 case context of
39 P.BadArg ->
40 P.BadArg ->
40 Report.Report "UNSAFE PATTERN" region [] $
41 Report.Report "UNSAFE PATTERN" region [] $
41− Report.toCodeSnippet 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:"
@@ -54,7 +55,7 @@ toReport source err =
54
55
55 P.BadDestruct ->
56 P.BadDestruct ->
56 Report.Report "UNSAFE PATTERN" region [] $
57 Report.Report "UNSAFE PATTERN" region [] $
57− Report.toCodeSnippet source region Nothing
58+ Code.toSnippet source region Nothing
58 (
59 (
59 "This pattern does not cover all possible values:"
60 "This pattern does not cover all possible values:"
60 ,
61 ,
@@ -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\
@@ -74,7 +75,7 @@ toReport source err =
74
75
75 P.BadCase ->
76 P.BadCase ->
76 Report.Report "MISSING PATTERNS" region [] $
77 Report.Report "MISSING PATTERNS" region [] $
77− Report.toCodeSnippet source region Nothing
78+ Code.toSnippet source region Nothing
78 (
79 (
79 "This `case` does not have branches for all possibilities:"
80 "This `case` does not have branches for all possibilities:"
80 ,
81 ,
@@ -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+5184−910

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Report.hs−40

This diff is too big to show here.

compiler/src/Reporting/Result.hs+10

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Type/Solve.hs+7

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

This diff is too big to show here.

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

The content is the same.

elm.cabal+34−16

This diff is too big to show here.

hints/bad-recursion.mdnew file+133

This diff is too big to show here.

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

This diff is too big to show here.

hints/comparing-records.mdnew file+85

This diff is too big to show here.

hints/implicit-casts.mdnew file+50

This diff is too big to show here.

hints/import-cycles.mdnew file+184

This diff is too big to show here.

hints/imports.mdnew file+126

This diff is too big to show here.

hints/infinite-type.mdnew file+42

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.mdnew file+139

This diff is too big to show here.

hints/optimize.mdnew file+59

This diff is too big to show here.

hints/port-modules.mdnew file+32

This diff is too big to show here.

hints/recursive-alias.mdnew file+162

This diff is too big to show here.

hints/repl.mdnew file+73

This diff is too big to show here.

hints/shadowing.mdnew file+70

This diff is too big to show here.

hints/tuples.mdnew file+19

This diff is too big to show here.

hints/type-annotations.mdnew file+60

This diff is too big to show here.

installers/README.mdnew file+32

This diff is too big to show here.

installers/linux/Dockerfilenew file+39

This diff is too big to show here.

installers/linux/README.mdnew file+93

This diff is too big to show here.

installers/mac/Distribution.xml+5−3

This diff is too big to show here.

installers/mac/README.mdnew file+93

This diff is too big to show here.

installers/mac/Resources/en.lproj/background.pngdeleted

Binary file not shown.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/PUBLISHING.md+29−141

This diff is too big to show here.

installers/npm/README.md+30−23

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/index.jsdeleted−21

This diff is too big to show here.

installers/npm/install.jsnew file+4

This diff is too big to show here.

installers/npm/package.json+13−15

This diff is too big to show here.

installers/npm/troubleshooting.mdnew file+76

This diff is too big to show here.

installers/win/Nsisfile.nsi+16−16

This diff is too big to show here.

installers/win/README.md+18−3

This diff is too big to show here.

installers/win/file.icodeleted

Binary file not shown.

installers/win/inst.dat+1−2

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+1−2

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifdeleted

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+20−15

This diff is too big to show here.

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

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Bump.hs+158−8

This diff is too big to show here.

terminal/src/Develop.hs+70−77

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Diff.hs+348−6

This diff is too big to show here.

terminal/src/Init.hs+2−1

This diff is too big to show here.

terminal/src/Install.hs+16−31

This diff is too big to show here.

terminal/src/Main.hs+32−36

This diff is too big to show here.

terminal/src/Make.hs+113−268

This diff is too big to show here.

terminal/src/Publish.hs+529−8

This diff is too big to show here.

terminal/src/Repl.hs+522−197

This diff is too big to show here.

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

This diff is too big to show here.

worker/elm.cabalnew file+210

This diff is too big to show here.

worker/elm.jsonnew file+26

This diff is too big to show here.

worker/nginx.confnew file+22

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Artifacts.hsnew file+155

This diff is too big to show here.

worker/src/Cors.hsnew file+48

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Errors.elmnew file+217

This diff is too big to show here.

worker/src/Main.hsnew file+73

This diff is too big to show here.